X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=6c0f5f819d354420ea1c1058e30b491ac9eaf906;hp=113e1a18df73519212cb1cb801dc46d80101249d;hb=cf16b23820da69e3c8d0156ae27e21c635bf1ec5;hpb=018f6678557506e68cc6b8643862143cc332f7da

diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm
index 113e1a18d..6c0f5f819 100644
--- a/FS/FS/Record.pm
+++ b/FS/FS/Record.pm
@@ -6,11 +6,14 @@ use subs qw(reload_dbdef);
 use Exporter;
 use Carp qw(carp cluck croak confess);
 use File::CounterFile;
-use DBIx::DBSchema;
-use FS::UID qw(dbh checkruid swapuid getotaker datasrc driver_name);
+use Locale::Country;
+use DBI qw(:sql_types);
+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;
 
@@ -64,16 +67,17 @@ FS::Record - Database record objects
 
     $value = $record->unique('column');
 
-    $value = $record->ut_float('column');
-    $value = $record->ut_number('column');
-    $value = $record->ut_numbern('column');
-    $value = $record->ut_money('column');
-    $value = $record->ut_text('column');
-    $value = $record->ut_textn('column');
-    $value = $record->ut_alpha('column');
-    $value = $record->ut_alphan('column');
-    $value = $record->ut_phonen('column');
-    $value = $record->ut_anythingn('column');
+    $error = $record->ut_float('column');
+    $error = $record->ut_number('column');
+    $error = $record->ut_numbern('column');
+    $error = $record->ut_money('column');
+    $error = $record->ut_text('column');
+    $error = $record->ut_textn('column');
+    $error = $record->ut_alpha('column');
+    $error = $record->ut_alphan('column');
+    $error = $record->ut_phonen('column');
+    $error = $record->ut_anything('column');
+    $error = $record->ut_name('column');
 
     $dbdef = reload_dbdef;
     $dbdef = reload_dbdef "/non/standard/filename";
@@ -133,9 +137,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;
@@ -168,18 +194,24 @@ objects.
 =cut
 
 sub qsearch {
-  my($table, $record, $select, $extra_sql ) = @_;
+  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 ( driver_name =~ /^Pg$/i ) {
-          "$_ IS NULL";
+          qq-( $_ IS NULL OR $_ = '' )-;
         } else {
           qq-( $_ IS NULL OR $_ = "" )-;
         }
@@ -194,17 +226,40 @@ sub qsearch {
   my $sth = $dbh->prepare($statement)
     or croak "$dbh->errstr doing $statement";
 
-  $sth->execute( map $record->{$_},
+  my $bind = 1;
+
+  foreach my $field (
     grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
-  ) or croak $dbh->errstr;
+  ) {
+    if ( $record->{$field} =~ /^\d+(\.\d+)?$/
+         && $dbdef->table($table)->column($field)->type =~ /(int)/i
+    ) {
+      $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } );
+    } else {
+      $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_VARCHAR } );
+    }
+  }
+
+#  $sth->execute( map $record->{$_},
+#    grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
+#  ) or croak "Error executing \"$statement\": ". $sth->errstr;
+
+  $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
+
   $dbh->commit or croak $dbh->errstr if $FS::UID::AutoCommit;
 
   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 {
@@ -220,6 +275,27 @@ sub qsearch {
 
 }
 
+=item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
+
+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.
+
+Arguments: 
+
+=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
@@ -308,14 +384,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) ) {
-    $self->setfield($field,$value);
+  if ( defined($_[1]) ) {
+    $_[0]->setfield($field, $_[1]);
   } else {
-    $self->getfield($field);
+    $_[0]->getfield($field);
   }    
 }
 
