FS::Record::qsearch - more portable, doesn't depend on $sth->execute returning

a number of rows, uses placeholders and prepare_cached

4 files changed, 80 insertions, 49 deletions

diff --git a/CREDITS b/CREDITS
index c6063b9f2..9dbed100d 100644
--- a/CREDITS
+++ b/CREDITS
@@ -58,5 +58,8 @@ and probably other things too (sorry if I forgot them).
 Kenny Elliott <kenny@neoserve.com> contributed ICRADIUS radreply table support,
 allowing attributes with ICRADIUS.
 
+Stephen Amadei <amadei@dandy.net> contribued portability cleanups for the
+low-level DBI stuff.
+
 Everything else is my (Ivan Kohler <ivan@420.am>) fault.
 
diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm
index dae9f3707..0d989e300 100644
--- a/FS/FS/Record.pm
+++ b/FS/FS/Record.pm
@@ -1,17 +1,20 @@
 package FS::Record;
 
 use strict;
-use vars qw($dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK);
+use vars qw($dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK $DEBUG);
 use subs qw(reload_dbdef);
 use Exporter;
 use Carp qw(carp cluck croak confess);
 use File::CounterFile;
-use FS::UID qw(dbh checkruid swapuid getotaker datasrc);
+use FS::UID qw(dbh checkruid swapuid getotaker datasrc driver_name);
 use FS::dbdef;
+use diagnostics;
 
 @ISA = qw(Exporter);
 @EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef);
 
