X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=0845cc6f3f4b3529bfde8e86a921627dc9c47c3c;hp=c8216eca83cf3f4f684ba49e7ec9eea3a3e89813;hb=20f38e4c256094bd938b732950e8f93319f851a5;hpb=36ac94ae711ab27d5f8d352ed7d2cba2e872ac31

diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm
index c8216eca8..0845cc6f3 100644
--- a/FS/FS/Record.pm
+++ b/FS/FS/Record.pm
@@ -15,7 +15,7 @@ use Locale::Country;
 use Text::CSV_XS;
 use File::Slurp qw( slurp );
 use DBI qw(:sql_types);
-use DBIx::DBSchema 0.33;
+use DBIx::DBSchema 0.38;
 use FS::UID qw(dbh getotaker datasrc driver_name);
 use FS::CurrentUser;
 use FS::Schema qw(dbdef);
@@ -31,7 +31,7 @@ use Tie::IxHash;
 
 #export dbdef for now... everything else expects to find it here
 @EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch
-                str2time_sql str2time_sql_closing );
+                str2time_sql str2time_sql_closing regexp_sql not_regexp_sql );
 
 $DEBUG = 0;
 $me = '[FS::Record]';
@@ -244,6 +244,9 @@ fine in the common case where there are only two parameters:
 
   my @records = qsearch( 'table', { 'field' => 'value' } );
 
+Also possible is an experimental LISTREF of PARAMS_HASHREFs for a UNION of
+the individual PARAMS_HASHREF queries
+
 ###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
@@ -300,104 +303,146 @@ sub _is_fs_float {
 }
 
 sub qsearch {
-  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( @stable, @record, @cache );
+  my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
+  my @debug = ();
+  my %union_options = ();
+  if ( ref($_[0]) eq 'ARRAY' ) {
+    my $optlist = shift;
+    %union_options = @_;
+    foreach my $href ( @$optlist ) {
+      push @stable,      ( $href->{'table'} or die "table name is required" );
+      push @record,      ( $href->{'hashref'}     || {} );
+      push @select,      ( $href->{'select'}      || '*' );
+      push @extra_sql,   ( $href->{'extra_sql'}   || '' );
+      push @extra_param, ( $href->{'extra_param'} || [] );
+      push @order_by,    ( $href->{'order_by'}    || '' );
+      push @cache,       ( $href->{'cache_obj'}   || '' );
+      push @addl_from,   ( $href->{'addl_from'}   || '' );
+      push @debug,       ( $href->{'debug'}       || '' );
+    }
+    die "at least one hashref is required" unless scalar(@stable);
+  } elsif ( ref($_[0]) eq 'HASH' ) {
     my $opt = shift;
-    $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'}       || '';
+    $stable[0]      = $opt->{'table'}       or die "table name is required";
+    $record[0]      = $opt->{'hashref'}     || {};
+    $select[0]      = $opt->{'select'}      || '*';
+    $extra_sql[0]   = $opt->{'extra_sql'}   || '';
+    $extra_param[0] = $opt->{'extra_param'} || [];
+    $order_by[0]    = $opt->{'order_by'}    || '';
+    $cache[0]       = $opt->{'cache_obj'}   || '';
+    $addl_from[0]   = $opt->{'addl_from'}   || '';
+    $debug[0]       = $opt->{'debug'}       || '';
   } else {
-    ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_;
-    $select ||= '*';
+    ( $stable[0],
+      $record[0],
+      $select[0],
+      $extra_sql[0],
+      $cache[0],
+      $addl_from[0]
+    ) = @_;
+    $select[0] ||= '*';
   }
+  my $cache = $cache[0];
 
-  #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
-  #for jsearch
-  $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
-  $stable = $1;
+  my @statement = ();
+  my @value = ();
+  my @bind_type = ();
   my $dbh = dbh;
+  foreach my $stable ( @stable ) {
+    my $record      = shift @record;
+    my $select      = shift @select;
+    my $extra_sql   = shift @extra_sql;
+    my $extra_param = shift @extra_param;
+    my $order_by    = shift @order_by;
+    my $cache       = shift @cache;
+    my $addl_from   = shift @addl_from;
+    my $debug       = shift @debug;
+
+    #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
+    #for jsearch
+    $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
+    $stable = $1;
+
+    my $table = $cache ? $cache->table : $stable;
+    my $dbdef_table = dbdef->table($table)
+      or die "No schema for table $table found - ".
+             "do you need to run freeside-upgrade?";
+    my $pkey = $dbdef_table->primary_key;
+
+    my @real_fields = grep exists($record->{$_}), real_fields($table);
+    my @virtual_fields;
+    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"
+        unless $nowarn_classload;
+      @virtual_fields = ();
+    }
 
-  my $table = $cache ? $cache->table : $stable;
-  my $dbdef_table = dbdef->table($table)
-    or die "No schema for table $table found - ".
-           "do you need to run freeside-upgrade?";
-  my $pkey = $dbdef_table->primary_key;
+    my $statement .= "SELECT $select FROM $stable";
+    $statement .= " $addl_from" if $addl_from;
+    if ( @real_fields or @virtual_fields ) {
+      $statement .= ' WHERE '. join(' AND ',
+        get_real_fields($table, $record, \@real_fields) ,
+        get_virtual_fields($table, $pkey, $record, \@virtual_fields),
+        );
+    }
 
-  my @real_fields = grep exists($record->{$_}), real_fields($table);
-  my @virtual_fields;
-  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"
-      unless $nowarn_classload;
-    @virtual_fields = ();
-  }
+    $statement .= " $extra_sql" if defined($extra_sql);
+    $statement .= " $order_by"  if defined($order_by);
 
