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;
}
}
+ $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;
=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 '' ) {
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 {
}
+=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 B<carp>s but
=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);
}
}
=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
--- /dev/null
+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<FS::Record>, L<FS::cust_main>
+
+=cut
+
+1;
+
+
}
};
+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
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
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
=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
@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
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<FS::cust_svc>)
+
+=cut
+
+sub cust_svc {
+ my $self = shift;
+ if ( $self->{'_svcnum'} ) {
+ values %{ $self->{'_svcnum'}->cache };
+ } else {
+ qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } );
+ }
}
=item labels
sub labels {
my $self = shift;
- map { [ $_->label ] } qsearch ( 'cust_svc', { 'pkgnum' => $self->pkgnum } );
+ map { [ $_->label ] } $self->cust_svc;
}
=item cust_main
=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
@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
''; #no error
}
+=item part_svc
+
+Returns the definition for this service, as a FS::part_svc object (see
+L<FS::part_svc>).
+
+=cut
+
+sub part_svc {
+ my $self = shift;
+ $self->{'_svcpart'}
+ ? $self->{'_svcpart'}
+ : qsearchs( 'part_svc', { 'svcpart' => $self->svcpart } );
+}
+
=item label
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;
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
#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
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 {
}
}
+=item svc_domain
+
+Returns the FS::svc_domain record for this account's domain (see
+L<FS::svc_domain).
+
+=cut
+
+sub svc_domain {
+ my $self = shift;
+ $self->{'_domsvc'}
+ ? $self->{'_domsvc'}
+ : qsearchs( 'svc_domain', { 'svcnum' => $self->domsvc } );
+}
+
=item email
Returns an email address associated with the account.
=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
FS/Conf.pm
FS/ConfItem.pm
FS/Record.pm
+FS/SearchCache.pm
FS/UI/Base.pm
FS/UI/CGI.pm
FS/UI/Gtk.pm
--- /dev/null
+BEGIN { $| = 1; print "1..1\n" }
+END {print "not ok 1\n" unless $loaded;}
+use FS::SearchCache;
+$loaded=1;
+print "ok 1\n";
<%
-#<!-- $Id: cust_main.cgi,v 1.13 2001-11-01 00:16:24 ivan Exp $ -->
+#<!-- $Id: cust_main.cgi,v 1.14 2001-11-03 17:49:52 ivan Exp $ -->
use strict;
#use vars qw( $conf %ncancelled_pkgs %all_pkgs $cgi @cust_main $sortby );
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;
$conf = new FS::Conf;
+my $cache;
+
+#my $monsterjoin = <<END;
+#cust_main left outer join (
+# ( cust_pkg left outer join part_pkg using(pkgpart)
+# ) left outer join (
+# (
+# (
+# ( cust_svc left outer join part_svc using (svcpart)
+# ) left outer join svc_acct using (svcnum)
+# ) left outer join svc_domain using(svcnum)
+# ) left outer join svc_forward using(svcnum)
+# ) using (pkgnum)
+#) using (custnum)
+#END
+
+my $monsterjoin = <<END;
+cust_main left outer join (
+ ( cust_pkg left outer join part_pkg using(pkgpart)
+ ) left outer join (
+ (
+ (
+ ( cust_svc left outer join part_svc using (svcpart)
+ ) left outer join (
+ svc_acct left outer join (
+ select svcnum, domain, catchall from svc_domain
+ ) as svc_acct_domsvc (
+ svc_acct_svcnum, svc_acct_domain, svc_acct_catchall
+ ) on svc_acct.domsvc = svc_acct_domsvc.svc_acct_svcnum
+ ) using (svcnum)
+ ) left outer join svc_domain using(svcnum)
+ ) left outer join svc_forward using(svcnum)
+ ) using (pkgnum)
+) using (custnum)
+END
+
if ( $cgi->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";
}
} 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);
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 ";
END
my(%saw,$cust_main);
+ my $p = popurl(2);
foreach $cust_main (
sort $sortby grep(!$saw{$_->custnum}++, @cust_main)
) {
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 <<END;
<TR>
<TD ROWSPAN=$rowspan><A HREF="$view"><FONT SIZE=-1>$custnum</FONT></A></TD>
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;
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!<TD><A HREF="$sview/$svcdb.cgi?$svcnum"><FONT SIZE=-1>$label</FONT></A></TD>!,
qq!<TD><A HREF="$sview/$svcdb.cgi?$svcnum"><FONT SIZE=-1>$value</FONT></A></TD>!;
$n2="</TR><TR>";
projects / freeside.git / commitdiff