+$DEBUG = 0;
+
 #ask FS::UID to run this stuff for us later
 $FS::UID::callback{'FS::Record'} = sub { 
   $File::CounterFile::DEFAULT_DIR = "/usr/local/etc/freeside/counters.". datasrc;
@@ -124,7 +127,7 @@ sub new {
     $hashref->{$field}='' unless defined $hashref->{$field};
     #trim the '$' and ',' from money fields for Pg (belong HERE?)
     #(what about Pg i18n?)
-    if ( datasrc =~ m/Pg/ 
+    if ( driver_name eq 'Pg' 
          && $self->dbdef_table->column($field)->type eq 'money' ) {
       ${$hashref}{$field} =~ s/^\$//;
       ${$hashref}{$field} =~ s/\,//;
@@ -157,37 +160,50 @@ objects.
 =cut
 
 sub qsearch {
-  my($table,$record) = @_;
-  my($dbh) = dbh;
+  my($table, $record) = @_;
+  my $dbh = dbh;
+
+  my @fields = grep exists($record->{$_}), fields($table);
+
+  my $statement = "SELECT * FROM $table";
+  if ( @fields ) {
+    $statement .= " WHERE ". join(' AND ', map {
+      if ( $record->{$_} eq '' || $record->{$_} eq undef ) {
+        if ( driver_name eq 'Pg' ) {
+          "$_ IS NULL";
+        } else {
+          qq-( $_ IS NULL OR $_ = "" )-;
+        }
+      } else {
+        "$_ = ?";
+      }
+    } @fields );
+  }
 
-  my(@fields)=grep exists($record->{$_}), fields($table);
+  warn $statement if $DEBUG;
+  my $sth = $dbh->prepare_cached($statement) or croak $dbh->errstr;
 
-  my($sth);
-  my($statement) = "SELECT * FROM $table". ( @fields
-    ? " WHERE ". join(' AND ',
-      map {
-        $record->{$_} eq ''
-          ? ( datasrc =~ m/Pg/
-                ? "$_ IS NULL"
-                : "( $_ IS NULL OR $_ = \"\" )"
-            )
-          : "$_ = ". _quote($record->{$_},$table,$_)
-      } @fields
-    ) : ''
-  );
-  $sth=$dbh->prepare($statement)
-    or croak $dbh->errstr; #is that a little too harsh?  hmm.
-  #warn $statement #if $debug # or some such;
+  $sth->execute( map $record->{$_},
+    grep $record->{$_} ne '' && $record->{$_} ne undef, @fields
+  ) or croak $dbh->errstr;
 
-  if ( eval ' scalar(@FS::'. $table. '::ISA);' ) {
-    map {
-      eval 'new FS::'. $table. ' ( $sth->fetchrow_hashref );';
-    } ( 1 .. $sth->execute );
+  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( {} )};
+    } else {
+      warn "untested code (class FS::$table uses custom new method)";
+      map {
+        eval 'FS::'. $table. '->new( { %{$_} } )';
+      } @{$sth->fetchall_arrayref( {} )};
+    }
   } else {
-    cluck "qsearch: warning: FS::$table not loaded; returning generic FS::Record objects";
+    cluck "warning: FS::$table not loaded; returning FS::Record objects";
     map {
-      new FS::Record ($table,$sth->fetchrow_hashref);
-    } ( 1 .. $sth->execute );
+      FS::Record->new( $table, { %{$_} } );
+    } @{$sth->fetchall_arrayref( {} )};
   }
 
 }
@@ -390,7 +406,7 @@ sub delete {
     map {
       $self->getfield($_) eq ''
         #? "( $_ IS NULL OR $_ = \"\" )"
-        ? ( datasrc =~ m/Pg/
+        ? ( driver_name eq 'Pg' 
               ? "$_ IS NULL"
               : "( $_ IS NULL OR $_ = \"\" )"
           )
@@ -462,7 +478,7 @@ sub replace {
       map {
         $old->getfield($_) eq ''
           #? "( $_ IS NULL OR $_ = \"\" )"
-          ? ( datasrc =~ m/Pg/
+          ? ( driver_name eq 'Pg' 
                 ? "$_ IS NULL"
                 : "( $_ IS NULL OR $_ = \"\" )"
             )
@@ -825,7 +841,7 @@ sub hfields {
 
 =head1 VERSION
 
-$Id: Record.pm,v 1.3 2000-03-03 18:21:38 ivan Exp $
+$Id: Record.pm,v 1.4 2000-06-23 12:25:59 ivan Exp $
 
 =head1 BUGS
 
@@ -849,7 +865,7 @@ The ut_ methods should ask the dbdef for a default length.
 
 ut_sqltype (like ut_varchar) should all be defined
 
-A fallback check method should be provided whith uses the dbdef.
+A fallback check method should be provided which uses the dbdef.
 
 The ut_money method assumes money has two decimal digits.
 
@@ -864,6 +880,10 @@ All the subroutines probably should be methods, here or elsewhere.
 Probably should borrow/use some dbdef methods where appropriate (like sub
 fields)
 
+As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
+or allow it to be set.  Working around it is ugly any way around - DBI should
+be fixed.  (only affects RDBMS which return uppercase column names)
+
 =head1 SEE ALSO
 
 L<FS::dbdef>, L<FS::UID>, L<DBI>
diff --git a/FS/FS/UID.pm b/FS/FS/UID.pm
index 2cee65d11..88d733829 100644
--- a/FS/FS/UID.pm
+++ b/FS/FS/UID.pm
@@ -3,19 +3,19 @@ package FS::UID;
 use strict;
 use vars qw(
   @ISA @EXPORT_OK $cgi $dbh $freeside_uid $user 
-  $conf_dir $secrets $datasrc $db_user $db_pass %callback
+  $conf_dir $secrets $datasrc $db_user $db_pass %callback $driver_name
 );
 use subs qw(
   getsecrets cgisetotaker
 );
 use Exporter;
-use Carp;
+use Carp qw(carp croak cluck);
 use DBI;
 use FS::Conf;
 
 @ISA = qw(Exporter);
 @EXPORT_OK = qw(checkeuid checkruid swapuid cgisuidsetup
-                adminsuidsetup getotaker dbh datasrc getsecrets );
+                adminsuidsetup getotaker dbh datasrc getsecrets driver_name );
 
 $freeside_uid = scalar(getpwnam('freeside'));
 
@@ -39,6 +39,8 @@ FS::UID - Subroutines for database login and assorted other stuff
 
   $datasrc = datasrc;
 
+  $driver_name = driver_name;
+
 =head1 DESCRIPTION
 
 Provides a hodgepodge of subroutines. 
@@ -89,8 +91,8 @@ sub adminsuidsetup {
 
 =item cgisuidsetup CGI_object
 
-Stores the CGI (see L<CGI>) object for later use. (CGI::Base is depriciated)
-Runs adminsuidsetup.
+Takes a single argument, which is a CGI (see L<CGI>) or Apache (see L<Apache>)
+object (CGI::Base is depriciated).  Runs cgisetotaker and then adminsuidsetup.
 
 =cut
 
@@ -138,10 +140,16 @@ sub datasrc {
   $datasrc;
 }
 
-#hack for web demo
-#sub setdbh {
-#  $dbh=$_[0];
-#}
+=item driver_name
+
+Returns just the driver name portion of the DBI data source.
+
+=cut
+
+sub driver_name {
+  return $driver_name if defined $driver_name;
+  $driver_name = ( split(':', $datasrc) )[1];
+}
 
 sub suidsetup {
   croak "suidsetup depriciated";
@@ -160,7 +168,8 @@ sub getotaker {
 =item cgisetotaker
 
 Sets and returns the CGI REMOTE_USER.  $cgi should be defined as a CGI.pm
-object.  Support for CGI::Base and derived classes is depriciated.
+object (see L<CGI>) or an Apache object (see L<Apache>).  Support for CGI::Base
+and derived classes is depriciated.
 
 =cut
 
@@ -229,6 +238,7 @@ sub getsecrets {
   ($datasrc, $db_user, $db_pass) = $conf->config($secrets)
     or die "Can't get secrets: $!";
   $FS::Conf::default_dir = $conf_dir. "/conf.$datasrc";
+  undef $driver_name;
   ($datasrc, $db_user, $db_pass);
 }
 
@@ -246,7 +256,7 @@ coderef into the hash %FS::UID::callback :
 
 =head1 VERSION
 
-$Id: UID.pm,v 1.2 2000-05-13 21:50:12 ivan Exp $
+$Id: UID.pm,v 1.3 2000-06-23 12:25:59 ivan Exp $
 
 =head1 BUGS
 
diff --git a/TODO b/TODO
index aaa90d452..5478707ef 100644
--- a/TODO
+++ b/TODO
@@ -1,4 +1,4 @@
-$Id: TODO,v 1.44 2000-06-15 14:45:38 ivan Exp $
+$Id: TODO,v 1.45 2000-06-23 12:25:59 ivan Exp $
 
 If you are interested in helping with any of these, please join the mailing
 list (send a blank message to ivan-freeside-subscribe@sisd.com) to avoid 
@@ -445,8 +445,8 @@ was happy with it could go in FS::Record::_quote, for data going into the
 database.
 
 our data display problem might be a Freeside problem wrt not using 
-Oracle-compatible DBI syntax (uses the return value from $sth->execute as
-a number of rows).  Fixing this is on the TODO.
+Oracle-compatible DBI syntax (fixed using the return value from $sth->execute
+as a number of rows - something else?).
 
 hooks for arbitrary commands out of configuration files
 svc_acct.pm svc_acct_sm.pm etc.
@@ -575,8 +575,6 @@ the web interface in general needs to be redone in a more abstract way.
 
 false laziness: some of search/svc_acct_sm.cgi was copied to search/svc_domain.cgi.  but web interface in general needs to be rewritten in a mucho cleaner way.
 
-Portability: in FS::Record, $sth->execute does not return a number of rows for all DBD's.  see man DBI
-
 subroutine the where clause (eventually all SQL) as OO perhaps (has anyone done this?)
 
 add a select method to FS::Record?