@@ -466,10 +558,11 @@ returns the error, otherwise returns false.
 
 sub replace {
   my ( $new, $old ) = ( shift, shift );
+  warn "[debug][FS::Record] $new ->replace $old\n" if $DEBUG;
 
   my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
   unless ( @diff ) {
-    carp "warning: records identical";
+    carp "[warning][FS::Record] $new -> replace $old: records identical";
     return '';
   }
 
@@ -560,7 +653,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!";
@@ -571,7 +663,6 @@ sub unique {
   my($index)=$counter->inc;
   $index=$counter->inc
     while qsearchs($table,{$field=>$index}); #just in case
-  &swapuid;
 
   $index =~ /^(\d*)$/;
   $index=$1;
@@ -725,7 +816,7 @@ sub ut_phonen {
   my $phonen = $self->getfield($field);
   if ( $phonen eq '' ) {
     $self->setfield($field,'');
-  } elsif ( $country eq 'US' ) {
+  } 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);
@@ -733,8 +824,8 @@ sub ut_phonen {
     $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_alphan($field);
+    warn "warning: don't know how to check phone numbers for country $country";
+    return $self->ut_textn($field);
   }
   '';
 }
@@ -785,8 +876,65 @@ sub ut_domain {
   '';
 }
 
+=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, $country ) = @_;
+  if ( $country eq 'US' ) {
+    $self->getfield($field) =~ /\s*(\d{5}(\-\d{4})?)\s*$/
+      or return "Illegal (zip) $field for country $country: ".
+                $self->getfield($field);
+    $self->setfield($field,$1);
+  } else {
+    $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));
+  '';
+}
+
 =item ut_anything COLUMN
 
 Untaints arbitrary data.  Be careful.
@@ -794,13 +942,30 @@ Untaints arbitrary data.  Be careful.
 =cut
 
 sub ut_anything {
-  my($self,$field)=@_;
-  $self->getfield($field) =~ /^(.*)$/
+  my( $self, $field ) = @_;
+  $self->getfield($field) =~ /^(.*)$/s
     or return "Illegal $field: ". $self->getfield($field);
   $self->setfield($field,$1);
   '';
 }
 
+=item ut_enum COLUMN CHOICES_ARRAYREF
+
+Check/untaint a column, supplying all possible choices, like the "enum" type.
+
+=cut
+
+sub ut_enum {
+  my( $self, $field, $choices ) = @_;
+  foreach my $choice ( @$choices ) {
+    if ( $self->getfield($field) eq $choice ) {
+      $self->setfield($choice);
+      return '';
+    }
+  }
+  return "Illegal (enum) field $field: ". $self->getfield($field);
+}
+
 =item fields [ TABLE ]
 
 This can be used as both a subroutine and a method call.  It returns a list
@@ -821,10 +986,12 @@ sub fields {
   }
   #croak "Usage: \@fields = fields(\$table)\n   or: \@fields = \$record->fields" unless $table;
   my($table_obj) = $dbdef->table($table);
-  croak "Unknown table $table" unless $table_obj;
+  confess "Unknown table $table" unless $table_obj;
   $table_obj->columns;
 }
 
+=back
+
 =head1 SUBROUTINES
 
 =over 4
@@ -889,12 +1056,12 @@ sub hfields {
   \%hash;
 }
 
-#sub _dump {
-#  my($self)=@_;
-#  join("\n", map {
-#    "$_: ". $self->getfield($_). "|"
-#  } (fields($self->table)) );
-#}
+sub _dump {
+  my($self)=@_;
+  join("\n", map {
+    "$_: ". $self->getfield($_). "|"
+  } (fields($self->table)) );
+}
 
 sub DESTROY { return; }
 
@@ -911,10 +1078,6 @@ sub DESTROY { return; }
 
 =back
 
-=head1 VERSION
-
-$Id: Record.pm,v 1.14 2001-04-15 12:56:30 ivan Exp $
-
 =head1 BUGS
 
 This module should probably be renamed, since much of the functionality is
@@ -943,7 +1106,7 @@ 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.
 
@@ -956,6 +1119,8 @@ 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<DBIx::DBSchema>, L<FS::UID>, L<DBI>