X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=16520f409152ec02571577609f6e1aaafd79c535;hp=d4d7ca13782aa9181d5ce9865e4b305d5678ab58;hb=90393980e5f2859ee1e186fa461f48f5129e803e;hpb=0e3d27730f91e10abb8f655d578eb0fd51b82cd1

diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm
index d4d7ca137..16520f409 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]';
@@ -350,7 +350,8 @@ sub qsearch {
   my @bind_type = ();
   my $dbh = dbh;
   foreach my $stable ( @stable ) {
-    my $record      = shift @record;
+    #stop altering the caller's hashref
+    my $record      = { %{ shift(@record) || {} } };#and be liberal in receipt
     my $select      = shift @select;
     my $extra_sql   = shift @extra_sql;
     my $extra_param = shift @extra_param;
@@ -795,6 +796,17 @@ sub setfield {
   $self->set(@_);
 }
 
+=item exists COLUMN
+
+Returns true if the column/field/key COLUMN exists.
+
+=cut
+
+sub exists {
+  my($self,$field) = @_;
+  exists($self->{Hash}->{$field});
+}
+
 =item AUTLOADED METHODS
 
 $record->column is a synonym for $record->get('column');
@@ -962,12 +974,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)
@@ -1032,7 +1044,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".
@@ -1547,7 +1559,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));
@@ -1561,24 +1573,32 @@ 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},
+    format_xml_formats         => $opt->{format_xml_formats},
+    format_row_callbacks       => $opt->{format_row_callbacks},
+    #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;
 
@@ -1593,6 +1613,8 @@ Class method for batch imports.  Available params:
 
 =item table
 
+=item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
+
 =item formats
 
 =item format_types
@@ -1603,6 +1625,12 @@ Class method for batch imports.  Available params:
 
 =item format_fixedlength_formats
 
+=item format_row_callbacks
+
+=item fields - Alternate way to specify import, specifying import fields directly as a listref
+
+=item postinsert_callback
+
 =item params
 
 =item job
@@ -1613,9 +1641,7 @@ FS::queue object, will be updated with progress
 
 =item type
 
-csv, xls or fixedlength
-
-=item format
+csv, xls, fixedlength, xml
 
 =item empty_ok
 
