From: ivan Date: Sat, 3 Nov 2001 17:49:52 +0000 (+0000) Subject: new 'jsearch' call for big joined searches & caching support X-Git-Tag: freeside_1_4_0pre11~234 X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=commitdiff_plain;h=fd72d2af8120195f96826eb044e217dbfcaee1c7 new 'jsearch' call for big joined searches & caching support preliminary customer browse optimizations, much faster! --- diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index ec326458d..3c8e9bac6 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -9,9 +9,10 @@ use File::CounterFile; use Locale::Country; use DBIx::DBSchema 0.19; use FS::UID qw(dbh checkruid getotaker datasrc driver_name); +use FS::SearchCache; @ISA = qw(Exporter); -@EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef); +@EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch); $DEBUG = 0; @@ -135,9 +136,31 @@ sub new { } } + $self->_cache($hashref, shift) if $self->can('_cache') && @_; + $self; } +sub new_or_cached { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + bless ($self, $class); + + $self->{'Table'} = shift unless defined ( $self->table ); + + my $hashref = $self->{'Hash'} = shift; + my $cache = shift; + if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) { + my $obj = $cache->cache->{$hashref->{$cache->key}}; + $obj->_cache($hashref, $cache) if $obj->can('_cache'); + $obj; + } else { + $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache); + } + +} + sub create { my $proto = shift; my $class = ref($proto) || $proto; @@ -170,15 +193,19 @@ objects. =cut sub qsearch { - my($table, $record, $select, $extra_sql ) = @_; - $table =~ /^([\w\_]+)$/ or die "Illegal table: $table"; - $table = $1; + my($stable, $record, $select, $extra_sql, $cache ) = @_; + #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table"; + #for jsearch + $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable"; + $stable = $1; $select ||= '*'; my $dbh = dbh; + my $table = $cache ? $cache->table : $stable; + my @fields = grep exists($record->{$_}), fields($table); - my $statement = "SELECT $select FROM $table"; + my $statement = "SELECT $select FROM $stable"; if ( @fields ) { $statement .= ' WHERE '. join(' AND ', map { if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) { @@ -206,9 +233,15 @@ sub qsearch { if ( eval 'scalar(@FS::'. $table. '::ISA);' ) { if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) { #derivied class didn't override new method, so this optimization is safe - map { - new( "FS::$table", { %{$_} } ) - } @{$sth->fetchall_arrayref( {} )}; + if ( $cache ) { + map { + new_or_cached( "FS::$table", { %{$_} }, $cache ) + } @{$sth->fetchall_arrayref( {} )}; + } else { + map { + new( "FS::$table", { %{$_} } ) + } @{$sth->fetchall_arrayref( {} )}; + } } else { warn "untested code (class FS::$table uses custom new method)"; map { @@ -224,6 +257,25 @@ sub qsearch { } +=item jsearch + +Experimental JOINed search method. Using this method, you can execute a +single SELECT spanning multiple tables, and cache the results for subsequent +method calls. Interface will almost definately change in an incompatible +fashion. + +=cut + +sub jsearch { + my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_; + my $cache = FS::SearchCache->new( $ptable, $pkey ); + my %saw; + ( $cache, + grep { !$saw{$_->getfield($pkey)}++ } + qsearch($table, $record, $select, $extra_sql, $cache ) + ); +} + =item qsearchs TABLE, HASHREF Same as qsearch, except that if more than one record matches, it Bs but @@ -312,16 +364,30 @@ $record->column('value') is a synonym for $record->set('column','value'); =cut +# readable/safe +#sub AUTOLOAD { +# my($self,$value)=@_; +# my($field)=$AUTOLOAD; +# $field =~ s/.*://; +# if ( defined($value) ) { +# confess "errant AUTOLOAD $field for $self (arg $value)" +# unless $self->can('setfield'); +# $self->setfield($field,$value); +# } else { +# confess "errant AUTOLOAD $field for $self (no args)" +# unless $self->can('getfield'); +# $self->getfield($field); +# } +#} + +# efficient sub AUTOLOAD { - my($self,$value)=@_; - my($field)=$AUTOLOAD; + my $field = $AUTOLOAD; $field =~ s/.*://; - if ( defined($value) ) { - confess "errant AUTOLOAD $field for $self (arg $value)" - unless $self->can('setfield'); - $self->setfield($field,$value); + if ( scalar(@_) == 2 ) { + $_[0]->setfield($field, $_[1]); } else { - $self->getfield($field); + $_[0]->getfield($field); } } @@ -992,10 +1058,6 @@ sub DESTROY { return; } =back -=head1 VERSION - -$Id: Record.pm,v 1.31 2001-11-02 05:11:52 ivan Exp $ - =head1 BUGS This module should probably be renamed, since much of the functionality is diff --git a/FS/FS/SearchCache.pm b/FS/FS/SearchCache.pm new file mode 100644 index 000000000..4218acfb6 --- /dev/null +++ b/FS/FS/SearchCache.pm @@ -0,0 +1,96 @@ +package FS::SearchCache; + +use strict; +use vars qw($DEBUG); +#use Carp qw(carp cluck croak confess); + +$DEBUG = 0; + +=head1 NAME + +FS::SearchCache - cache + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=item new + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my( $table, $key ) = @_; + warn "table $table\n" if $DEBUG > 1; + warn "key $key\n" if $DEBUG > 1; + my $self = { 'table' => $table, + 'key' => $key, + 'cache' => {}, + 'subcache' => {}, + }; + bless ($self, $class); + + $self; +} + +=item table + +=cut + +sub table { my $self = shift; $self->{table}; } + +=item key + +=cut + +sub key { my $self = shift; $self->{key}; } + +=item cache + +=cut + +sub cache { my $self = shift; $self->{cache}; } + +=item subcache + +=cut + +sub subcache { + my $self = shift; + my $col = shift; + my $table = shift; + my $keyval = shift; + if ( exists $self->{subcache}->{$col}->{$keyval} ) { + warn "returning existing subcache for $keyval ($col)". + "$self->{subcache}->{$col}->{$keyval}\n" if $DEBUG; + return $self->{subcache}->{$col}->{$keyval}; + } else { + #my $tablekey = @_ ? shift : $col; + my $tablekey = $col; + my $subcache = ref($self)->new( $table, $tablekey ); + $self->{subcache}->{$col}->{$keyval} = $subcache; + warn "creating new subcache $table $tablekey: $subcache\n" if $DEBUG; + $subcache; + } +} + +=back + +=head1 BUGS + +Dismal documentation. + +=head1 SEE ALSO + +L, L + +=cut + +1; + + diff --git a/FS/FS/cust_main.pm b/FS/FS/cust_main.pm index dfb712502..4c4fe8702 100644 --- a/FS/FS/cust_main.pm +++ b/FS/FS/cust_main.pm @@ -75,6 +75,18 @@ $FS::UID::callback{'FS::cust_main'} = sub { } }; +sub _cache { + my $self = shift; + my ( $hashref, $cache ) = @_; + if ( exists $hashref->{'pkgnum'} ) { +# #@{ $self->{'_pkgnum'} } = (); + my $subcache = $cache->subcache( 'pkgnum', 'cust_pkg', $hashref->{custnum}); + $self->{'_pkgnum'} = $subcache; + #push @{ $self->{'_pkgnum'} }, + FS::cust_pkg->new_or_cached($hashref, $subcache) if $hashref->{pkgnum}; + } +} + =head1 NAME FS::cust_main - Object methods for cust_main records @@ -701,7 +713,11 @@ Returns all packages (see L) for this customer. sub all_pkgs { my $self = shift; - qsearch( 'cust_pkg', { 'custnum' => $self->custnum }); + if ( $self->{'_pkgnum'} ) { + values %{ $self->{'_pkgnum'}->cache }; + } else { + qsearch( 'cust_pkg', { 'custnum' => $self->custnum }); + } } =item ncancelled_pkgs @@ -712,16 +728,20 @@ Returns all non-cancelled packages (see L) for this customer. sub ncancelled_pkgs { my $self = shift; - @{ [ # force list context - qsearch( 'cust_pkg', { - 'custnum' => $self->custnum, - 'cancel' => '', - }), - qsearch( 'cust_pkg', { - 'custnum' => $self->custnum, - 'cancel' => 0, - }), - ] }; + if ( $self->{'_pkgnum'} ) { + grep { ! $_->getfield('cancel') } values %{ $self->{'_pkgnum'}->cache }; + } else { + @{ [ # force list context + qsearch( 'cust_pkg', { + 'custnum' => $self->custnum, + 'cancel' => '', + }), + qsearch( 'cust_pkg', { + 'custnum' => $self->custnum, + 'cancel' => 0, + }), + ] }; + } } =item suspended_pkgs @@ -1855,7 +1875,7 @@ sub append_fuzzyfiles { =head1 VERSION -$Id: cust_main.pm,v 1.44 2001-10-22 08:31:25 ivan Exp $ +$Id: cust_main.pm,v 1.45 2001-11-03 17:49:52 ivan Exp $ =head1 BUGS diff --git a/FS/FS/cust_pkg.pm b/FS/FS/cust_pkg.pm index 7aee8d027..19e1da356 100644 --- a/FS/FS/cust_pkg.pm +++ b/FS/FS/cust_pkg.pm @@ -20,6 +20,27 @@ use FS::svc_www; @ISA = qw( FS::Record ); +sub _cache { + my $self = shift; + my ( $hashref, $cache ) = @_; + #if ( $hashref->{'pkgpart'} ) { + if ( $hashref->{'pkg'} ) { + # #@{ $self->{'_pkgnum'} } = (); + # my $subcache = $cache->subcache('pkgpart', 'part_pkg'); + # $self->{'_pkgpart'} = $subcache; + # #push @{ $self->{'_pkgnum'} }, + # FS::part_pkg->new_or_cached($hashref, $subcache); + $self->{'_pkgpart'} = FS::part_pkg->new($hashref); + } + if ( exists $hashref->{'svcnum'} ) { + #@{ $self->{'_pkgnum'} } = (); + my $subcache = $cache->subcache('svcnum', 'cust_svc', $hashref->{pkgnum}); + $self->{'_svcnum'} = $subcache; + #push @{ $self->{'_pkgnum'} }, + FS::cust_svc->new_or_cached($hashref, $subcache) if $hashref->{svcnum}; + } +} + =head1 NAME FS::cust_pkg - Object methods for cust_pkg objects @@ -420,7 +441,26 @@ L). sub part_pkg { my $self = shift; - qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); + #exists( $self->{'_pkgpart'} ) + $self->{'_pkgpart'} + ? $self->{'_pkgpart'} + : qsearchs( 'part_pkg', { 'pkgpart' => $self->pkgpart } ); +} + +=item cust_svc + +Returns the services for this package, as FS::cust_svc objects (see +L) + +=cut + +sub cust_svc { + my $self = shift; + if ( $self->{'_svcnum'} ) { + values %{ $self->{'_svcnum'}->cache }; + } else { + qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } ); + } } =item labels @@ -432,7 +472,7 @@ Returns a list of lists, calling the label method for all services sub labels { my $self = shift; - map { [ $_->label ] } qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } ); + map { [ $_->label ] } $self->cust_svc; } =item cust_main @@ -589,7 +629,7 @@ sub order { =head1 VERSION -$Id: cust_pkg.pm,v 1.12 2001-10-22 08:29:42 ivan Exp $ +$Id: cust_pkg.pm,v 1.13 2001-11-03 17:49:52 ivan Exp $ =head1 BUGS diff --git a/FS/FS/cust_svc.pm b/FS/FS/cust_svc.pm index daec79fe8..c398e5ecd 100644 --- a/FS/FS/cust_svc.pm +++ b/FS/FS/cust_svc.pm @@ -14,6 +14,17 @@ use FS::svc_forward; @ISA = qw( FS::Record ); +sub _cache { + my $self = shift; + my ( $hashref, $cache ) = @_; + if ( $hashref->{'username'} ) { + $self->{'_svc_acct'} = FS::svc_acct->new($hashref, ''); + } + if ( $hashref->{'svc'} ) { + $self->{'_svcpart'} = FS::part_svc->new($hashref); + } +} + =head1 NAME FS::cust_svc - Object method for cust_svc objects @@ -109,6 +120,20 @@ sub check { ''; #no error } +=item part_svc + +Returns the definition for this service, as a FS::part_svc object (see +L). + +=cut + +sub part_svc { + my $self = shift; + $self->{'_svcpart'} + ? $self->{'_svcpart'} + : qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } ); +} + =item label Returns a list consisting of: @@ -120,11 +145,14 @@ Returns a list consisting of: sub label { my $self = shift; - my $part_svc = qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } ); - my $svcdb = $part_svc->svcdb; - my $svc_x = qsearchs( $svcdb, { 'svcnum' => $self->svcnum } ) - or die "can't find $svcdb.svcnum ". $self->svcnum; - my $svc = $part_svc->svc; + my $svcdb = $self->part_svc->svcdb; + my $svc_x; + if ( $svcdb eq 'svc_acct' && $self->{'_svc_acct'} ) { + $svc_x = $self->{'_svc_acct'}; + } else { + $svc_x = qsearchs( $svcdb, { 'svcnum' => $self->svcnum } ) + or die "can't find $svcdb.svcnum ". $self->svcnum; + } my $tag; if ( $svcdb eq 'svc_acct' ) { $tag = $svc_x->email; @@ -148,14 +176,14 @@ sub label { cluck "warning: asked for label of unsupported svcdb; using svcnum"; $tag = $svc_x->getfield('svcnum'); } - $svc, $tag, $svcdb; + $self->part_svc->svc, $tag, $svcdb; } =back =head1 VERSION -$Id: cust_svc.pm,v 1.5 2001-09-03 22:07:38 ivan Exp $ +$Id: cust_svc.pm,v 1.6 2001-11-03 17:49:52 ivan Exp $ =head1 BUGS diff --git a/FS/FS/svc_acct.pm b/FS/FS/svc_acct.pm index 3e7230f49..219d8d404 100644 --- a/FS/FS/svc_acct.pm +++ b/FS/FS/svc_acct.pm @@ -85,6 +85,18 @@ $FS::UID::callback{'FS::svc_acct'} = sub { #not needed in 5.004 #srand($$|time); +sub _cache { + my $self = shift; + my ( $hashref, $cache ) = @_; + if ( $hashref->{'svc_acct_svcnum'} ) { + $self->{'_domsvc'} = FS::svc_domain->new( { + 'svcnum' => $hashref->{'domsvc'}, + 'domain' => $hashref->{'svc_acct_domain'}, + 'catchall' => $hashref->{'svc_acct_catchall'}, + } ); + } +} + =head1 NAME FS::svc_acct - Object methods for svc_acct records @@ -880,7 +892,8 @@ Returns the domain associated with this account. sub domain { my $self = shift; if ( $self->domsvc ) { - my $svc_domain = qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } ) + #$self->svc_domain->domain; + my $svc_domain = $self->svc_domain or die "no svc_domain.svcnum for svc_acct.domsvc ". $self->domsvc; $svc_domain->domain; } else { @@ -888,6 +901,20 @@ sub domain { } } +=item svc_domain + +Returns the FS::svc_domain record for this account's domain (see +L{'_domsvc'} + ? $self->{'_domsvc'} + : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } ); +} + =item email Returns an email address associated with the account. @@ -931,7 +958,7 @@ sub ssh { =head1 VERSION -$Id: svc_acct.pm,v 1.52 2001-10-24 15:29:30 ivan Exp $ +$Id: svc_acct.pm,v 1.53 2001-11-03 17:49:52 ivan Exp $ =head1 BUGS diff --git a/FS/MANIFEST b/FS/MANIFEST index 4254514a2..c83fad5c9 100644 --- a/FS/MANIFEST +++ b/FS/MANIFEST @@ -14,6 +14,7 @@ FS/CGI.pm FS/Conf.pm FS/ConfItem.pm FS/Record.pm +FS/SearchCache.pm FS/UI/Base.pm FS/UI/CGI.pm FS/UI/Gtk.pm diff --git a/FS/t/SearchCache.t b/FS/t/SearchCache.t new file mode 100644 index 000000000..3c26f3528 --- /dev/null +++ b/FS/t/SearchCache.t @@ -0,0 +1,5 @@ +BEGIN { $| = 1; print "1..1\n" } +END {print "not ok 1\n" unless $loaded;} +use FS::SearchCache; +$loaded=1; +print "ok 1\n"; diff --git a/httemplate/search/cust_main.cgi b/httemplate/search/cust_main.cgi index a52321de3..db33df784 100755 --- a/httemplate/search/cust_main.cgi +++ b/httemplate/search/cust_main.cgi @@ -1,5 +1,5 @@ <% -# +# use strict; #use vars qw( $conf %ncancelled_pkgs %all_pkgs $cgi @cust_main $sortby ); @@ -9,7 +9,7 @@ use CGI::Carp qw(fatalsToBrowser); use IO::Handle; use String::Approx qw(amatch); use FS::UID qw(cgisuidsetup); -use FS::Record qw(qsearch qsearchs dbdef); +use FS::Record qw(qsearch qsearchs dbdef jsearch); use FS::CGI qw(header menubar eidiot popurl table); use FS::cust_main; use FS::cust_svc; @@ -19,17 +19,59 @@ cgisuidsetup($cgi); $conf = new FS::Conf; +my $cache; + +#my $monsterjoin = <param('browse') ) { my $query = $cgi->param('browse'); if ( $query eq 'custnum' ) { $sortby=\*custnum_sort; - @cust_main=qsearch('cust_main',{}); +# @cust_main=qsearch('cust_main',{}); + ( $cache, @cust_main ) = + jsearch($monsterjoin, {}, '', '', 'cust_main', 'custnum' ); } elsif ( $query eq 'last' ) { $sortby=\*last_sort; - @cust_main=qsearch('cust_main',{}); +# @cust_main=qsearch('cust_main',{}); + ( $cache, @cust_main ) = + jsearch($monsterjoin, {}, '', '', 'cust_main', 'custnum' ); } elsif ( $query eq 'company' ) { $sortby=\*company_sort; - @cust_main=qsearch('cust_main',{}); +# @cust_main=qsearch('cust_main',{}); + ( $cache, @cust_main ) = + jsearch($monsterjoin, {}, '', '', 'cust_main', 'custnum' ); } else { die "unknown browse field $query"; } @@ -50,6 +92,7 @@ if ( $conf->exists('hidecancelledpackages' ) ) { } else { %all_pkgs = map { $_->custnum => [ $_->all_pkgs ] } @cust_main; } +#%all_pkgs = (); if ( scalar(@cust_main) == 1 && ! $cgi->param('referral_custnum') ) { print $cgi->redirect(popurl(2). "view/cust_main.cgi?". $cust_main[0]->custnum); @@ -58,7 +101,7 @@ if ( scalar(@cust_main) == 1 && ! $cgi->param('referral_custnum') ) { eidiot "No matching customers found!\n"; } else { - my($total)=scalar(@cust_main); + my $total = scalar(@cust_main); print header("Customer Search Results",menubar( 'Main Menu', popurl(2) )), "$total matching customers found "; @@ -128,6 +171,7 @@ print <custnum}++, @cust_main) ) { @@ -141,13 +185,14 @@ END my(@lol_cust_svc); my($rowspan)=0;#scalar( @{$all_pkgs{$custnum}} ); foreach ( @{$all_pkgs{$custnum}} ) { - my(@cust_svc) = qsearch( 'cust_svc', { 'pkgnum' => $_->pkgnum } ); + #my(@cust_svc) = qsearch( 'cust_svc', { 'pkgnum' => $_->pkgnum } ); + my @cust_svc = $_->cust_svc; push @lol_cust_svc, \@cust_svc; $rowspan += scalar(@cust_svc) || 1; } #my($rowspan) = scalar(@{$all_pkgs{$custnum}}); - my($view) = popurl(2). "view/cust_main.cgi?$custnum"; + my $view = $p. 'view/cust_main.cgi?'. $custnum; print < $custnum @@ -168,10 +213,13 @@ END my($n1)=''; foreach ( @{$all_pkgs{$custnum}} ) { - my($pkgnum) = ($_->pkgnum); - my($pkg) = $_->part_pkg->pkg; - my $comment = $_->part_pkg->comment; - my($pkgview) = popurl(2). "/view/cust_pkg.cgi?$pkgnum"; + my $pkgnum = $_->pkgnum; +# my $part_pkg = qsearchs( 'part_pkg', { pkgpart => $_->pkgpart } ); + my $part_pkg = $_->part_pkg; + + my $pkg = $part_pkg->pkg; + my $comment = $part_pkg->comment; + my $pkgview = $p. 'view/cust_pkg.cgi?'. $pkgnum; my @cust_svc = @{shift @lol_cust_svc}; #my(@cust_svc) = qsearch( 'cust_svc', { 'pkgnum' => $_->pkgnum } ); my $rowspan = scalar(@cust_svc) || 1; @@ -181,7 +229,7 @@ END foreach my $cust_svc ( @cust_svc ) { my($label, $value, $svcdb) = $cust_svc->label; my($svcnum) = $cust_svc->svcnum; - my($sview) = popurl(2). "/view"; + my($sview) = $p.'view'; print $n2,qq!$label!, qq!$value!; $n2="";