X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=88e54115d1c730f15d9972943d05722c2227688d;hb=be0e9e416110d38acdc864a9019bfc47870ee5c2;hp=a93a10ac6a3abceed9ed4e9328d26aeac5d235d1;hpb=41967a7cac39ce2156b9b86436ade82f9a99104e;p=freeside.git

diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm
index a93a10ac6..88e54115d 100644
--- a/FS/FS/Record.pm
+++ b/FS/FS/Record.pm
@@ -6,7 +6,7 @@ use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG
              $conf $conf_encryption $money_char $lat_lower $lon_upper
              $me
              $nowarn_identical $nowarn_classload
-             $no_update_diff $no_check_foreign
+             $no_update_diff $no_history $no_check_foreign
              @encrypt_payby
            );
 use Exporter;
@@ -48,6 +48,7 @@ $me = '[FS::Record]';
 $nowarn_identical = 0;
 $nowarn_classload = 0;
 $no_update_diff = 0;
+$no_history = 0;
 $no_check_foreign = 0;
 
 my $rsa_module;
@@ -458,7 +459,13 @@ sub qsearch {
 #    grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
 #  ) or croak "Error executing \"$statement\": ". $sth->errstr;
 
-  $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
+  my $ok = $sth->execute;
+  if (!$ok) {
+    my $error = "Error executing \"$statement\"";
+    $error .= ' (' . join(', ', map {"'$_'"} @value) . ')' if @value;
+    $error .= ': '. $sth->errstr;
+    croak $error;
+  }
 
   my $table = $stable[0];
   my $pkey = '';
@@ -523,6 +530,215 @@ sub qsearch {
   return @return;
 }
 
+=item _query
+
+Construct the SQL statement and parameter-binding list for qsearch.  Takes
+the qsearch parameters.
+
+Returns a hash containing:
+'table':      The primary table name (if there is one).
+'statement':  The SQL statement itself.
+'bind_type':  An arrayref of bind types.
+'value':      An arrayref of parameter values.
+'cache':      The cache object, if one was passed.
+
+=cut
+
+sub _query {
+  my( @stable, @record, @cache );
+  my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
+  my @debug = ();
+  my $cursor = '';
+  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[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[0],
+      $record[0],
+      $select[0],
+      $extra_sql[0],
+      $cache[0],
+      $addl_from[0]
+    ) = @_;
+    $select[0] ||= '*';
+  }
+  my $cache = $cache[0];
+
+  my @statement = ();
+  my @value = ();
+  my @bind_type = ();
+
+  my $result_table = $stable[0];
+  foreach my $stable ( @stable ) {
+    #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;
+    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;
+
+    $result_table = '' if $result_table ne $stable;
+
+    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 $statement .= "SELECT $select FROM $stable";
+    $statement .= " $addl_from" if $addl_from;
+    if ( @real_fields ) {
+      $statement .= ' WHERE '. join(' AND ',
+        get_real_fields($table, $record, \@real_fields));
+    }
+
+    $statement .= " $extra_sql" if defined($extra_sql);
+    $statement .= " $order_by"  if defined($order_by);
+
+    push @statement, $statement;
+
+    warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
+ 
+
+    foreach my $field (
+      grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
+    ) {
+
+      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";
+      #}
+
+      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);
+      }
+      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};
+
+  return {
+    statement => $statement,
+    bind_type => \@bind_type,
+    value     => \@value,
+    table     => $result_table,
+    cache     => $cache,
+  };
+}
+
+# qsearch should eventually use this
+sub _from_hashref {
+  my ($table, $cache, @hashrefs) = @_;
+  my @return;
+  # XXX get rid of these string evals at some point
+  # (when we have time to test it)
+  # my $class = "FS::$table" if $table;
+  # if ( $class and $class->isa('FS::Record') )
+  #   if ( $class->can('new') eq \&new )
+  #
+  if ( $table && 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
+      if ( $cache ) {
+        @return = map {
+          new_or_cached( "FS::$table", { %{$_} }, $cache )
+        } @hashrefs;
+      } else {
+        @return = map {
+          new( "FS::$table", { %{$_} } )
+        } @hashrefs;
+      }
+    } else {
+      #okay, its been tested
+      # warn "untested code (class FS::$table uses custom new method)";
+      @return = map {
+        eval 'FS::'. $table. '->new( { %{$_} } )';
+      } @hashrefs;
+    }
+
+    # Check for encrypted fields and decrypt them.
+   ## only in the local copy, not the cached object
+    if ( $conf_encryption 
+         && eval 'defined(@FS::'. $table . '::encrypted_fields)' ) {
+      foreach my $record (@return) {
+        foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
+          next if $field eq 'payinfo' 
+                    && ($record->isa('FS::payinfo_transaction_Mixin') 
+                        || $record->isa('FS::payinfo_Mixin') )
+                    && $record->payby
+                    && !grep { $record->payby eq $_ } @encrypt_payby;
+          # Set it directly... This may cause a problem in the future...
+          $record->setfield($field, $record->decrypt($record->getfield($field)));
+        }
+      }
+    }
+  } else {
+    cluck "warning: FS::$table not loaded; returning FS::Record objects"
+      unless $nowarn_classload;
+    @return = map {
+      FS::Record->new( $table, { %{$_} } );
+    } @hashrefs;
+  }
+  return @return;
+}
+
 ## makes this easier to read
 
 sub get_real_fields {
@@ -1040,7 +1256,7 @@ sub insert {
   }
 
   my $h_sth;
-  if ( defined dbdef->table('h_'. $table) ) {
+  if ( defined( dbdef->table('h_'. $table) ) && ! $no_history ) {
     my $h_statement = $self->_h_statement('insert');
     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
     $h_sth = dbh->prepare($h_statement) or do {
@@ -1451,6 +1667,7 @@ sub process_batch_import {
     format_sep_chars           => $opt->{format_sep_chars},
     format_fixedlength_formats => $opt->{format_fixedlength_formats},
     format_xml_formats         => $opt->{format_xml_formats},
+    format_asn_formats         => $opt->{format_asn_formats},
     format_row_callbacks       => $opt->{format_row_callbacks},
     #per-import
     job                        => $job,
@@ -1533,8 +1750,12 @@ sub batch_import {
   my $file    = $param->{file};
   my $params  = $param->{params} || {};
 
-  my( $type, $header, $sep_char, $fixedlength_format, 
-      $xml_format, $row_callback, @fields );
+  my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
+  my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
+
+  my( $type, $header, $sep_char,
+      $fixedlength_format, $xml_format, $asn_format,
+      $parser_opt, $row_callback, @fields );
 
   my $postinsert_callback = '';
   $postinsert_callback = $param->{'postinsert_callback'}
@@ -1567,11 +1788,21 @@ sub batch_import {
         ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
         : '';
 
+    $parser_opt =
+      $param->{'format_parser_opts'}
+        ? $param->{'format_parser_opts'}{ $param->{'format'} }
+        : {};
+
     $xml_format =
       $param->{'format_xml_formats'}
         ? $param->{'format_xml_formats'}{ $param->{'format'} }
         : '';
 
+    $asn_format =
+      $param->{'format_asn_formats'}
+        ? $param->{'format_asn_formats'}{ $param->{'format'} }
+        : '';
+
     $row_callback =
       $param->{'format_row_callbacks'}
         ? $param->{'format_row_callbacks'}{ $param->{'format'} }
@@ -1611,22 +1842,22 @@ sub batch_import {
   my $count;
   my $parser;
   my @buffer = ();
+  my $asn_header_buffer;
   if ( $type eq 'csv' || $type eq 'fixedlength' ) {
 
     if ( $type eq 'csv' ) {
 
-      my %attr = ();
-      $attr{sep_char} = $sep_char if $sep_char;
-      $parser = new Text::CSV_XS \%attr;
+      $parser_opt->{'binary'} = 1;
+      $parser_opt->{'sep_char'} = $sep_char if $sep_char;
+      $parser = Text::CSV_XS->new($parser_opt);
 
     } elsif ( $type eq 'fixedlength' ) {
 
       eval "use Parse::FixedLength;";
       die $@ if $@;
-      $parser = Parse::FixedLength->new($fixedlength_format);
+      $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
 
-    }
-    else {
+    } else {
       die "Unknown file type $type\n";
     }
 
@@ -1652,7 +1883,9 @@ sub batch_import {
     $count++;
 
     $row = $header || 0;
+
   } elsif ( $type eq 'xml' ) {
+
     # FS::pay_batch
     eval "use XML::Simple;";
     die $@ if $@;
@@ -1668,6 +1901,26 @@ sub batch_import {
     $rows = $rows->{$_} foreach @$xmlrow;
     $rows = [ $rows ] if ref($rows) ne 'ARRAY';
     $count = @buffer = @$rows;
+
+  } elsif ( $type eq 'asn.1' ) {
+
+    eval "use Convert::ASN1";
+    die $@ if $@;
+
+    my $asn = Convert::ASN1->new;
+    $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
+
+    $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
+
+    my $data = slurp($file);
+    my $asn_output = $parser->decode( $data )
+      or return "No ". $asn_format->{'macro'}. " found\n";
+
+    $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
+
+    my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
+    $count = @buffer = @$rows;
+
   } else {
     die "Unknown file type $type\n";
   }
@@ -1711,6 +1964,7 @@ sub batch_import {
   while (1) {
 
     my @columns = ();
+    my %hash = %$params;
     if ( $type eq 'csv' ) {
 
       last unless scalar(@buffer);
@@ -1747,16 +2001,27 @@ sub batch_import {
       #warn $z++. ": $_\n" for @columns;
 
     } elsif ( $type eq 'xml' ) {
+
       # $parser = [ 'Column0Key', 'Column1Key' ... ]
       last unless scalar(@buffer);
       my $row = shift @buffer;
       @columns = @{ $row }{ @$parser };
+
+    } elsif ( $type eq 'asn.1' ) {
+
+      last unless scalar(@buffer);
+      my $row = shift @buffer;
+      &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
+        if $asn_format->{row_callback};
+      foreach my $key ( keys %{ $asn_format->{map} } ) {
+        $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
+      }
+
     } else {
       die "Unknown file type $type\n";
     }
 
     my @later = ();
-    my %hash = %$params;
 
     foreach my $field ( @fields ) {
 
@@ -1772,6 +2037,11 @@ sub batch_import {
 
     }
 
+    if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
+                         && length($1) == $custnum_length ) {
+      $hash{custnum} = $2;
+    }
+
     #my $table   = $param->{table};
     my $class = "FS::$table";
 
@@ -1833,7 +2103,7 @@ sub batch_import {
     return "Empty file!";
   }
 
-  $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
+  $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 
   ''; #no error
 
@@ -2051,11 +2321,18 @@ is an error, returns the error, otherwise returns false.
 
 sub ut_money {
   my($self,$field)=@_;
-  $self->setfield($field, 0) if $self->getfield($field) eq '';
-  $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/
-    or return "Illegal (money) $field: ". $self->getfield($field);
-  #$self->setfield($field, "$1$2$3" || 0);
-  $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
+
+  if ( $self->getfield($field) eq '' ) {
+    $self->setfield($field, 0);
+  } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
+    #handle one decimal place without barfing out
+    $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
+  } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
+    $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
+  } else {
+    return "Illegal (money) $field: ". $self->getfield($field);
+  }
+
   '';
 }
 
@@ -2089,8 +2366,10 @@ sub ut_text {
   #warn "msgcat ". \&msgcat. "\n";
   #warn "notexist ". \&notexist. "\n";
   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
+  # \p{Word} = alphanumerics, marks (diacritics), and connectors
+  # see perldoc perluniprops
   $self->getfield($field)
-    =~ /^([\wô \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
+    =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
       or return gettext('illegal_or_empty_text'). " $field: ".
                  $self->getfield($field);
   $self->setfield($field,$1);
@@ -2421,10 +2700,9 @@ sub ut_coordn {
 
 }
 
-
 =item ut_domain COLUMN
 
-Check/untaint host and domain names.
+Check/untaint host and domain names.  May not be null.
 
 =cut
 
@@ -2432,11 +2710,27 @@ sub ut_domain {
   my( $self, $field ) = @_;
   #$self->getfield($field) =~/^(\w+\.)*\w+$/
   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
-    or return "Illegal (domain) $field: ". $self->getfield($field);
+    or return "Illegal (hostname) $field: ". $self->getfield($field);
   $self->setfield($field,$1);
   '';
 }
 
+=item ut_domainn COLUMN
+
+Check/untaint host and domain names.  May be null.
+
+=cut
+
+sub ut_domainn {
+  my( $self, $field ) = @_;
+  if ( $self->getfield($field) =~ /^()$/ ) {
+    $self->setfield($field,'');
+    '';
+  } else {
+    $self->ut_domain($field);
+  }
+}
+
 =item ut_name COLUMN
 
 Check/untaint proper names; allows alphanumerics, spaces and the following
@@ -2449,12 +2743,31 @@ May not be null.
 sub ut_name {
   my( $self, $field ) = @_;
 #  warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
-  $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
+  $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
-  $self->setfield($field,$1);
+  my $name = $1;
+  $name =~ s/^\s+//; 
+  $name =~ s/\s+$//; 
+  $name =~ s/\s+/ /g;
+  $self->setfield($field, $name);
   '';
 }
 
+=item ut_namen COLUMN
+
+Check/untaint proper names; allows alphanumerics, spaces and the following
+punctuation: , . - '
+
+May not be null.
+
+=cut
+
+sub ut_namen {
+  my( $self, $field ) = @_;
+  return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
+  $self->ut_name($field);
+}
+
 =item ut_zip COLUMN
 
 Check/untaint zip codes.
@@ -2563,6 +2876,22 @@ sub ut_enumn {
     : '';
 }
 
+=item ut_flag COLUMN
+
+Check/untaint a column if it contains either an empty string or 'Y'.  This
+is the standard form for boolean flags in Freeside.
+
+=cut
+
+sub ut_flag {
+  my( $self, $field ) = @_;
+  my $value = uc($self->getfield($field));
+  if ( $value eq '' or $value eq 'Y' ) {
+    $self->setfield($field, $value);
+    return '';
+  }
+  return "Illegal (flag) field $field: $value";
+}
 
 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
 
@@ -2659,7 +2988,7 @@ You should generally not have to worry about calling this, as the system handles
 
 sub encrypt {
   my ($self, $value) = @_;
-  my $encrypted;
+  my $encrypted = $value;
 
   if ($conf->exists('encryption')) {
     if ($self->is_encrypted($value)) {
@@ -2879,6 +3208,8 @@ sub _quote {
   my $column_type = $column_obj->type;
   my $nullable = $column_obj->null;
 
+  utf8::upgrade($value);
+
   warn "  $table.$column: $value ($column_type".
        ( $nullable ? ' NULL' : ' NOT NULL' ).
        ")\n" if $DEBUG > 2;