-  my $statement = "SELECT $select FROM $stable";
-  $statement .= " $addl_from" if $addl_from;
-  if ( @real_fields or @virtual_fields ) {
-    $statement .= ' WHERE '. join(' AND ',
-      get_real_fields($table, $record, \@real_fields) ,
-      get_virtual_fields($table, $pkey, $record, \@virtual_fields),
-      );
-  }
+    push @statement, $statement;
 
-  $statement .= " $extra_sql" if defined($extra_sql);
-  $statement .= " $order_by"  if defined($order_by);
+    warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
+ 
 
-  warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
-  my $sth = $dbh->prepare($statement)
-    or croak "$dbh->errstr doing $statement";
+    foreach my $field (
+      grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
+    ) {
 
-  my $bind = 1;
+      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;
 
-  foreach my $field (
-    grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
-  ) {
+      my $bind_type = _bind_type($type, $value);
 
-    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 $bind_type = _bind_type($type, $value);
-
-    #if ( $DEBUG > 2 ) {
-    #  no strict 'refs';
-    #  %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
-    #    unless keys %TYPE;
-    #  warn "  bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
-    #}
-
-    #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, $bind_type );
-    #}
+      #if ( $DEBUG > 2 ) {
+      #  no strict 'refs';
+      #  %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
+      #    unless keys %TYPE;
+      #  warn "  bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
+      #}
 
-  }
+      push @value, $value;
+      push @bind_type, $bind_type;
 
-  foreach my $param ( @$extra_param ) {
-    my $bind_type = { TYPE => SQL_VARCHAR };
-    my $value = $param;
-    if ( ref($param) ) {
-      $value = $param->[0];
-      my $type = $param->[1];
-      $bind_type = _bind_type($type, $value);
     }
+
+    foreach my $param ( @$extra_param ) {
+      my $bind_type = { TYPE => SQL_VARCHAR };
+      my $value = $param;
+      if ( ref($param) ) {
+        $value = $param->[0];
+        my $type = $param->[1];
+        $bind_type = _bind_type($type, $value);
+      }
+      push @value, $value;
+      push @bind_type, $bind_type;
+    }
+  }
+
+  my $statement = join( ' ) UNION ( ', @statement );
+  $statement = "( $statement )" if scalar(@statement) > 1;
+  $statement .= " $union_options{order_by}" if $union_options{order_by};
+
+  my $sth = $dbh->prepare($statement)
+    or croak "$dbh->errstr doing $statement";
+
+  my $bind = 1;
+  foreach my $value ( @value ) {
+    my $bind_type = shift @bind_type;
     $sth->bind_param($bind++, $value, $bind_type );
   }
 
@@ -407,6 +452,13 @@ sub qsearch {
 
   $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
 
+  # virtual fields and blessings are nonsense in a heterogeneous UNION, right?
+  my $table = $stable[0];
+  my $pkey = '';
+  $table = '' if grep { $_ ne $table } @stable;
+  $pkey = dbdef->table($table)->primary_key if $table;
+
+  my @virtual_fields = ();
   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
     @virtual_fields = "FS::$table"->virtual_fields;
   } else {
@@ -910,12 +962,12 @@ sub insert {
   my $db_seq = 0;
   if ( $primary_key ) {
     my $col = $self->dbdef_table->column($primary_key);
-    
+
     $db_seq =
       uc($col->type) =~ /^(BIG)?SERIAL\d?/
       || ( driver_name eq 'Pg'
              && defined($col->default)
-             && $col->default =~ /^nextval\(/i
+             && $col->quoted_default =~ /^nextval\(/i
          )
       || ( driver_name eq 'mysql'
              && defined($col->local)
@@ -980,7 +1032,7 @@ sub insert {
       #my $oid = $sth->{'pg_oid_status'};
       #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
 
-      my $default = $self->dbdef_table->column($primary_key)->default;
+      my $default = $self->dbdef_table->column($primary_key)->quoted_default;
       unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
         dbh->rollback if $FS::UID::AutoCommit;
         return "can't parse $table.$primary_key default value".
@@ -1207,7 +1259,10 @@ sub replace {
   
   # Encrypt for replace
   my $saved = {};
-  if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) {
+  if (    $conf->exists('encryption')
+       && defined(eval '@FS::'. $new->table . '::encrypted_fields')
+       && scalar( eval '@FS::'. $new->table . '::encrypted_fields')
+  ) {
     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
       $saved->{$field} = $new->getfield($field);
       $new->setfield($field, $new->encrypt($new->getfield($field)));
@@ -1492,7 +1547,7 @@ sub process_batch_import {
   my($job, $opt) = ( shift, shift );
 
   my $table = $opt->{table};
-  my @pass_params = @{ $opt->{params} };
+  my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
   my %formats = %{ $opt->{formats} };
 
   my $param = thaw(decode_base64(shift));
@@ -1506,24 +1561,30 @@ sub process_batch_import {
   my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
   my $file = $dir. $files{'file'};
 
-  my $error =
-    FS::Record::batch_import( {
-      #class-static
-      table                      => $table,
-      formats                    => \%formats,
-      format_types               => $opt->{format_types},
-      format_headers             => $opt->{format_headers},
-      format_sep_chars           => $opt->{format_sep_chars},
-      format_fixedlength_formats => $opt->{format_fixedlength_formats},
-      #per-import
-      job                        => $job,
-      file                       => $file,
-      #type                       => $type,
-      format                     => $param->{format},
-      params                     => { map { $_ => $param->{$_} } @pass_params },
-      #?
-      default_csv                => $opt->{default_csv},
-    } );
+  my %iopt = (
+    #class-static
+    table                      => $table,
+    formats                    => \%formats,
+    format_types               => $opt->{format_types},
+    format_headers             => $opt->{format_headers},
+    format_sep_chars           => $opt->{format_sep_chars},
+    format_fixedlength_formats => $opt->{format_fixedlength_formats},
+    #per-import
+    job                        => $job,
+    file                       => $file,
+    #type                       => $type,
+    format                     => $param->{format},
+    params                     => { map { $_ => $param->{$_} } @pass_params },
+    #?
+    default_csv                => $opt->{default_csv},
+  );
+
+  if ( $opt->{'batch_namecol'} ) {
+    $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
+    $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
+  }
+
+  my $error = FS::Record::batch_import( \%iopt );
 
   unlink $file;
 
@@ -1676,6 +1737,24 @@ sub batch_import {
   my $oldAutoCommit = $FS::UID::AutoCommit;
   local $FS::UID::AutoCommit = 0;
   my $dbh = dbh;
+
+  if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
+    my $batch_col   = $param->{'batch_keycol'};
+
+    my $batch_class = 'FS::'. $param->{'batch_table'};
+    my $batch = $batch_class->new({
+      $param->{'batch_namecol'} => $param->{'batch_namevalue'}
+    });
+    my $error = $batch->insert;
+    if ( $error ) {
+      $dbh->rollback if $oldAutoCommit;
+      return "can't insert batch record: $error";
+    }
+    #primary key via dbdef? (so the column names don't have to match)
+    my $batch_value = $batch->get( $param->{'batch_keycol'} );
+
+    $params->{ $batch_col } = $batch_value;
+  }
   
   my $line;
   my $imported = 0;
@@ -1688,6 +1767,8 @@ sub batch_import {
       last unless scalar(@buffer);
       $line = shift(@buffer);
 
+      next if $line =~ /^\s*$/; #skip empty lines
+
       $parser->parse($line) or do {
         $dbh->rollback if $oldAutoCommit;
         return "can't parse: ". $parser->error_input();
@@ -2059,7 +2140,7 @@ sub ut_alpha {
   '';
 }
 
-=item ut_alpha COLUMN
+=item ut_alphan COLUMN
 
 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
 error, returns the error, otherwise returns false.
@@ -2074,6 +2155,22 @@ sub ut_alphan {
   '';
 }
 
+=item ut_alphasn COLUMN
+
+Check/untaint alphanumeric strings, spaces allowed.  May be null.  If there is
+an error, returns the error, otherwise returns false.
+
+=cut
+
+sub ut_alphasn {
+  my($self,$field)=@_;
+  $self->getfield($field) =~ /^([\w ]*)$/ 
+    or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
+  $self->setfield($field,$1);
+  '';
+}
+
+
 =item ut_alpha_lower COLUMN
 
 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
@@ -2149,12 +2246,14 @@ sub ut_hexn {
 }
 =item ut_ip COLUMN
 
-Check/untaint ip addresses.  IPv4 only for now.
+Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
+to 127.0.0.1.
 
 =cut
 
 sub ut_ip {
   my( $self, $field ) = @_;
+  $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
   $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; }
@@ -2164,7 +2263,8 @@ sub ut_ip {
 
 =item ut_ipn COLUMN
 
-Check/untaint ip addresses.  IPv4 only for now.  May be null.
+Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
+to 127.0.0.1.  May be null.
 
 =cut
 
@@ -2622,7 +2722,7 @@ sub loadRSA {
     #Initialize the Module
     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
 
-    if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') {
+    if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
       $rsa_module = $conf->config('encryptionmodule');
     }
 
@@ -2631,13 +2731,13 @@ sub loadRSA {
 	$rsa_loaded++;
     }
     # Initialize Encryption
-    if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') {
+    if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
       my $public_key = join("\n",$conf->config('encryptionpublickey'));
       $rsa_encrypt = $rsa_module->new_public_key($public_key);
     }
     
     # Intitalize Decryption
-    if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') {
+    if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
       $rsa_decrypt = $rsa_module->new_private_key($private_key);
     }
@@ -2680,6 +2780,25 @@ sub h_date {
   $h ? $h->history_date : '';
 }
 
+=item scalar_sql SQL
+
+A class method with a propensity for becoming an instance method.  This
+method executes the sql statement represented by SQL and returns a scalar
+representing the result.  Don't ask for rows -- you get the first column
+of the first row.  Don't give me bogus SQL or I'll die on you.
+
+Returns an empty string in the event of no rows.
+
+=cut
+
+sub scalar_sql {
+  my($self, $sql ) = ( shift, shift );
+  my $sth = dbh->prepare($sql) or die dbh->errstr;
+  $sth->execute
+    or die "Unexpected error executing statement $sql: ". $sth->errstr;
+  $sth->fetchrow_arrayref->[0] || '';
+}
+
 =back
 
 =head1 SUBROUTINES
@@ -2823,6 +2942,48 @@ sub str2time_sql_closing {
   return ' ) ';
 }
 
+=item regexp_sql [ DRIVER_NAME ]
+
+Returns the operator to do a regular expression comparison based on database
+type, such as '~' for Pg or 'REGEXP' for mysql.
+
+You can pass an optional driver name such as "Pg", "mysql" or
+$dbh->{Driver}->{Name} to return a function for that database instead of
+the current database.
+
+=cut
+
+sub regexp_sql {
+  my $driver = shift || driver_name;
+
+  return '~'      if $driver =~ /^Pg/i;
+  return 'REGEXP' if $driver =~ /^mysql/i;
+
+  die "don't know how to use regular expressions in ". driver_name." databases";
+
+}
+
+=item not_regexp_sql [ DRIVER_NAME ]
+
+Returns the operator to do a regular expression negation based on database
+type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
+
+You can pass an optional driver name such as "Pg", "mysql" or
+$dbh->{Driver}->{Name} to return a function for that database instead of
+the current database.
+
+=cut
+
+sub not_regexp_sql {
+  my $driver = shift || driver_name;
+
+  return '!~'         if $driver =~ /^Pg/i;
+  return 'NOT REGEXP' if $driver =~ /^mysql/i;
+
+  die "don't know how to use regular expressions in ". driver_name." databases";
+
+}
+
 =back
 
 =head1 BUGS