add "extra_param" option to qsearch for more realisitic profiling data, RT#5083
[freeside.git] / FS / FS / Record.pm
index cbd6ad8..7019cb9 100644 (file)
@@ -4,7 +4,8 @@ use strict;
 use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG
              $conf $conf_encryption $me
              %virtual_fields_cache
-             $nowarn_identical $no_update_diff $no_check_foreign
+             $nowarn_identical $nowarn_classload
+             $no_update_diff $no_check_foreign
            );
 use Exporter;
 use Carp qw(carp cluck croak confess);
@@ -36,6 +37,7 @@ $DEBUG = 0;
 $me = '[FS::Record]';
 
 $nowarn_identical = 0;
+$nowarn_classload = 0;
 $no_update_diff = 0;
 $no_check_foreign = 0;
 
@@ -152,7 +154,8 @@ sub new {
 
   unless ( defined ( $self->table ) ) {
     $self->{'Table'} = shift;
-    carp "warning: FS::Record::new called with table name ". $self->{'Table'};
+    carp "warning: FS::Record::new called with table name ". $self->{'Table'}
+      unless $nowarn_classload;
   }
   
   $self->{'Hash'} = shift;
@@ -212,23 +215,24 @@ objects.
 
 The preferred usage is to pass a hash reference of named parameters:
 
-  my @records = qsearch( {
-                           'table'     => 'table_name',
-                           'hashref'   => { 'field' => 'value'
-                                            'field' => { 'op'    => '<',
-                                                         'value' => '420',
-                                                       },
-                                          },
-
-                           #these are optional...
-                           'select'    => '*',
-                           'extra_sql' => 'AND field ',
-                           'order_by'  => 'ORDER BY something',
-                           #'cache_obj' => '', #optional
-                           'addl_from' => 'LEFT JOIN othtable USING ( field )',
-                           'debug'     => 1,
-                         }
-                       );
+  @records = qsearch( {
+                        'table'       => 'table_name',
+                        'hashref'     => { 'field' => 'value'
+                                           'field' => { 'op'    => '<',
+                                                        'value' => '420',
+                                                      },
+                                         },
+
+                        #these are optional...
+                        'select'      => '*',
+                        'extra_sql'   => 'AND field = ? AND intfield = ?',
+                        'extra_param' => [ 'value', [ 5, 'int' ] ],
+                        'order_by'    => 'ORDER BY something',
+                        #'cache_obj'   => '', #optional
+                        'addl_from'   => 'LEFT JOIN othtable USING ( field )',
+                        'debug'       => 1,
+                      }
+                    );
 
 Much code still uses old-style positional parameters, this is also probably
 fine in the common case where there are only two parameters:
@@ -248,19 +252,31 @@ fine in the common case where there are only two parameters:
 
 my %TYPE = (); #for debugging
 
+sub _is_fs_float {
+  my ($type, $value) = @_;
+  if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) ||
+       ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/)
+     ) {
+    return 1;
+  }
+  '';
+}
+
 sub qsearch {
-  my($stable, $record, $select, $extra_sql, $order_by, $cache, $addl_from );
+  my($stable, $record, $cache );
+  my( $select, $extra_sql, $extra_param, $order_by, $addl_from );
   my $debug = '';
   if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too
     my $opt = shift;
-    $stable    = $opt->{'table'}     or die "table name is required";
-    $record    = $opt->{'hashref'}   || {};
-    $select    = $opt->{'select'}    || '*';
-    $extra_sql = $opt->{'extra_sql'} || '';
-    $order_by  = $opt->{'order_by'}  || '';
-    $cache     = $opt->{'cache_obj'} || '';
-    $addl_from = $opt->{'addl_from'} || '';
-    $debug     = $opt->{'debug'}     || '';
+    $stable      = $opt->{'table'}       or die "table name is required";
+    $record      = $opt->{'hashref'}     || {};
+    $select      = $opt->{'select'}      || '*';
+    $extra_sql   = $opt->{'extra_sql'}   || '';
+    $extra_param = $opt->{'extra_param'} || [];
+    $order_by    = $opt->{'order_by'}    || '';
+    $cache       = $opt->{'cache_obj'}   || '';
+    $addl_from   = $opt->{'addl_from'}   || '';
+    $debug       = $opt->{'debug'}       || '';
   } else {
     ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_;
     $select ||= '*';
@@ -283,7 +299,8 @@ sub qsearch {
   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
     @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
   } else {
-    cluck "warning: FS::$table not loaded; virtual fields not searchable";
+    cluck "warning: FS::$table not loaded; virtual fields not searchable"
+      unless $nowarn_classload;
     @virtual_fields = ();
   }
 
@@ -310,19 +327,18 @@ sub qsearch {
   ) {
 
     my $value = $record->{$field};
+    my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
     $value = $value->{'value'} if ref($value);
     my $type = dbdef->table($table)->column($field)->type;
 
     my $TYPE = SQL_VARCHAR;
-    if ( $type =~ /(int|(big)?serial)/i && $value =~ /^\d+(\.\d+)?$/ ) {
+    if ( $type =~ /(big)?(int|serial)/i && $value =~ /^\d+(\.\d+)?$/ ) {
       $TYPE = SQL_INTEGER;
 
     #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT
-    } elsif (    ( $type =~ /(numeric)/i     && $value =~ /^[+-]?\d+(\.\d+)?$/)
-              || ( $type =~ /(real|float4)/i
-                     && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/
-                 )
-            ) {
+    #fixed by DBD::Pg 2.11.8
+    #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded
+    } elsif ( _is_fs_float( $type, $value ) ) {
       $TYPE = SQL_DECIMAL;
     }
 
@@ -333,10 +349,32 @@ sub qsearch {
       warn "  bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
     }
 
-    $sth->bind_param($bind++, $value, { TYPE => $TYPE } );
+    #if this needs to be re-enabled, it needs to use a custom op like
+    #"APPROX=" or something (better name?, not '=', to avoid affecting other
+    # searches
+    #if ($TYPE eq SQL_DECIMAL && $op eq 'APPROX=' ) {
+    #  # these values are arbitrary; better (faster?) ones welcome
+    #  $sth->bind_param($bind++, $value*1.00001, { TYPE => $TYPE } );
+    #  $sth->bind_param($bind++, $value*.99999, { TYPE => $TYPE } );
+    #} else {
+      $sth->bind_param($bind++, $value, { TYPE => $TYPE } );
+    #}
 
   }
 
+  foreach my $param ( @$extra_param ) {
+    my $TYPE = SQL_VARCHAR;
+    my $value = $param;
+    if ( ref($param) ) {
+      $value = $param->[0];
+      my $type = $param->[1];
+      if ( $type =~ /(big)?(int|serial)/i && $value =~ /^\d+(\.\d+)?$/ ) {
+        $TYPE = SQL_INTEGER;
+      } # & DECIMAL?  well, who cares for now
+    }
+    $sth->bind_param($bind++, $value, { TYPE => $TYPE } );
+  }
+
 #  $sth->execute( map $record->{$_},
 #    grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
 #  ) or croak "Error executing \"$statement\": ". $sth->errstr;
@@ -346,7 +384,8 @@ sub qsearch {
   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
     @virtual_fields = "FS::$table"->virtual_fields;
   } else {
-    cluck "warning: FS::$table not loaded; virtual fields not returned either";
+    cluck "warning: FS::$table not loaded; virtual fields not returned either"
+      unless $nowarn_classload;
     @virtual_fields = ();
   }
 
@@ -416,7 +455,8 @@ sub qsearch {
       }
     }
   } else {
-    cluck "warning: FS::$table not loaded; returning FS::Record objects";
+    cluck "warning: FS::$table not loaded; returning FS::Record objects"
+      unless $nowarn_classload;
     @return = map {
       FS::Record->new( $table, { %{$_} } );
     } values(%result);
@@ -481,6 +521,9 @@ sub get_real_fields {
 
       my $op = '=';
       my $column = $_;
+      my $type = dbdef->table($table)->column($column)->type;
+      my $value = $record->{$column};
+      $value = $value->{'value'} if ref($value);
       if ( ref($record->{$_}) ) {
         $op = $record->{$_}{'op'} if $record->{$_}{'op'};
         #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
@@ -495,8 +538,7 @@ sub get_real_fields {
       if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
         if ( $op eq '=' ) {
           if ( driver_name eq 'Pg' ) {
-            my $type = dbdef->table($table)->column($column)->type;
-            if ( $type =~ /(int|(big)?serial)/i ) {
+            if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
               qq-( $column IS NULL )-;
             } else {
               qq-( $column IS NULL OR $column = '' )-;
@@ -506,8 +548,7 @@ sub get_real_fields {
           }
         } elsif ( $op eq '!=' ) {
           if ( driver_name eq 'Pg' ) {
-            my $type = dbdef->table($table)->column($column)->type;
-            if ( $type =~ /(int|(big)?serial)/i ) {
+            if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
               qq-( $column IS NOT NULL )-;
             } else {
               qq-( $column IS NOT NULL AND $column != '' )-;
@@ -522,6 +563,11 @@ sub get_real_fields {
             qq-( $column $op "" )-;
           }
         }
+      #if this needs to be re-enabled, it needs to use a custom op like
+      #"APPROX=" or something (better name?, not '=', to avoid affecting other
+      # searches
+      #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
+      #  ( "$column <= ?", "$column >= ?" );
       } else {
         "$column $op ?";
       }
@@ -1914,7 +1960,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.
 
@@ -1926,7 +1972,7 @@ sub ut_text {
   #warn "notexist ". \&notexist. "\n";
   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
   $self->getfield($field)
-    =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/
+    =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>]+)$/
       or return gettext('illegal_or_empty_text'). " $field: ".
                  $self->getfield($field);
   $self->setfield($field,$1);