X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=b620c0114653f74b20e25728ad2493e28a64f9f7;hb=2d03c78d5e081a98cf2a2896a3bf4bc76a7802f7;hp=cb42b266c1070ee87b6a43bb49ab31fb89799bab;hpb=e6ea57971831f25d682d97a0ba508c39b66ecd8b;p=freeside.git

diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm
index cb42b266c..b620c0114 100644
--- a/FS/FS/Record.pm
+++ b/FS/FS/Record.pm
@@ -2,14 +2,14 @@ package FS::Record;
 
 use strict;
 use vars qw( $dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK $DEBUG
-             $me );
+             $me %dbdef_cache );
 use subs qw(reload_dbdef);
 use Exporter;
 use Carp qw(carp cluck croak confess);
 use File::CounterFile;
 use Locale::Country;
 use DBI qw(:sql_types);
-use DBIx::DBSchema 0.19;
+use DBIx::DBSchema 0.23;
 use FS::UID qw(dbh checkruid getotaker datasrc driver_name);
 use FS::SearchCache;
 use FS::Msgcat qw(gettext);
@@ -132,15 +132,8 @@ sub new {
 
   my $hashref = $self->{'Hash'} = shift;
 
-  foreach my $field ( $self->fields ) { 
-    $hashref->{$field}='' unless defined $hashref->{$field};
-    #trim the '$' and ',' from money fields for Pg (belong HERE?)
-    #(what about Pg i18n?)
-    if ( driver_name =~ /^Pg$/i
-         && $self->dbdef_table->column($field)->type eq 'money' ) {
-      ${$hashref}{$field} =~ s/^\$//;
-      ${$hashref}{$field} =~ s/\,//;
-    }
+  foreach my $field ( grep !defined($hashref->{$_}), $self->fields ) { 
+    $hashref->{$field}='';
   }
 
   $self->_cache($hashref, shift) if $self->can('_cache') && @_;
@@ -217,26 +210,56 @@ sub qsearch {
     $statement .= ' WHERE '. join(' AND ', map {
 
       my $op = '=';
+      my $column = $_;
       if ( ref($record->{$_}) ) {
         $op = $record->{$_}{'op'} if $record->{$_}{'op'};
-        $op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name !~ /^Pg$/i;
+        #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name !~ /^Pg$/i;
+        if ( uc($op) eq 'ILIKE' ) {
+          $op = 'LIKE';
+          $record->{$_}{'value'} = lc($record->{$_}{'value'});
+          $column = "LOWER($_)";
+        }
         $record->{$_} = $record->{$_}{'value'}
       }
 
       if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
-        if ( driver_name =~ /^Pg$/i ) {
-          qq-( $_ IS NULL OR $_ = '' )-;
+        if ( $op eq '=' ) {
+          if ( driver_name eq 'Pg' ) {
+            my $type = $dbdef->table($table)->column($column)->type;
+            if ( $type =~ /(int|serial)/i ) {
+              qq-( $column IS NULL )-;
+            } else {
+              qq-( $column IS NULL OR $column = '' )-;
+            }
+          } else {
+            qq-( $column IS NULL OR $column = "" )-;
+          }
+        } elsif ( $op eq '!=' ) {
+          if ( driver_name eq 'Pg' ) {
+            my $type = $dbdef->table($table)->column($column)->type;
+            if ( $type =~ /(int|serial)/i ) {
+              qq-( $column IS NOT NULL )-;
+            } else {
+              qq-( $column IS NOT NULL AND $column != '' )-;
+            }
+          } else {
+            qq-( $column IS NOT NULL AND $column != "" )-;
+          }
         } else {
-          qq-( $_ IS NULL OR $_ = "" )-;
+          if ( driver_name eq 'Pg' ) {
+            qq-( $column $op '' )-;
+          } else {
+            qq-( $column $op "" )-;
+          }
         }
       } else {
-        "$_ $op ?";
+        "$column $op ?";
       }
     } @fields );
   }
   $statement .= " $extra_sql" if defined($extra_sql);
 
-  warn "[debug]$me $statement\n" if $DEBUG;
+  warn "[debug]$me $statement\n" if $DEBUG > 1;
   my $sth = $dbh->prepare($statement)
     or croak "$dbh->errstr doing $statement";
 
@@ -246,7 +269,7 @@ sub qsearch {
     grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
   ) {
     if ( $record->{$field} =~ /^\d+(\.\d+)?$/
-         && $dbdef->table($table)->column($field)->type =~ /(int)/i
+         && $dbdef->table($table)->column($field)->type =~ /(int|serial)/i
     ) {
       $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } );
     } else {
@@ -319,9 +342,11 @@ for a single item, or your data is corrupted.
 =cut
 
 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
+  my $table = $_[0];
   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?
+  carp "warning: Multiple records in scalar search ($table)"
+    if scalar(@result) > 1;
+  #should warn more vehemently if the search was on a primary key?
   scalar(@result) ? ($result[0]) : ();
 }
 
@@ -405,11 +430,11 @@ sub AUTOLOAD {
   $field =~ s/.*://;
   if ( defined($value) ) {
     confess "errant AUTOLOAD $field for $self (arg $value)"
-      unless $self->can('setfield');
+      unless ref($self) && $self->can('setfield');
     $self->setfield($field,$value);
   } else {
     confess "errant AUTOLOAD $field for $self (no args)"
-      unless $self->can('getfield');
+      unless ref($self) && $self->can('getfield');
     $self->getfield($field);
   }    
 }
@@ -437,6 +462,8 @@ To make a distinct duplicate of an FS::Record object, you can do:
 
 sub hash {
   my($self) = @_;
+  confess $self. ' -> hash: Hash attribute is undefined'
+    unless defined($self->{'Hash'});
   %{ $self->{'Hash'} }; 
 }
 
@@ -488,13 +515,13 @@ sub insert {
       join( ', ', @values ).
     ")"
   ;
-  warn "[debug]$me $statement\n" if $DEBUG;
+  warn "[debug]$me $statement\n" if $DEBUG > 1;
   my $sth = dbh->prepare($statement) or return dbh->errstr;
 
   my $h_sth;
   if ( defined $dbdef->table('h_'. $self->table) ) {
     my $h_statement = $self->_h_statement('insert');
-    warn "[debug]$me $h_statement\n" if $DEBUG;
+    warn "[debug]$me $h_statement\n" if $DEBUG > 2;
     $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
   } else {
     $h_sth = '';
@@ -548,13 +575,13 @@ sub delete {
           ? ( $self->dbdef_table->primary_key)
           : $self->fields
   );
-  warn "[debug]$me $statement\n" if $DEBUG;
+  warn "[debug]$me $statement\n" if $DEBUG > 1;
   my $sth = dbh->prepare($statement) or return dbh->errstr;
 
   my $h_sth;
   if ( defined $dbdef->table('h_'. $self->table) ) {
     my $h_statement = $self->_h_statement('delete');
-    warn "[debug]$me $h_statement\n" if $DEBUG;
+    warn "[debug]$me $h_statement\n" if $DEBUG > 2;
     $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
   } else {
     $h_sth = '';
@@ -597,7 +624,24 @@ returns the error, otherwise returns false.
 =cut
 
 sub replace {
-  my ( $new, $old ) = ( shift, shift );
+  my $new = shift;
+
+  my $old;
+  if ( @_ ) { 
+    $old = shift;
+  } else {
+    warn "[debug]$me replace called with no arguments; autoloading old record\n"
+     if $DEBUG;
+    my $primary_key = $new->dbdef_table->primary_key;
+    if ( $primary_key ) {
+      $old = qsearchs($new->table, { $primary_key => $new->$primary_key() } )
+        or croak "can't find ". $new->table. ".$primary_key ".
+                 $new->$primary_key();
+    } else {
+      croak $new->table. " has no primary key; pass old record as argument";
+    }
+  }
+
   warn "[debug]$me $new ->replace $old\n" if $DEBUG;
 
   return "Records not in same table!" unless $new->table eq $old->table;
@@ -626,20 +670,20 @@ sub replace {
         $old->getfield($_) eq ''
           #? "( $_ IS NULL OR $_ = \"\" )"
           ? ( driver_name =~ /^Pg$/i
-                ? "$_ IS NULL"
+                ? "( $_ IS NULL OR $_ = '' ) "
                 : "( $_ IS NULL OR $_ = \"\" )"
             )
           : "$_ = ". _quote($old->getfield($_),$old->table,$_)
       } ( $primary_key ? ( $primary_key ) : $old->fields )
     )
   ;
-  warn "[debug]$me $statement\n" if $DEBUG;
+  warn "[debug]$me $statement\n" if $DEBUG > 1;
   my $sth = dbh->prepare($statement) or return dbh->errstr;
 
   my $h_old_sth;
   if ( defined $dbdef->table('h_'. $old->table) ) {
     my $h_old_statement = $old->_h_statement('replace_old');
-    warn "[debug]$me $h_old_statement\n" if $DEBUG;
+    warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
     $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
   } else {
     $h_old_sth = '';
@@ -648,7 +692,7 @@ sub replace {
   my $h_new_sth;
   if ( defined $dbdef->table('h_'. $new->table) ) {
     my $h_new_statement = $new->_h_statement('replace_new');
-    warn "[debug]$me $h_new_statement\n" if $DEBUG;
+    warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
     $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
   } else {
     $h_new_sth = '';
@@ -721,7 +765,7 @@ sub unique {
   my($self,$field) = @_;
   my($table)=$self->table;
 
-  croak("&FS::UID::checkruid failed") unless &checkruid;
+  #croak("&FS::UID::checkruid failed") unless &checkruid;
 
   croak "Unique called on field $field, but it is ",
         $self->getfield($field),
@@ -767,6 +811,21 @@ sub ut_float {
   '';
 }
 
+=item ut_snumber COLUMN
+
+Check/untaint signed numeric data (whole numbers).  May not be null.  If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub ut_snumber {
+  my($self, $field) = @_;
+  $self->getfield($field) =~ /^(-?)\s*(\d+)$/
+    or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
+  $self->setfield($field, "$1$2");
+  '';
+}
+
 =item ut_number COLUMN
 
 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
@@ -817,7 +876,7 @@ sub ut_money {
 =item ut_text COLUMN
 
 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
-symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
+symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / =
 May not be null.  If there is an error, returns the error, otherwise returns
 false.
 
@@ -825,10 +884,10 @@ false.
 
 sub ut_text {
   my($self,$field)=@_;
-  warn "msgcat ". \&msgcat. "\n";
-  warn "notexist ". \&notexist. "\n";
-  warn "AUTOLOAD ". \&AUTOLOAD. "\n";
-  $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/]+)$/
+  #warn "msgcat ". \&msgcat. "\n";
+  #warn "notexist ". \&notexist. "\n";
+  #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
+  $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=]+)$/
     or return gettext('illegal_or_empty_text'). " $field: ".
                $self->getfield($field);
   $self->setfield($field,$1);
@@ -845,7 +904,7 @@ May be null.  If there is an error, returns the error, otherwise returns false.
 
 sub ut_textn {
   my($self,$field)=@_;
-  $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/]*)$/
+  $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=]*)$/
     or return gettext('illegal_text'). " $field: ". $self->getfield($field);
   $self->setfield($field,$1);
   '';
@@ -923,7 +982,7 @@ sub ut_ip {
   $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");
+  $self->setfield($field, "$1.$2.$3.$4");
   '';
 }
 
@@ -989,9 +1048,13 @@ sub ut_zip {
                 $self->getfield($field);
     $self->setfield($field,$1);
   } else {
-    $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
-      or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
-    $self->setfield($field,$1);
+    if ( $self->getfield($field) =~ /^\s*$/ ) {
+      $self->setfield($field,'');
+    } else {
+      $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
+        or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
+      $self->setfield($field,$1);
+    }
   }
   '';
 }
@@ -1116,8 +1179,15 @@ I<$FS::Record::setup_hack> is true.  Returns a DBIx::DBSchema object.
 
 sub reload_dbdef {
   my $file = shift || $dbdef_file;
-  $dbdef = load DBIx::DBSchema $file
-    or die "can't load database schema from $file";
+
+  unless ( exists $dbdef_cache{$file} ) {
+    warn "[debug]$me loading dbdef for $file\n" if $DEBUG;
+    $dbdef_cache{$file} = DBIx::DBSchema->load( $file )
+                            or die "can't load database schema from $file";
+  } else {
+    warn "[debug]$me re-using cached dbdef for $file\n" if $DEBUG;
+  }
+  $dbdef = $dbdef_cache{$file};
 }
 
 =item dbdef
@@ -1137,15 +1207,23 @@ type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
 =cut
 
 sub _quote {
-  my($value,$table,$field)=@_;
-  my($dbh)=dbh;
-  if ( $value =~ /^\d+(\.\d+)?$/ && 
-#       ! ( datatype($table,$field) =~ /^char/ ) 
-       ! ( $dbdef->table($table)->column($field)->type =~ /(char|binary)$/i ) 
-  ) {
+  my($value, $table, $column) = @_;
+  my $column_obj = $dbdef->table($table)->column($column);
+  my $column_type = $column_obj->type;
+
+  if ( $value eq '' && $column_type =~ /^int/ ) {
+    if ( $column_obj->null ) {
+      'NULL';
+    } else {
+      cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
+            "using 0 instead";
+      0;
+    }
+  } elsif ( $value =~ /^\d+(\.\d+)?$/ && 
+            ! $column_type =~ /(char|binary|text)$/i ) {
     $value;
   } else {
-    $dbh->quote($value);
+    dbh->quote($value);
   }
 }