X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=2c745b4137a599ac31749ed340a4a2a5b40ee081;hp=f5f928210d4ca4f65bb60932fd2e6e2e7e7a5206;hb=6ef34dda51afba96d8dc6c4dd72427c3d4003945;hpb=6cd87c0d3b5280446301c647fa5f1ec5a593fa3f

diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm
index f5f928210..2c745b413 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::dbdef;
+use Locale::Country;
+use DBIx::DBSchema;
+use FS::UID qw(dbh checkruid getotaker datasrc driver_name);
 
 @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;
@@ -71,7 +74,8 @@ FS::Record - Database record objects
     $value = $record->ut_alpha('column');
     $value = $record->ut_alphan('column');
     $value = $record->ut_phonen('column');
-    $value = $record->ut_anythingn('column');
+    $value = $record->ut_anything('column');
+    $value = $record->ut_name('column');
 
     $dbdef = reload_dbdef;
     $dbdef = reload_dbdef "/non/standard/filename";
@@ -124,7 +128,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 =~ /^Pg$/i
          && $self->dbdef_table->column($field)->type eq 'money' ) {
       ${$hashref}{$field} =~ s/^\$//;
       ${$hashref}{$field} =~ s/\,//;
@@ -147,47 +151,75 @@ sub create {
   }
 }
 
-=item qsearch TABLE, HASHREF
+=item qsearch TABLE, HASHREF, SELECT, EXTRA_SQL
 
 Searches the database for all records matching (at least) the key/value pairs
 in HASHREF.  Returns all the records found as `FS::TABLE' objects if that
 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
 objects.
 
+###oops, argh, FS::Record::new only lets us create database fields.
+#Normal behaviour if SELECT is not specified is `*', as in
+#C<SELECT * FROM table WHERE ...>.  However, there is an experimental new
+#feature where you can specify SELECT - remember, the objects returned,
+#although blessed into the appropriate `FS::TABLE' package, will only have the
+#fields you specify.  This might have unwanted results if you then go calling
+#regular FS::TABLE methods
+#on it.
+
 =cut
 
 sub qsearch {
-  my($table,$record) = @_;
-  my($dbh) = dbh;
+  my($table, $record, $select, $extra_sql ) = @_;
+  $table =~ /^([\w\_]+)$/ or die "Illegal table: $table";
+  $table = $1;
+  $select ||= '*';
+  my $dbh = dbh;
+
+  my @fields = grep exists($record->{$_}), fields($table);
+
+  my $statement = "SELECT $select FROM $table";
+  if ( @fields ) {
+    $statement .= ' WHERE '. join(' AND ', map {
+      if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
+        if ( driver_name =~ /^Pg$/i ) {
+          "$_ IS NULL";
+        } else {
+          qq-( $_ IS NULL OR $_ = "" )-;
+        }
+      } else {
+        "$_ = ?";
+      }
+    } @fields );
+  }
+  $statement .= " $extra_sql" if defined($extra_sql);
 
-  my(@fields)=grep exists($record->{$_}), fields($table);
+  warn $statement if $DEBUG;
+  my $sth = $dbh->prepare($statement)
+    or croak "$dbh->errstr doing $statement";
 
-  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 defined( $record->{$_} ) && $record->{$_} ne '', @fields
+  ) or croak "Error executing \"$statement\": ". $dbh->errstr;
+  $dbh->commit or croak $dbh->errstr if $FS::UID::AutoCommit;
 
-  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( {} )};
   }
 
 }
@@ -204,7 +236,7 @@ sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
   my(@result) = qsearch(@_);
   carp "warning: Multiple records in scalar search!" if scalar(@result) > 1;
     #should warn more vehemently if the search was on a primary key?
-  $result[0];
+  scalar(@result) ? ($result[0]) : ();
 }
 
 =back