@@ -1630,18 +1656,67 @@ sub batch_import {
     if $DEBUG;
 
   my $table   = $param->{table};
-  my $formats = $param->{formats};
 
   my $job     = $param->{job};
   my $file    = $param->{file};
-  my $format  = $param->{'format'};
   my $params  = $param->{params} || {};
 
-  die "unknown format $format" unless exists $formats->{ $format };
+  my( $type, $header, $sep_char, $fixedlength_format, 
+      $xml_format, $row_callback, @fields );
+  my $postinsert_callback = '';
+  if ( $param->{'format'} ) {
+
+    my $format  = $param->{'format'};
+    my $formats = $param->{formats};
+    die "unknown format $format" unless exists $formats->{ $format };
+
+    $type = $param->{'format_types'}
+            ? $param->{'format_types'}{ $format }
+            : $param->{type} || 'csv';
+
+
+    $header = $param->{'format_headers'}
+               ? $param->{'format_headers'}{ $param->{'format'} }
+               : 0;
+
+    $sep_char = $param->{'format_sep_chars'}
+                  ? $param->{'format_sep_chars'}{ $param->{'format'} }
+                  : ',';
 
-  my $type = $param->{'format_types'}
-             ? $param->{'format_types'}{ $format }
-             : $param->{type} || 'csv';
+    $fixedlength_format =
+      $param->{'format_fixedlength_formats'}
+        ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
+        : '';
+
+    $xml_format =
+      $param->{'format_xml_formats'}
+        ? $param->{'format_xml_formats'}{ $param->{'format'} }
+        : '';
+
+    $row_callback =
+      $param->{'format_row_callbacks'}
+        ? $param->{'format_row_callbacks'}{ $param->{'format'} }
+        : '';
+
+    @fields = @{ $formats->{ $format } };
+
+  } elsif ( $param->{'fields'} ) {
+
+    $type = ''; #infer from filename
+    $header = 0;
+    $sep_char = ',';
+    $fixedlength_format = '';
+    $row_callback = '';
+    @fields = @{ $param->{'fields'} };
+
+    $postinsert_callback = $param->{'postinsert_callback'}
+      if $param->{'postinsert_callback'}
+
+  } else {
+    die "neither format nor fields specified";
+  }
+
+  #my $file    = $param->{file};
 
   unless ( $type ) {
     if ( $file =~ /\.(\w+)$/i ) {
@@ -1655,20 +1730,6 @@ sub batch_import {
       if $param->{'default_csv'} && $type ne 'xls';
   }
 
-  my $header = $param->{'format_headers'}
-                 ? $param->{'format_headers'}{ $param->{'format'} }
-                 : 0;
-
-  my $sep_char = $param->{'format_sep_chars'}
-                   ? $param->{'format_sep_chars'}{ $param->{'format'} }
-                   : ',';
-
-  my $fixedlength_format =
-    $param->{'format_fixedlength_formats'}
-      ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
-      : '';
-
-  my @fields = @{ $formats->{ $format } };
 
   my $row = 0;
   my $count;
@@ -1687,8 +1748,9 @@ sub batch_import {
       eval "use Parse::FixedLength;";
       die $@ if $@;
       $parser = new Parse::FixedLength $fixedlength_format;
- 
-    } else {
+
+    }
+    else {
       die "Unknown file type $type\n";
     }
 
@@ -1714,7 +1776,22 @@ sub batch_import {
     $count++;
 
     $row = $header || 0;
-
+  } elsif ( $type eq 'xml' ) {
+    # FS::pay_batch
+    eval "use XML::Simple;";
+    die $@ if $@;
+    my $xmlrow = $xml_format->{'xmlrow'};
+    $parser = $xml_format->{'xmlkeys'};
+    die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
+    my $data = XML::Simple::XMLin(
+      $file,
+      'SuppressEmpty' => '', #sets empty values to ''
+      'KeepRoot'      => 1,
+    );
+    my $rows = $data;
+    $rows = $rows->{$_} foreach @$xmlrow;
+    $rows = [ $rows ] if ref($rows) ne 'ARRAY';
+    $count = @buffer = @$rows;
   } else {
     die "Unknown file type $type\n";
   }
@@ -1731,7 +1808,27 @@ sub batch_import {
   my $oldAutoCommit = $FS::UID::AutoCommit;
   local $FS::UID::AutoCommit = 0;
   my $dbh = dbh;
-  
+
+  #my $params  = $param->{params} || {};
+  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 $job     = $param->{job};
   my $line;
   my $imported = 0;
   my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
@@ -1743,6 +1840,10 @@ sub batch_import {
       last unless scalar(@buffer);
       $line = shift(@buffer);
 
+      next if $line =~ /^\s*$/; #skip empty lines
+
+      $line = &{$row_callback}($line) if $row_callback;
+
       $parser->parse($line) or do {
         $dbh->rollback if $oldAutoCommit;
         return "can't parse: ". $parser->error_input();
@@ -1764,6 +1865,11 @@ sub batch_import {
       #my $z = 'A';
       #warn $z++. ": $_\n" for @columns;
 
+    } elsif ( $type eq 'xml' ) {
+      # $parser = [ 'Column0Key', 'Column1Key' ... ]
+      last unless scalar(@buffer);
+      my $row = shift @buffer;
+      @columns = @{ $row }{ @$parser };
     } else {
       die "Unknown file type $type\n";
     }
@@ -1785,6 +1891,7 @@ sub batch_import {
 
     }
 
+    #my $table   = $param->{table};
     my $class = "FS::$table";
 
     my $record = $class->new( \%hash );
@@ -1793,7 +1900,13 @@ sub batch_import {
     while ( scalar(@later) ) {
       my $sub = shift @later;
       my $data = shift @later;
-      &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf);
+      eval {
+        &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
+      };
+      if ( $@ ) {
+        $dbh->rollback if $oldAutoCommit;
+        return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
+      }
       last if exists( $param->{skiprow} );
     }
     next if exists( $param->{skiprow} );
@@ -1808,6 +1921,15 @@ sub batch_import {
     $row++;
     $imported++;
 
+    if ( $postinsert_callback ) {
+      my $error = &{$postinsert_callback}($record, $param);
+      if ( $error ) {
+        $dbh->rollback if $oldAutoCommit;
+        return "postinsert_callback error". ( $line ? " for $line" : '' ).
+               ": $error";
+      }
+    }
+
     if ( $job && time - $min_sec > $last ) { #progress bar
       $job->update_statustext( int(100 * $imported / $count) );
       $last = time;
@@ -1815,9 +1937,12 @@ sub batch_import {
 
   }
 
-  $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
+  unless ( $imported || $param->{empty_ok} ) {
+    $dbh->rollback if $oldAutoCommit;
+    return "Empty file!";
+  }
 
-  return "Empty file!" unless $imported || $param->{empty_ok};
+  $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
 
   ''; #no error
 
@@ -2074,7 +2199,7 @@ sub ut_text {
   #warn "notexist ". \&notexist. "\n";
   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
   $self->getfield($field)
-    =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>]+)$/
+    =~ /^([µ_0123456789aAáÁàÀâÂåÅäÄãêæÆbBcCçÇdDðÐeEéÉèÈêÊëËfFgGhHiIíÍìÌîÎïÏjJkKlLmMnNñÑoOóÓòÒôÔöÖõÕøغpPqQrRsSßtTuUúÚùÙûÛüÜvVwWxXyYýÝÿzZþÞ \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>]+)$/
       or return gettext('illegal_or_empty_text'). " $field: ".
                  $self->getfield($field);
   $self->setfield($field,$1);
@@ -2091,11 +2216,8 @@ May be null.  If there is an error, returns the error, otherwise returns false.
 
 sub ut_textn {
   my($self,$field)=@_;
-  $self->getfield($field)
-    =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/
-      or return gettext('illegal_text'). " $field: ". $self->getfield($field);
-  $self->setfield($field,$1);
-  '';
+  return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
+  $self->ut_text($field);
 }
 
 =item ut_alpha COLUMN
@@ -2114,7 +2236,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.
@@ -2129,6 +2251,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
@@ -2348,7 +2486,9 @@ May not be null.
 
 sub ut_name {
   my( $self, $field ) = @_;
-  $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
+#  warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
+  #$self->getfield($field) =~ /^([\w \,\.\-\']+)$/
+  $self->getfield($field) =~ /^([µ_0123456789aAáÁàÀâÂåÅäÄãêæÆbBcCçÇdDðÐeEéÉèÈêÊëËfFgGhHiIíÍìÌîÎïÏjJkKlLmMnNñÑoOóÓòÒôÔöÖõÕøغpPqQrRsSßtTuUúÚùÙûÛüÜvVwWxXyYýÝÿzZþÞ \,\.\-\']+)$/
     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
   $self->setfield($field,$1);
   '';
@@ -2680,7 +2820,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');
     }
 
@@ -2689,13 +2829,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);
     }
@@ -2738,6 +2878,27 @@ sub h_date {
   $h ? $h->history_date : '';
 }
 
+=item scalar_sql SQL [ PLACEHOLDER, ... ]
+
+A class or object method.  Executes the sql statement represented by SQL and
+returns a scalar representing the result: the first column of the first row.
+
+Dies on bogus SQL.  Returns an empty string if no row is returned.
+
+Typically used for statments which return a single value such as "SELECT
+COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
+
+=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;
+  my $scalar = $sth->fetchrow_arrayref->[0];
+  defined($scalar) ? $scalar : '';
+}
+
 =back
 
 =head1 SUBROUTINES
@@ -2881,6 +3042,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