@@ -285,6 +317,8 @@ sub 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);
   } else {
     $self->getfield($field);
@@ -361,6 +395,7 @@ sub insert {
   local $SIG{PIPE} = 'IGNORE';
 
   $sth->execute or return $sth->errstr;
+  dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 
   '';
 }
@@ -390,7 +425,7 @@ sub delete {
     map {
       $self->getfield($_) eq ''
         #? "( $_ IS NULL OR $_ = \"\" )"
-        ? ( datasrc =~ m/Pg/
+        ? ( driver_name =~ /^Pg$/i
               ? "$_ IS NULL"
               : "( $_ IS NULL OR $_ = \"\" )"
           )
@@ -410,6 +445,7 @@ sub delete {
 
   my $rc = $sth->execute or return $sth->errstr;
   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
+  dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 
   undef $self; #no need to keep object!
 
@@ -462,7 +498,7 @@ sub replace {
       map {
         $old->getfield($_) eq ''
           #? "( $_ IS NULL OR $_ = \"\" )"
-          ? ( datasrc =~ m/Pg/
+          ? ( driver_name =~ /^Pg$/i
                 ? "$_ IS NULL"
                 : "( $_ IS NULL OR $_ = \"\" )"
             )
@@ -481,6 +517,7 @@ sub replace {
 
   my $rc = $sth->execute or return $sth->errstr;
   #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
+  dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 
   '';
 
@@ -510,7 +547,7 @@ sub check {
 =item unique COLUMN
 
 Replaces COLUMN in record with a unique number.  Called by the B<add> method
-on primary keys and single-field unique columns (see L<FS::dbdef_table>).
+on primary keys and single-field unique columns (see L<DBIx::DBSchema::Table>).
 Returns the new value.
 
 =cut
@@ -529,7 +566,6 @@ sub unique {
   #warn "table $table is tainted" if is_tainted($table);
   #warn "field $field is tainted" if is_tainted($field);
 
-  &swapuid;
   my($counter) = new File::CounterFile "$table.$field",0;
 # hack for web demo
 #  getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
@@ -540,7 +576,6 @@ sub unique {
   my($index)=$counter->inc;
   $index=$counter->inc
     while qsearchs($table,{$field=>$index}); #just in case
-  &swapuid;
 
   $index =~ /^(\d*)$/;
   $index=$1;
@@ -678,26 +713,131 @@ sub ut_alphan {
   '';
 }
 
-=item ut_phonen COLUMN
+=item ut_phonen COLUMN [ COUNTRY ]
 
 Check/untaint phone numbers.  May be null.  If there is an error, returns
 the error, otherwise returns false.
 
+Takes an optional two-letter ISO country code; without it or with unsupported
+countries, ut_phonen simply calls ut_alphan.
+
 =cut
 
 sub ut_phonen {
-  my($self,$field)=@_;
+  my( $self, $field, $country ) = @_;
+  return $self->ut_alphan($field) unless defined $country;
   my $phonen = $self->getfield($field);
   if ( $phonen eq '' ) {
     $self->setfield($field,'');
-  } else {
+  } elsif ( $country eq 'US' || $country eq 'CA' ) {
     $phonen =~ s/\D//g;
     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
       or return "Illegal (phone) $field: ". $self->getfield($field);
     $phonen = "$1-$2-$3";
     $phonen .= " x$4" if $4;
     $self->setfield($field,$phonen);
+  } else {
+    warn "don't know how to check phone numbers for country $country";
+    return $self->ut_textn($field);
+  }
+  '';
+}
+
+=item ut_ip COLUMN
+
+Check/untaint ip addresses.  IPv4 only for now.
+
+=cut
+
+sub ut_ip {
+  my( $self, $field ) = @_;
+  $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
+    or return "Illegal (IP address) $field: ". $self->getfield($field);
+  for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
+  $self->setfield($field, "$1.$2.$3.$3");
+  '';
+}
+
+=item ut_ipn COLUMN
+
+Check/untaint ip addresses.  IPv4 only for now.  May be null.
+
+=cut
+
+sub ut_ipn {
+  my( $self, $field ) = @_;
+  if ( $self->getfield($field) =~ /^()$/ ) {
+    $self->setfield($field,'');
+    '';
+  } else {
+    $self->ut_ip($field);
+  }
+}
+
+=item ut_domain COLUMN
+
+Check/untaint host and domain names.
+
+=cut
+
+sub ut_domain {
+  my( $self, $field ) = @_;
+  #$self->getfield($field) =~/^(\w+\.)*\w+$/
+  $self->getfield($field) =~/^(\w+\.)*\w+$/
+    or return "Illegal (domain) $field: ". $self->getfield($field);
+  $self->setfield($field,$1);
+  '';
+}
+
+=item ut_name COLUMN
+
+Check/untaint proper names; allows alphanumerics, spaces and the following
+punctuation: , . - '
+
+May not be null.
+
+=cut
+
+sub ut_name {
+  my( $self, $field ) = @_;
+  $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
+    or return "Illegal (name) $field: ". $self->getfield($field);
+  $self->setfield($field,$1);
+  '';
+}
+
+=item ut_zip COLUMN
+
+Check/untaint zip codes.
+
+=cut
+
+sub ut_zip {
+  my( $self, $field ) = @_;
+  $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
+    or return "Illegal (zip) $field: ". $self->getfield($field);
+  $self->setfield($field,$1);
+  '';
+}
+
+=item ut_country COLUMN
+
+Check/untaint country codes.  Country names are changed to codes, if possible -
+see L<Locale::Country>.
+
+=cut
+
+sub ut_country {
+  my( $self, $field ) = @_;
+  unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
+    if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/ 
+         && country2code($1) ) {
+      $self->setfield($field,uc(country2code($1)));
+    }
   }
+  $self->getfield($field) =~ /^(\w\w)$/
+    or return "Illegal (country) $field: ". $self->getfield($field);
+  $self->setfield($field,uc($1));
   '';
 }
 
@@ -709,7 +849,7 @@ Untaints arbitrary data.  Be careful.
 
 sub ut_anything {
   my($self,$field)=@_;
-  $self->getfield($field) =~ /^(.*)$/
+  $self->getfield($field) =~ /^(.*)$/s
     or return "Illegal $field: ". $self->getfield($field);
   $self->setfield($field,$1);
   '';
@@ -719,7 +859,7 @@ sub ut_anything {
 
 This can be used as both a subroutine and a method call.  It returns a list
 of the columns in this record's table, or an explicitly specified table.
-(See L<dbdef_table>).
+(See L<DBIx::DBSchema::Table>).
 
 =cut
 
@@ -739,21 +879,23 @@ sub fields {
   $table_obj->columns;
 }
 
+=back
+
 =head1 SUBROUTINES
 
 =over 4
 
 =item reload_dbdef([FILENAME])
 
-Load a database definition (see L<FS::dbdef>), optionally from a non-default
-filename.  This command is executed at startup unless
-I<$FS::Record::setup_hack> is true.  Returns a FS::dbdef object.
+Load a database definition (see L<DBIx::DBSchema>), optionally from a
+non-default filename.  This command is executed at startup unless
+I<$FS::Record::setup_hack> is true.  Returns a DBIx::DBSchema object.
 
 =cut
 
 sub reload_dbdef {
   my $file = shift || $dbdef_file;
-  $dbdef = load FS::dbdef ($file);
+  $dbdef = load DBIx::DBSchema $file;
 }
 
 =item dbdef
@@ -768,7 +910,7 @@ sub dbdef { $dbdef; }
 
 This is an internal function used to construct SQL statements.  It returns
 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
-type (see L<dbdef_column>) does not end in `char' or `binary'.
+type (see L<FS::dbdef_column>) does not end in `char' or `binary'.
 
 =cut
 
@@ -810,6 +952,8 @@ sub hfields {
 #  } (fields($self->table)) );
 #}
 
+sub DESTROY { return; }
+
 #sub DESTROY {
 #  my $self = shift;
 #  #use Carp qw(cluck);
@@ -825,7 +969,7 @@ sub hfields {
 
 =head1 VERSION
 
-$Id: Record.pm,v 1.1 1999-08-04 09:03:53 ivan Exp $
+$Id: Record.pm,v 1.25 2001-08-21 09:34:13 ivan Exp $
 
 =head1 BUGS
 
@@ -849,13 +993,13 @@ 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.
 
 The Pg money kludge in the new method only strips `$'.
 
-The ut_phonen method assumes US-style phone numbers.
+The ut_phonen method only checks US-style phone numbers.
 
 The _quote function should probably use ut_float instead of a regex.
 
@@ -864,9 +1008,15 @@ 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)
+
+ut_zip should take an optional country like ut_phone.
+
 =head1 SEE ALSO
 
-L<FS::dbdef>, L<FS::UID>, L<DBI>
+L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
 
 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.