FS/FS/Record.pm

   1 package FS::Record;
   2 use base qw( Exporter );
   3
   4 use strict;
   5 use vars qw( $AUTOLOAD
   6              %virtual_fields_cache
   7              $money_char $lat_lower $lon_upper
   8            );
   9 use Carp qw(carp cluck croak confess);
  10 use Scalar::Util qw( blessed );
  11 use File::Slurp qw( slurp );
  12 use File::CounterFile;
  13 use Text::CSV_XS;
  14 use DBI qw(:sql_types);
  15 use DBIx::DBSchema 0.43; #0.43 for foreign keys
  16 use Locale::Country;
  17 use Locale::Currency;
  18 use NetAddr::IP; # for validation
  19 use FS::UID qw(dbh datasrc driver_name);
  20 use FS::CurrentUser;
  21 use FS::Schema qw(dbdef);
  22 use FS::SearchCache;
  23 use FS::Msgcat qw(gettext);
  24 #use FS::Conf; #dependency loop bs, in install_callback below instead
  25
  26 use FS::part_virtual_field;
  27
  28 use Tie::IxHash;
  29
  30 our @encrypt_payby = qw( CARD DCRD CHEK DCHK );
  31
  32 #export dbdef for now... everything else expects to find it here
  33 our @EXPORT_OK = qw(
  34   dbh fields hfields qsearch qsearchs dbdef jsearch
  35   str2time_sql str2time_sql_closing regexp_sql not_regexp_sql concat_sql
  36   midnight_sql
  37 );
  38
  39 our $DEBUG = 0;
  40 our $me = '[FS::Record]';
  41
  42 our $nowarn_identical = 0;
  43 our $nowarn_classload = 0;
  44 our $no_update_diff = 0;
  45
  46 our $no_check_foreign = 1; #well, not inefficiently in perl by default anymore
  47
  48 my $rsa_module;
  49 my $rsa_loaded;
  50 my $rsa_encrypt;
  51 my $rsa_decrypt;
  52
  53 our $conf = '';
  54 our $conf_encryption = '';
  55 FS::UID->install_callback( sub {
  56
  57   eval "use FS::Conf;";
  58   die $@ if $@;
  59   $conf = FS::Conf->new;
  60   $conf_encryption = $conf->exists('encryption');
  61   $money_char = $conf->config('money_char') || '$';
  62   my $nw_coords = $conf->exists('geocode-require_nw_coordinates');
  63   $lat_lower = $nw_coords ? 1 : -90;
  64   $lon_upper = $nw_coords ? -1 : 180;
  65
  66   $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
  67
  68   if ( driver_name eq 'Pg' ) {
  69     eval "use DBD::Pg ':pg_types'";
  70     die $@ if $@;
  71   } else {
  72     eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }";
  73   }
  74
  75 } );
  76
  77 =head1 NAME
  78
  79 FS::Record - Database record objects
  80
  81 =head1 SYNOPSIS
  82
  83     use FS::Record;
  84     use FS::Record qw(dbh fields qsearch qsearchs);
  85
  86     $record = new FS::Record 'table', \%hash;
  87     $record = new FS::Record 'table', { 'column' => 'value', ... };
  88
  89     $record  = qsearchs FS::Record 'table', \%hash;
  90     $record  = qsearchs FS::Record 'table', { 'column' => 'value', ... };
  91     @records = qsearch  FS::Record 'table', \%hash;
  92     @records = qsearch  FS::Record 'table', { 'column' => 'value', ... };
  93
  94     $table = $record->table;
  95     $dbdef_table = $record->dbdef_table;
  96
  97     $value = $record->get('column');
  98     $value = $record->getfield('column');
  99     $value = $record->column;
 100
 101     $record->set( 'column' => 'value' );
 102     $record->setfield( 'column' => 'value' );
 103     $record->column('value');
 104
 105     %hash = $record->hash;
 106
 107     $hashref = $record->hashref;
 108
 109     $error = $record->insert;
 110
 111     $error = $record->delete;
 112
 113     $error = $new_record->replace($old_record);
 114
 115     # external use deprecated - handled by the database (at least for Pg, mysql)
 116     $value = $record->unique('column');
 117
 118     $error = $record->ut_float('column');
 119     $error = $record->ut_floatn('column');
 120     $error = $record->ut_number('column');
 121     $error = $record->ut_numbern('column');
 122     $error = $record->ut_snumber('column');
 123     $error = $record->ut_snumbern('column');
 124     $error = $record->ut_money('column');
 125     $error = $record->ut_text('column');
 126     $error = $record->ut_textn('column');
 127     $error = $record->ut_alpha('column');
 128     $error = $record->ut_alphan('column');
 129     $error = $record->ut_phonen('column');
 130     $error = $record->ut_anything('column');
 131     $error = $record->ut_name('column');
 132
 133     $quoted_value = _quote($value,'table','field');
 134
 135     #deprecated
 136     $fields = hfields('table');
 137     if ( $fields->{Field} ) { # etc.
 138
 139     @fields = fields 'table'; #as a subroutine
 140     @fields = $record->fields; #as a method call
 141
 142
 143 =head1 DESCRIPTION
 144
 145 (Mostly) object-oriented interface to database records.  Records are currently
 146 implemented on top of DBI.  FS::Record is intended as a base class for
 147 table-specific classes to inherit from, i.e. FS::cust_main.
 148
 149 =head1 CONSTRUCTORS
 150
 151 =over 4
 152
 153 =item new [ TABLE, ] HASHREF
 154
 155 Creates a new record.  It doesn't store it in the database, though.  See
 156 L<"insert"> for that.
 157
 158 Note that the object stores this hash reference, not a distinct copy of the
 159 hash it points to.  You can ask the object for a copy with the I<hash>
 160 method.
 161
 162 TABLE can only be omitted when a dervived class overrides the table method.
 163
 164 =cut
 165
 166 sub new {
 167   my $proto = shift;
 168   my $class = ref($proto) || $proto;
 169   my $self = {};
 170   bless ($self, $class);
 171
 172   unless ( defined ( $self->table ) ) {
 173     $self->{'Table'} = shift;
 174     carp "warning: FS::Record::new called with table name ". $self->{'Table'}
 175       unless $nowarn_classload;
 176   }
 177
 178   $self->{'Hash'} = shift;
 179
 180   foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
 181     $self->{'Hash'}{$field}='';
 182   }
 183
 184   $self->_rebless if $self->can('_rebless');
 185
 186   $self->{'modified'} = 0;
 187
 188   $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
 189
 190   $self;
 191 }
 192
 193 sub new_or_cached {
 194   my $proto = shift;
 195   my $class = ref($proto) || $proto;
 196   my $self = {};
 197   bless ($self, $class);
 198
 199   $self->{'Table'} = shift unless defined ( $self->table );
 200
 201   my $hashref = $self->{'Hash'} = shift;
 202   my $cache = shift;
 203   if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
 204     my $obj = $cache->cache->{$hashref->{$cache->key}};
 205     $obj->_cache($hashref, $cache) if $obj->can('_cache');
 206     $obj;
 207   } else {
 208     $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
 209   }
 210
 211 }
 212
 213 sub create {
 214   my $proto = shift;
 215   my $class = ref($proto) || $proto;
 216   my $self = {};
 217   bless ($self, $class);
 218   if ( defined $self->table ) {
 219     cluck "create constructor is deprecated, use new!";
 220     $self->new(@_);
 221   } else {
 222     croak "FS::Record::create called (not from a subclass)!";
 223   }
 224 }
 225
 226 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 227
 228 Searches the database for all records matching (at least) the key/value pairs
 229 in HASHREF.  Returns all the records found as `FS::TABLE' objects if that
 230 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
 231 objects.
 232
 233 The preferred usage is to pass a hash reference of named parameters:
 234
 235   @records = qsearch( {
 236                         'table'       => 'table_name',
 237                         'hashref'     => { 'field' => 'value'
 238                                            'field' => { 'op'    => '<',
 239                                                         'value' => '420',
 240                                                       },
 241                                          },
 242
 243                         #these are optional...
 244                         'select'      => '*',
 245                         'extra_sql'   => 'AND field = ? AND intfield = ?',
 246                         'extra_param' => [ 'value', [ 5, 'int' ] ],
 247                         'order_by'    => 'ORDER BY something',
 248                         #'cache_obj'   => '', #optional
 249                         'addl_from'   => 'LEFT JOIN othtable USING ( field )',
 250                         'debug'       => 1,
 251                       }
 252                     );
 253
 254 Much code still uses old-style positional parameters, this is also probably
 255 fine in the common case where there are only two parameters:
 256
 257   my @records = qsearch( 'table', { 'field' => 'value' } );
 258
 259 Also possible is an experimental LISTREF of PARAMS_HASHREFs for a UNION of
 260 the individual PARAMS_HASHREF queries
 261
 262 ###oops, argh, FS::Record::new only lets us create database fields.
 263 #Normal behaviour if SELECT is not specified is `*', as in
 264 #C<SELECT * FROM table WHERE ...>.  However, there is an experimental new
 265 #feature where you can specify SELECT - remember, the objects returned,
 266 #although blessed into the appropriate `FS::TABLE' package, will only have the
 267 #fields you specify.  This might have unwanted results if you then go calling
 268 #regular FS::TABLE methods
 269 #on it.
 270
 271 =cut
 272
 273 my %TYPE = (); #for debugging
 274
 275 sub _bind_type {
 276   my($type, $value) = @_;
 277
 278   my $bind_type = { TYPE => SQL_VARCHAR };
 279
 280   if ( $type =~ /(big)?(int|serial)/i && $value =~ /^-?\d+(\.\d+)?$/ ) {
 281
 282     $bind_type = { TYPE => SQL_INTEGER };
 283
 284   } elsif ( $type =~ /^bytea$/i || $type =~ /(blob|varbinary)/i ) {
 285
 286     if ( driver_name eq 'Pg' ) {
 287       no strict 'subs';
 288       $bind_type = { pg_type => PG_BYTEA };
 289     #} else {
 290     #  $bind_type = ? #SQL_VARCHAR could be fine?
 291     }
 292
 293   #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT
 294   #fixed by DBD::Pg 2.11.8
 295   #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded
 296   #(make a Tron test first)
 297   } elsif ( _is_fs_float( $type, $value ) ) {
 298
 299     $bind_type = { TYPE => SQL_DECIMAL };
 300
 301   }
 302
 303   $bind_type;
 304
 305 }
 306
 307 sub _is_fs_float {
 308   my($type, $value) = @_;
 309   if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) ||
 310        ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/)
 311      ) {
 312     return 1;
 313   }
 314   '';
 315 }
 316
 317 sub qsearch {
 318   my( @stable, @record, @cache );
 319   my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
 320   my @debug = ();
 321   my %union_options = ();
 322   if ( ref($_[0]) eq 'ARRAY' ) {
 323     my $optlist = shift;
 324     %union_options = @_;
 325     foreach my $href ( @$optlist ) {
 326       push @stable,      ( $href->{'table'} or die "table name is required" );
 327       push @record,      ( $href->{'hashref'}     || {} );
 328       push @select,      ( $href->{'select'}      || '*' );
 329       push @extra_sql,   ( $href->{'extra_sql'}   || '' );
 330       push @extra_param, ( $href->{'extra_param'} || [] );
 331       push @order_by,    ( $href->{'order_by'}    || '' );
 332       push @cache,       ( $href->{'cache_obj'}   || '' );
 333       push @addl_from,   ( $href->{'addl_from'}   || '' );
 334       push @debug,       ( $href->{'debug'}       || '' );
 335     }
 336     die "at least one hashref is required" unless scalar(@stable);
 337   } elsif ( ref($_[0]) eq 'HASH' ) {
 338     my $opt = shift;
 339     $stable[0]      = $opt->{'table'}       or die "table name is required";
 340     $record[0]      = $opt->{'hashref'}     || {};
 341     $select[0]      = $opt->{'select'}      || '*';
 342     $extra_sql[0]   = $opt->{'extra_sql'}   || '';
 343     $extra_param[0] = $opt->{'extra_param'} || [];
 344     $order_by[0]    = $opt->{'order_by'}    || '';
 345     $cache[0]       = $opt->{'cache_obj'}   || '';
 346     $addl_from[0]   = $opt->{'addl_from'}   || '';
 347     $debug[0]       = $opt->{'debug'}       || '';
 348   } else {
 349     ( $stable[0],
 350       $record[0],
 351       $select[0],
 352       $extra_sql[0],
 353       $cache[0],
 354       $addl_from[0]
 355     ) = @_;
 356     $select[0] ||= '*';
 357   }
 358   my $cache = $cache[0];
 359
 360   my @statement = ();
 361   my @value = ();
 362   my @bind_type = ();
 363   my $dbh = dbh;
 364   foreach my $stable ( @stable ) {
 365     #stop altering the caller's hashref
 366     my $record      = { %{ shift(@record) || {} } };#and be liberal in receipt
 367     my $select      = shift @select;
 368     my $extra_sql   = shift @extra_sql;
 369     my $extra_param = shift @extra_param;
 370     my $order_by    = shift @order_by;
 371     my $cache       = shift @cache;
 372     my $addl_from   = shift @addl_from;
 373     my $debug       = shift @debug;
 374
 375     #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
 376     #for jsearch
 377     $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
 378     $stable = $1;
 379
 380     my $table = $cache ? $cache->table : $stable;
 381     my $dbdef_table = dbdef->table($table)
 382       or die "No schema for table $table found - ".
 383              "do you need to run freeside-upgrade?";
 384     my $pkey = $dbdef_table->primary_key;
 385
 386     my @real_fields = grep exists($record->{$_}), real_fields($table);
 387
 388     my $statement .= "SELECT $select FROM $stable";
 389     $statement .= " $addl_from" if $addl_from;
 390     if ( @real_fields ) {
 391       $statement .= ' WHERE '. join(' AND ',
 392         get_real_fields($table, $record, \@real_fields));
 393     }
 394
 395     $statement .= " $extra_sql" if defined($extra_sql);
 396     $statement .= " $order_by"  if defined($order_by);
 397
 398     push @statement, $statement;
 399
 400     warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
 401
 402
 403     foreach my $field (
 404       grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
 405     ) {
 406
 407       my $value = $record->{$field};
 408       my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
 409       $value = $value->{'value'} if ref($value);
 410       my $type = dbdef->table($table)->column($field)->type;
 411
 412       my $bind_type = _bind_type($type, $value);
 413
 414       #if ( $DEBUG > 2 ) {
 415       #  no strict 'refs';
 416       #  %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
 417       #    unless keys %TYPE;
 418       #  warn "  bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
 419       #}
 420
 421       push @value, $value;
 422       push @bind_type, $bind_type;
 423
 424     }
 425
 426     foreach my $param ( @$extra_param ) {
 427       my $bind_type = { TYPE => SQL_VARCHAR };
 428       my $value = $param;
 429       if ( ref($param) ) {
 430         $value = $param->[0];
 431         my $type = $param->[1];
 432         $bind_type = _bind_type($type, $value);
 433       }
 434       push @value, $value;
 435       push @bind_type, $bind_type;
 436     }
 437   }
 438
 439   my $statement = join( ' ) UNION ( ', @statement );
 440   $statement = "( $statement )" if scalar(@statement) > 1;
 441   $statement .= " $union_options{order_by}" if $union_options{order_by};
 442
 443   my $sth = $dbh->prepare($statement)
 444     or croak "$dbh->errstr doing $statement";
 445
 446   my $bind = 1;
 447   foreach my $value ( @value ) {
 448     my $bind_type = shift @bind_type;
 449     $sth->bind_param($bind++, $value, $bind_type );
 450   }
 451
 452 #  $sth->execute( map $record->{$_},
 453 #    grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
 454 #  ) or croak "Error executing \"$statement\": ". $sth->errstr;
 455
 456   my $ok = $sth->execute;
 457   if (!$ok) {
 458     my $error = "Error executing \"$statement\"";
 459     $error .= ' (' . join(', ', map {"'$_'"} @value) . ')' if @value;
 460     $error .= ': '. $sth->errstr;
 461     croak $error;
 462   }
 463
 464   my $table = $stable[0];
 465   my $pkey = '';
 466   $table = '' if grep { $_ ne $table } @stable;
 467   $pkey = dbdef->table($table)->primary_key if $table;
 468
 469   my %result;
 470   tie %result, "Tie::IxHash";
 471   my @stuff = @{ $sth->fetchall_arrayref( {} ) };
 472   if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
 473     %result = map { $_->{$pkey}, $_ } @stuff;
 474   } else {
 475     @result{@stuff} = @stuff;
 476   }
 477
 478   $sth->finish;
 479
 480   my @return;
 481   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
 482     if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
 483       #derivied class didn't override new method, so this optimization is safe
 484       if ( $cache ) {
 485         @return = map {
 486           new_or_cached( "FS::$table", { %{$_} }, $cache )
 487         } values(%result);
 488       } else {
 489         @return = map {
 490           new( "FS::$table", { %{$_} } )
 491         } values(%result);
 492       }
 493     } else {
 494       #okay, its been tested
 495       # warn "untested code (class FS::$table uses custom new method)";
 496       @return = map {
 497         eval 'FS::'. $table. '->new( { %{$_} } )';
 498       } values(%result);
 499     }
 500
 501     # Check for encrypted fields and decrypt them.
 502    ## only in the local copy, not the cached object
 503     if ( $conf_encryption
 504          && eval '@FS::'. $table . '::encrypted_fields' ) {
 505       foreach my $record (@return) {
 506         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 507           next if $field eq 'payinfo'
 508                     && ($record->isa('FS::payinfo_transaction_Mixin')
 509                         || $record->isa('FS::payinfo_Mixin') )
 510                     && $record->payby
 511                     && !grep { $record->payby eq $_ } @encrypt_payby;
 512           # Set it directly... This may cause a problem in the future...
 513           $record->setfield($field, $record->decrypt($record->getfield($field)));
 514         }
 515       }
 516     }
 517   } else {
 518     cluck "warning: FS::$table not loaded; returning FS::Record objects"
 519       unless $nowarn_classload;
 520     @return = map {
 521       FS::Record->new( $table, { %{$_} } );
 522     } values(%result);
 523   }
 524   return @return;
 525 }
 526
 527 =item _query
 528
 529 Construct the SQL statement and parameter-binding list for qsearch.  Takes
 530 the qsearch parameters.
 531
 532 Returns a hash containing:
 533 'table':      The primary table name (if there is one).
 534 'statement':  The SQL statement itself.
 535 'bind_type':  An arrayref of bind types.
 536 'value':      An arrayref of parameter values.
 537 'cache':      The cache object, if one was passed.
 538
 539 =cut
 540
 541 sub _query {
 542   my( @stable, @record, @cache );
 543   my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
 544   my @debug = ();
 545   my $cursor = '';
 546   my %union_options = ();
 547   if ( ref($_[0]) eq 'ARRAY' ) {
 548     my $optlist = shift;
 549     %union_options = @_;
 550     foreach my $href ( @$optlist ) {
 551       push @stable,      ( $href->{'table'} or die "table name is required" );
 552       push @record,      ( $href->{'hashref'}     || {} );
 553       push @select,      ( $href->{'select'}      || '*' );
 554       push @extra_sql,   ( $href->{'extra_sql'}   || '' );
 555       push @extra_param, ( $href->{'extra_param'} || [] );
 556       push @order_by,    ( $href->{'order_by'}    || '' );
 557       push @cache,       ( $href->{'cache_obj'}   || '' );
 558       push @addl_from,   ( $href->{'addl_from'}   || '' );
 559       push @debug,       ( $href->{'debug'}       || '' );
 560     }
 561     die "at least one hashref is required" unless scalar(@stable);
 562   } elsif ( ref($_[0]) eq 'HASH' ) {
 563     my $opt = shift;
 564     $stable[0]      = $opt->{'table'}       or die "table name is required";
 565     $record[0]      = $opt->{'hashref'}     || {};
 566     $select[0]      = $opt->{'select'}      || '*';
 567     $extra_sql[0]   = $opt->{'extra_sql'}   || '';
 568     $extra_param[0] = $opt->{'extra_param'} || [];
 569     $order_by[0]    = $opt->{'order_by'}    || '';
 570     $cache[0]       = $opt->{'cache_obj'}   || '';
 571     $addl_from[0]   = $opt->{'addl_from'}   || '';
 572     $debug[0]       = $opt->{'debug'}       || '';
 573   } else {
 574     ( $stable[0],
 575       $record[0],
 576       $select[0],
 577       $extra_sql[0],
 578       $cache[0],
 579       $addl_from[0]
 580     ) = @_;
 581     $select[0] ||= '*';
 582   }
 583   my $cache = $cache[0];
 584
 585   my @statement = ();
 586   my @value = ();
 587   my @bind_type = ();
 588
 589   my $result_table = $stable[0];
 590   foreach my $stable ( @stable ) {
 591     #stop altering the caller's hashref
 592     my $record      = { %{ shift(@record) || {} } };#and be liberal in receipt
 593     my $select      = shift @select;
 594     my $extra_sql   = shift @extra_sql;
 595     my $extra_param = shift @extra_param;
 596     my $order_by    = shift @order_by;
 597     my $cache       = shift @cache;
 598     my $addl_from   = shift @addl_from;
 599     my $debug       = shift @debug;
 600
 601     #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
 602     #for jsearch
 603     $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
 604     $stable = $1;
 605
 606     $result_table = '' if $result_table ne $stable;
 607
 608     my $table = $cache ? $cache->table : $stable;
 609     my $dbdef_table = dbdef->table($table)
 610       or die "No schema for table $table found - ".
 611              "do you need to run freeside-upgrade?";
 612     my $pkey = $dbdef_table->primary_key;
 613
 614     my @real_fields = grep exists($record->{$_}), real_fields($table);
 615
 616     my $statement .= "SELECT $select FROM $stable";
 617     $statement .= " $addl_from" if $addl_from;
 618     if ( @real_fields ) {
 619       $statement .= ' WHERE '. join(' AND ',
 620         get_real_fields($table, $record, \@real_fields));
 621     }
 622
 623     $statement .= " $extra_sql" if defined($extra_sql);
 624     $statement .= " $order_by"  if defined($order_by);
 625
 626     push @statement, $statement;
 627
 628     warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
 629
 630
 631     foreach my $field (
 632       grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
 633     ) {
 634
 635       my $value = $record->{$field};
 636       my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
 637       $value = $value->{'value'} if ref($value);
 638       my $type = dbdef->table($table)->column($field)->type;
 639
 640       my $bind_type = _bind_type($type, $value);
 641
 642       #if ( $DEBUG > 2 ) {
 643       #  no strict 'refs';
 644       #  %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
 645       #    unless keys %TYPE;
 646       #  warn "  bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
 647       #}
 648
 649       push @value, $value;
 650       push @bind_type, $bind_type;
 651
 652     }
 653
 654     foreach my $param ( @$extra_param ) {
 655       my $bind_type = { TYPE => SQL_VARCHAR };
 656       my $value = $param;
 657       if ( ref($param) ) {
 658         $value = $param->[0];
 659         my $type = $param->[1];
 660         $bind_type = _bind_type($type, $value);
 661       }
 662       push @value, $value;
 663       push @bind_type, $bind_type;
 664     }
 665   }
 666
 667   my $statement = join( ' ) UNION ( ', @statement );
 668   $statement = "( $statement )" if scalar(@statement) > 1;
 669   $statement .= " $union_options{order_by}" if $union_options{order_by};
 670
 671   return {
 672     statement => $statement,
 673     bind_type => \@bind_type,
 674     value     => \@value,
 675     table     => $result_table,
 676     cache     => $cache,
 677   };
 678 }
 679
 680 # qsearch should eventually use this
 681 sub _from_hashref {
 682   my ($table, $cache, @hashrefs) = @_;
 683   my @return;
 684   # XXX get rid of these string evals at some point
 685   # (when we have time to test it)
 686   # my $class = "FS::$table" if $table;
 687   # if ( $class and $class->isa('FS::Record') )
 688   #   if ( $class->can('new') eq \&new )
 689   #
 690   if ( $table && eval 'scalar(@FS::'. $table. '::ISA);' ) {
 691     if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
 692       #derivied class didn't override new method, so this optimization is safe
 693       if ( $cache ) {
 694         @return = map {
 695           new_or_cached( "FS::$table", { %{$_} }, $cache )
 696         } @hashrefs;
 697       } else {
 698         @return = map {
 699           new( "FS::$table", { %{$_} } )
 700         } @hashrefs;
 701       }
 702     } else {
 703       #okay, its been tested
 704       # warn "untested code (class FS::$table uses custom new method)";
 705       @return = map {
 706         eval 'FS::'. $table. '->new( { %{$_} } )';
 707       } @hashrefs;
 708     }
 709
 710     # Check for encrypted fields and decrypt them.
 711    ## only in the local copy, not the cached object
 712     if ( $conf_encryption
 713          && eval '@FS::'. $table . '::encrypted_fields' ) {
 714       foreach my $record (@return) {
 715         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 716           next if $field eq 'payinfo'
 717                     && ($record->isa('FS::payinfo_transaction_Mixin')
 718                         || $record->isa('FS::payinfo_Mixin') )
 719                     && $record->payby
 720                     && !grep { $record->payby eq $_ } @encrypt_payby;
 721           # Set it directly... This may cause a problem in the future...
 722           $record->setfield($field, $record->decrypt($record->getfield($field)));
 723         }
 724       }
 725     }
 726   } else {
 727     cluck "warning: FS::$table not loaded; returning FS::Record objects"
 728       unless $nowarn_classload;
 729     @return = map {
 730       FS::Record->new( $table, { %{$_} } );
 731     } @hashrefs;
 732   }
 733   return @return;
 734 }
 735
 736 ## makes this easier to read
 737
 738 sub get_real_fields {
 739   my $table = shift;
 740   my $record = shift;
 741   my $real_fields = shift;
 742
 743    ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability
 744       return (
 745       map {
 746
 747       my $op = '=';
 748       my $column = $_;
 749       my $type = dbdef->table($table)->column($column)->type;
 750       my $value = $record->{$column};
 751       $value = $value->{'value'} if ref($value);
 752       if ( ref($record->{$_}) ) {
 753         $op = $record->{$_}{'op'} if $record->{$_}{'op'};
 754         #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
 755         if ( uc($op) eq 'ILIKE' ) {
 756           $op = 'LIKE';
 757           $record->{$_}{'value'} = lc($record->{$_}{'value'});
 758           $column = "LOWER($_)";
 759         }
 760         $record->{$_} = $record->{$_}{'value'}
 761       }
 762
 763       if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
 764         if ( $op eq '=' ) {
 765           if ( driver_name eq 'Pg' ) {
 766             if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
 767               qq-( $column IS NULL )-;
 768             } else {
 769               qq-( $column IS NULL OR $column = '' )-;
 770             }
 771           } else {
 772             qq-( $column IS NULL OR $column = "" )-;
 773           }
 774         } elsif ( $op eq '!=' ) {
 775           if ( driver_name eq 'Pg' ) {
 776             if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
 777               qq-( $column IS NOT NULL )-;
 778             } else {
 779               qq-( $column IS NOT NULL AND $column != '' )-;
 780             }
 781           } else {
 782             qq-( $column IS NOT NULL AND $column != "" )-;
 783           }
 784         } else {
 785           if ( driver_name eq 'Pg' ) {
 786             qq-( $column $op '' )-;
 787           } else {
 788             qq-( $column $op "" )-;
 789           }
 790         }
 791       } elsif ( $op eq '!=' ) {
 792         qq-( $column IS NULL OR $column != ? )-;
 793       #if this needs to be re-enabled, it needs to use a custom op like
 794       #"APPROX=" or something (better name?, not '=', to avoid affecting other
 795       # searches
 796       #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
 797       #  ( "$column <= ?", "$column >= ?" );
 798       } else {
 799         "$column $op ?";
 800       }
 801     } @{ $real_fields } );
 802 }
 803
 804 =item by_key PRIMARY_KEY_VALUE
 805
 806 This is a class method that returns the record with the given primary key
 807 value.  This method is only useful in FS::Record subclasses.  For example:
 808
 809   my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
 810
 811 is equivalent to:
 812
 813   my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
 814
 815 =cut
 816
 817 sub by_key {
 818   my ($class, $pkey_value) = @_;
 819
 820   my $table = $class->table
 821     or croak "No table for $class found";
 822
 823   my $dbdef_table = dbdef->table($table)
 824     or die "No schema for table $table found - ".
 825            "do you need to create it or run dbdef-create?";
 826   my $pkey = $dbdef_table->primary_key
 827     or die "No primary key for table $table";
 828
 829   return qsearchs($table, { $pkey => $pkey_value });
 830 }
 831
 832 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
 833
 834 Experimental JOINed search method.  Using this method, you can execute a
 835 single SELECT spanning multiple tables, and cache the results for subsequent
 836 method calls.  Interface will almost definately change in an incompatible
 837 fashion.
 838
 839 Arguments:
 840
 841 =cut
 842
 843 sub jsearch {
 844   my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
 845   my $cache = FS::SearchCache->new( $ptable, $pkey );
 846   my %saw;
 847   ( $cache,
 848     grep { !$saw{$_->getfield($pkey)}++ }
 849       qsearch($table, $record, $select, $extra_sql, $cache )
 850   );
 851 }
 852
 853 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 854
 855 Same as qsearch, except that if more than one record matches, it B<carp>s but
 856 returns the first.  If this happens, you either made a logic error in asking
 857 for a single item, or your data is corrupted.
 858
 859 =cut
 860
 861 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
 862   my $table = $_[0];
 863   my(@result) = qsearch(@_);
 864   cluck "warning: Multiple records in scalar search ($table)"
 865     if scalar(@result) > 1;
 866   #should warn more vehemently if the search was on a primary key?
 867   scalar(@result) ? ($result[0]) : ();
 868 }
 869
 870 =back
 871
 872 =head1 METHODS
 873
 874 =over 4
 875
 876 =item table
 877
 878 Returns the table name.
 879
 880 =cut
 881
 882 sub table {
 883 #  cluck "warning: FS::Record::table deprecated; supply one in subclass!";
 884   my $self = shift;
 885   $self -> {'Table'};
 886 }
 887
 888 =item dbdef_table
 889
 890 Returns the DBIx::DBSchema::Table object for the table.
 891
 892 =cut
 893
 894 sub dbdef_table {
 895   my($self)=@_;
 896   my($table)=$self->table;
 897   dbdef->table($table);
 898 }
 899
 900 =item primary_key
 901
 902 Returns the primary key for the table.
 903
 904 =cut
 905
 906 sub primary_key {
 907   my $self = shift;
 908   my $pkey = $self->dbdef_table->primary_key;
 909 }
 910
 911 =item get, getfield COLUMN
 912
 913 Returns the value of the column/field/key COLUMN.
 914
 915 =cut
 916
 917 sub get {
 918   my($self,$field) = @_;
 919   # to avoid "Use of unitialized value" errors
 920   if ( defined ( $self->{Hash}->{$field} ) ) {
 921     $self->{Hash}->{$field};
 922   } else {
 923     '';
 924   }
 925 }
 926 sub getfield {
 927   my $self = shift;
 928   $self->get(@_);
 929 }
 930
 931 =item set, setfield COLUMN, VALUE
 932
 933 Sets the value of the column/field/key COLUMN to VALUE.  Returns VALUE.
 934
 935 =cut
 936
 937 sub set {
 938   my($self,$field,$value) = @_;
 939   $self->{'modified'} = 1;
 940   $self->{'Hash'}->{$field} = $value;
 941 }
 942 sub setfield {
 943   my $self = shift;
 944   $self->set(@_);
 945 }
 946
 947 =item exists COLUMN
 948
 949 Returns true if the column/field/key COLUMN exists.
 950
 951 =cut
 952
 953 sub exists {
 954   my($self,$field) = @_;
 955   exists($self->{Hash}->{$field});
 956 }
 957
 958 =item AUTLOADED METHODS
 959
 960 $record->column is a synonym for $record->get('column');
 961
 962 $record->column('value') is a synonym for $record->set('column','value');
 963
 964 =cut
 965
 966 # readable/safe
 967 sub AUTOLOAD {
 968   my($self,$value)=@_;
 969   my($field)=$AUTOLOAD;
 970   $field =~ s/.*://;
 971   if ( defined($value) ) {
 972     confess "errant AUTOLOAD $field for $self (arg $value)"
 973       unless blessed($self) && $self->can('setfield');
 974     $self->setfield($field,$value);
 975   } else {
 976     confess "errant AUTOLOAD $field for $self (no args)"
 977       unless blessed($self) && $self->can('getfield');
 978     $self->getfield($field);
 979   }
 980 }
 981
 982 # efficient
 983 #sub AUTOLOAD {
 984 #  my $field = $AUTOLOAD;
 985 #  $field =~ s/.*://;
 986 #  if ( defined($_[1]) ) {
 987 #    $_[0]->setfield($field, $_[1]);
 988 #  } else {
 989 #    $_[0]->getfield($field);
 990 #  }
 991 #}
 992
 993 =item hash
 994
 995 Returns a list of the column/value pairs, usually for assigning to a new hash.
 996
 997 To make a distinct duplicate of an FS::Record object, you can do:
 998
 999     $new = new FS::Record ( $old->table, { $old->hash } );
1000
1001 =cut
1002
1003 sub hash {
1004   my($self) = @_;
1005   confess $self. ' -> hash: Hash attribute is undefined'
1006     unless defined($self->{'Hash'});
1007   %{ $self->{'Hash'} };
1008 }
1009
1010 =item hashref
1011
1012 Returns a reference to the column/value hash.  This may be deprecated in the
1013 future; if there's a reason you can't just use the autoloaded or get/set
1014 methods, speak up.
1015
1016 =cut
1017
1018 sub hashref {
1019   my($self) = @_;
1020   $self->{'Hash'};
1021 }
1022
1023 =item modified
1024
1025 Returns true if any of this object's values have been modified with set (or via
1026 an autoloaded method).  Doesn't yet recognize when you retreive a hashref and
1027 modify that.
1028
1029 =cut
1030
1031 sub modified {
1032   my $self = shift;
1033   $self->{'modified'};
1034 }
1035
1036 =item select_for_update
1037
1038 Selects this record with the SQL "FOR UPDATE" command.  This can be useful as
1039 a mutex.
1040
1041 =cut
1042
1043 sub select_for_update {
1044   my $self = shift;
1045   my $primary_key = $self->primary_key;
1046   qsearchs( {
1047     'select'    => '*',
1048     'table'     => $self->table,
1049     'hashref'   => { $primary_key => $self->$primary_key() },
1050     'extra_sql' => 'FOR UPDATE',
1051   } );
1052 }
1053
1054 =item lock_table
1055
1056 Locks this table with a database-driver specific lock method.  This is used
1057 as a mutex in order to do a duplicate search.
1058
1059 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
1060
1061 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
1062
1063 Errors are fatal; no useful return value.
1064
1065 Note: To use this method for new tables other than svc_acct and svc_phone,
1066 edit freeside-upgrade and add those tables to the duplicate_lock list.
1067
1068 =cut
1069
1070 sub lock_table {
1071   my $self = shift;
1072   my $table = $self->table;
1073
1074   warn "$me locking $table table\n" if $DEBUG;
1075
1076   if ( driver_name =~ /^Pg/i ) {
1077
1078     dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
1079       or die dbh->errstr;
1080
1081   } elsif ( driver_name =~ /^mysql/i ) {
1082
1083     dbh->do("SELECT * FROM duplicate_lock
1084                WHERE lockname = '$table'
1085                FOR UPDATE"
1086            ) or die dbh->errstr;
1087
1088   } else {
1089
1090     die "unknown database ". driver_name. "; don't know how to lock table";
1091
1092   }
1093
1094   warn "$me acquired $table table lock\n" if $DEBUG;
1095
1096 }
1097
1098 =item insert
1099
1100 Inserts this record to the database.  If there is an error, returns the error,
1101 otherwise returns false.
1102
1103 =cut
1104
1105 sub insert {
1106   my $self = shift;
1107   my $saved = {};
1108
1109   warn "$self -> insert" if $DEBUG;
1110
1111   my $error = $self->check;
1112   return $error if $error;
1113
1114   #single-field non-null unique keys are given a value if empty
1115   #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
1116   foreach ( $self->dbdef_table->unique_singles) {
1117     next if $self->getfield($_);
1118     next if $self->dbdef_table->column($_)->null eq 'NULL';
1119     $self->unique($_);
1120   }
1121
1122   #and also the primary key, if the database isn't going to
1123   my $primary_key = $self->dbdef_table->primary_key;
1124   my $db_seq = 0;
1125   if ( $primary_key ) {
1126     my $col = $self->dbdef_table->column($primary_key);
1127
1128     $db_seq =
1129       uc($col->type) =~ /^(BIG)?SERIAL\d?/
1130       || ( driver_name eq 'Pg'
1131              && defined($col->default)
1132              && $col->quoted_default =~ /^nextval\(/i
1133          )
1134       || ( driver_name eq 'mysql'
1135              && defined($col->local)
1136              && $col->local =~ /AUTO_INCREMENT/i
1137          );
1138     $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
1139   }
1140
1141   my $table = $self->table;
1142
1143   # Encrypt before the database
1144   if (    defined(eval '@FS::'. $table . '::encrypted_fields')
1145        && scalar( eval '@FS::'. $table . '::encrypted_fields')
1146        && $conf->exists('encryption')
1147   ) {
1148     foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
1149       next if $field eq 'payinfo'
1150                 && ($self->isa('FS::payinfo_transaction_Mixin')
1151                     || $self->isa('FS::payinfo_Mixin') )
1152                 && $self->payby
1153                 && !grep { $self->payby eq $_ } @encrypt_payby;
1154       $saved->{$field} = $self->getfield($field);
1155       $self->setfield($field, $self->encrypt($self->getfield($field)));
1156     }
1157   }
1158
1159   #false laziness w/delete
1160   my @real_fields =
1161     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1162     real_fields($table)
1163   ;
1164   my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
1165   #eslaf
1166
1167   my $statement = "INSERT INTO $table ";
1168   if ( @real_fields ) {
1169     $statement .=
1170       "( ".
1171         join( ', ', @real_fields ).
1172       ") VALUES (".
1173         join( ', ', @values ).
1174        ")"
1175     ;
1176   } else {
1177     $statement .= 'DEFAULT VALUES';
1178   }
1179   warn "[debug]$me $statement\n" if $DEBUG > 1;
1180   my $sth = dbh->prepare($statement) or return dbh->errstr;
1181
1182   local $SIG{HUP} = 'IGNORE';
1183   local $SIG{INT} = 'IGNORE';
1184   local $SIG{QUIT} = 'IGNORE';
1185   local $SIG{TERM} = 'IGNORE';
1186   local $SIG{TSTP} = 'IGNORE';
1187   local $SIG{PIPE} = 'IGNORE';
1188
1189   $sth->execute or return $sth->errstr;
1190
1191   # get inserted id from the database, if applicable & needed
1192   if ( $db_seq && ! $self->getfield($primary_key) ) {
1193     warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
1194
1195     my $insertid = '';
1196
1197     if ( driver_name eq 'Pg' ) {
1198
1199       #my $oid = $sth->{'pg_oid_status'};
1200       #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
1201
1202       my $default = $self->dbdef_table->column($primary_key)->quoted_default;
1203       unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
1204         dbh->rollback if $FS::UID::AutoCommit;
1205         return "can't parse $table.$primary_key default value".
1206                " for sequence name: $default";
1207       }
1208       my $sequence = $1;
1209
1210       my $i_sql = "SELECT currval('$sequence')";
1211       my $i_sth = dbh->prepare($i_sql) or do {
1212         dbh->rollback if $FS::UID::AutoCommit;
1213         return dbh->errstr;
1214       };
1215       $i_sth->execute() or do { #$i_sth->execute($oid)
1216         dbh->rollback if $FS::UID::AutoCommit;
1217         return $i_sth->errstr;
1218       };
1219       $insertid = $i_sth->fetchrow_arrayref->[0];
1220
1221     } elsif ( driver_name eq 'mysql' ) {
1222
1223       $insertid = dbh->{'mysql_insertid'};
1224       # work around mysql_insertid being null some of the time, ala RT :/
1225       unless ( $insertid ) {
1226         warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
1227              "using SELECT LAST_INSERT_ID();";
1228         my $i_sql = "SELECT LAST_INSERT_ID()";
1229         my $i_sth = dbh->prepare($i_sql) or do {
1230           dbh->rollback if $FS::UID::AutoCommit;
1231           return dbh->errstr;
1232         };
1233         $i_sth->execute or do {
1234           dbh->rollback if $FS::UID::AutoCommit;
1235           return $i_sth->errstr;
1236         };
1237         $insertid = $i_sth->fetchrow_arrayref->[0];
1238       }
1239
1240     } else {
1241
1242       dbh->rollback if $FS::UID::AutoCommit;
1243       return "don't know how to retreive inserted ids from ". driver_name.
1244              ", try using counterfiles (maybe run dbdef-create?)";
1245
1246     }
1247
1248     $self->setfield($primary_key, $insertid);
1249
1250   }
1251
1252   my $h_sth;
1253   if ( defined dbdef->table('h_'. $table) ) {
1254     my $h_statement = $self->_h_statement('insert');
1255     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1256     $h_sth = dbh->prepare($h_statement) or do {
1257       dbh->rollback if $FS::UID::AutoCommit;
1258       return dbh->errstr;
1259     };
1260   } else {
1261     $h_sth = '';
1262   }
1263   $h_sth->execute or return $h_sth->errstr if $h_sth;
1264
1265   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1266
1267   # Now that it has been saved, reset the encrypted fields so that $new
1268   # can still be used.
1269   foreach my $field (keys %{$saved}) {
1270     $self->setfield($field, $saved->{$field});
1271   }
1272
1273   '';
1274 }
1275
1276 =item add
1277
1278 Depriciated (use insert instead).
1279
1280 =cut
1281
1282 sub add {
1283   cluck "warning: FS::Record::add deprecated!";
1284   insert @_; #call method in this scope
1285 }
1286
1287 =item delete
1288
1289 Delete this record from the database.  If there is an error, returns the error,
1290 otherwise returns false.
1291
1292 =cut
1293
1294 sub delete {
1295   my $self = shift;
1296
1297   my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1298     map {
1299       $self->getfield($_) eq ''
1300         #? "( $_ IS NULL OR $_ = \"\" )"
1301         ? ( driver_name eq 'Pg'
1302               ? "$_ IS NULL"
1303               : "( $_ IS NULL OR $_ = \"\" )"
1304           )
1305         : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1306     } ( $self->dbdef_table->primary_key )
1307           ? ( $self->dbdef_table->primary_key)
1308           : real_fields($self->table)
1309   );
1310   warn "[debug]$me $statement\n" if $DEBUG > 1;
1311   my $sth = dbh->prepare($statement) or return dbh->errstr;
1312
1313   my $h_sth;
1314   if ( defined dbdef->table('h_'. $self->table) ) {
1315     my $h_statement = $self->_h_statement('delete');
1316     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1317     $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1318   } else {
1319     $h_sth = '';
1320   }
1321
1322   my $primary_key = $self->dbdef_table->primary_key;
1323
1324   local $SIG{HUP} = 'IGNORE';
1325   local $SIG{INT} = 'IGNORE';
1326   local $SIG{QUIT} = 'IGNORE';
1327   local $SIG{TERM} = 'IGNORE';
1328   local $SIG{TSTP} = 'IGNORE';
1329   local $SIG{PIPE} = 'IGNORE';
1330
1331   my $rc = $sth->execute or return $sth->errstr;
1332   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1333   $h_sth->execute or return $h_sth->errstr if $h_sth;
1334
1335   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1336
1337   #no need to needlessly destoy the data either (causes problems actually)
1338   #undef $self; #no need to keep object!
1339
1340   '';
1341 }
1342
1343 =item del
1344
1345 Depriciated (use delete instead).
1346
1347 =cut
1348
1349 sub del {
1350   cluck "warning: FS::Record::del deprecated!";
1351   &delete(@_); #call method in this scope
1352 }
1353
1354 =item replace OLD_RECORD
1355
1356 Replace the OLD_RECORD with this one in the database.  If there is an error,
1357 returns the error, otherwise returns false.
1358
1359 =cut
1360
1361 sub replace {
1362   my ($new, $old) = (shift, shift);
1363
1364   $old = $new->replace_old unless defined($old);
1365
1366   warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1367
1368   if ( $new->can('replace_check') ) {
1369     my $error = $new->replace_check($old);
1370     return $error if $error;
1371   }
1372
1373   return "Records not in same table!" unless $new->table eq $old->table;
1374
1375   my $primary_key = $old->dbdef_table->primary_key;
1376   return "Can't change primary key $primary_key ".
1377          'from '. $old->getfield($primary_key).
1378          ' to ' . $new->getfield($primary_key)
1379     if $primary_key
1380        && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1381
1382   my $error = $new->check;
1383   return $error if $error;
1384
1385   # Encrypt for replace
1386   my $saved = {};
1387   if (    $conf->exists('encryption')
1388        && defined(eval '@FS::'. $new->table . '::encrypted_fields')
1389        && scalar( eval '@FS::'. $new->table . '::encrypted_fields')
1390   ) {
1391     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1392       next if $field eq 'payinfo'
1393                 && ($new->isa('FS::payinfo_transaction_Mixin')
1394                     || $new->isa('FS::payinfo_Mixin') )
1395                 && $new->payby
1396                 && !grep { $new->payby eq $_ } @encrypt_payby;
1397       $saved->{$field} = $new->getfield($field);
1398       $new->setfield($field, $new->encrypt($new->getfield($field)));
1399     }
1400   }
1401
1402   #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1403   my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1404                    ? ($_, $new->getfield($_)) : () } $old->fields;
1405
1406   unless (keys(%diff) || $no_update_diff ) {
1407     carp "[warning]$me ". ref($new)."->replace ".
1408            ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
1409          ": records identical"
1410       unless $nowarn_identical;
1411     return '';
1412   }
1413
1414   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1415     map {
1416       "$_ = ". _quote($new->getfield($_),$old->table,$_)
1417     } real_fields($old->table)
1418   ). ' WHERE '.
1419     join(' AND ',
1420       map {
1421
1422         if ( $old->getfield($_) eq '' ) {
1423
1424          #false laziness w/qsearch
1425          if ( driver_name eq 'Pg' ) {
1426             my $type = $old->dbdef_table->column($_)->type;
1427             if ( $type =~ /(int|(big)?serial)/i ) {
1428               qq-( $_ IS NULL )-;
1429             } else {
1430               qq-( $_ IS NULL OR $_ = '' )-;
1431             }
1432           } else {
1433             qq-( $_ IS NULL OR $_ = "" )-;
1434           }
1435
1436         } else {
1437           "$_ = ". _quote($old->getfield($_),$old->table,$_);
1438         }
1439
1440       } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1441     )
1442   ;
1443   warn "[debug]$me $statement\n" if $DEBUG > 1;
1444   my $sth = dbh->prepare($statement) or return dbh->errstr;
1445
1446   my $h_old_sth;
1447   if ( defined dbdef->table('h_'. $old->table) ) {
1448     my $h_old_statement = $old->_h_statement('replace_old');
1449     warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1450     $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1451   } else {
1452     $h_old_sth = '';
1453   }
1454
1455   my $h_new_sth;
1456   if ( defined dbdef->table('h_'. $new->table) ) {
1457     my $h_new_statement = $new->_h_statement('replace_new');
1458     warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1459     $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1460   } else {
1461     $h_new_sth = '';
1462   }
1463
1464   local $SIG{HUP} = 'IGNORE';
1465   local $SIG{INT} = 'IGNORE';
1466   local $SIG{QUIT} = 'IGNORE';
1467   local $SIG{TERM} = 'IGNORE';
1468   local $SIG{TSTP} = 'IGNORE';
1469   local $SIG{PIPE} = 'IGNORE';
1470
1471   my $rc = $sth->execute or return $sth->errstr;
1472   #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1473   $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1474   $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1475
1476   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1477
1478   # Now that it has been saved, reset the encrypted fields so that $new
1479   # can still be used.
1480   foreach my $field (keys %{$saved}) {
1481     $new->setfield($field, $saved->{$field});
1482   }
1483
1484   '';
1485
1486 }
1487
1488 sub replace_old {
1489   my( $self ) = shift;
1490   warn "[$me] replace called with no arguments; autoloading old record\n"
1491     if $DEBUG;
1492
1493   my $primary_key = $self->dbdef_table->primary_key;
1494   if ( $primary_key ) {
1495     $self->by_key( $self->$primary_key() ) #this is what's returned
1496       or croak "can't find ". $self->table. ".$primary_key ".
1497         $self->$primary_key();
1498   } else {
1499     croak $self->table. " has no primary key; pass old record as argument";
1500   }
1501
1502 }
1503
1504 =item rep
1505
1506 Depriciated (use replace instead).
1507
1508 =cut
1509
1510 sub rep {
1511   cluck "warning: FS::Record::rep deprecated!";
1512   replace @_; #call method in this scope
1513 }
1514
1515 =item check
1516
1517 Checks custom fields. Subclasses should still provide a check method to validate
1518 non-custom fields, foreign keys, etc., and call this method via $self->SUPER::check.
1519
1520 =cut
1521
1522 sub check {
1523     my $self = shift;
1524     foreach my $field ($self->virtual_fields) {
1525         my $error = $self->ut_textn($field);
1526         return $error if $error;
1527     }
1528     '';
1529 }
1530
1531 =item virtual_fields [ TABLE ]
1532
1533 Returns a list of virtual fields defined for the table.  This should not
1534 be exported, and should only be called as an instance or class method.
1535
1536 =cut
1537
1538 sub virtual_fields {
1539   my $self = shift;
1540   my $table;
1541   $table = $self->table or confess "virtual_fields called on non-table";
1542
1543   confess "Unknown table $table" unless dbdef->table($table);
1544
1545   return () unless dbdef->table('part_virtual_field');
1546
1547   unless ( $virtual_fields_cache{$table} ) {
1548     my $concat = [ "'cf_'", "name" ];
1549     my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' .
1550                 "WHERE dbtable = '$table'";
1551     my $dbh = dbh;
1552     my $result = $dbh->selectcol_arrayref($query);
1553     confess "Error executing virtual fields query: $query: ". $dbh->errstr
1554       if $dbh->err;
1555     $virtual_fields_cache{$table} = $result;
1556   }
1557
1558   @{$virtual_fields_cache{$table}};
1559
1560 }
1561
1562 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1563
1564 Processes a batch import as a queued JSRPC job
1565
1566 JOB is an FS::queue entry.
1567
1568 OPTIONS_HASHREF can have the following keys:
1569
1570 =over 4
1571
1572 =item table
1573
1574 Table name (required).
1575
1576 =item params
1577
1578 Listref of field names for static fields.  They will be given values from the
1579 PARAMS hashref and passed as a "params" hashref to batch_import.
1580
1581 =item formats
1582
1583 Formats hashref.  Keys are field names, values are listrefs that define the
1584 format.
1585
1586 Each listref value can be a column name or a code reference.  Coderefs are run
1587 with the row object, data and a FS::Conf object as the three parameters.
1588 For example, this coderef does the same thing as using the "columnname" string:
1589
1590   sub {
1591     my( $record, $data, $conf ) = @_;
1592     $record->columnname( $data );
1593   },
1594
1595 Coderefs are run after all "column name" fields are assigned.
1596
1597 =item format_types
1598
1599 Optional format hashref of types.  Keys are field names, values are "csv",
1600 "xls" or "fixedlength".  Overrides automatic determination of file type
1601 from extension.
1602
1603 =item format_headers
1604
1605 Optional format hashref of header lines.  Keys are field names, values are 0
1606 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1607 number of lines.
1608
1609 =item format_sep_chars
1610
1611 Optional format hashref of CSV sep_chars.  Keys are field names, values are the
1612 CSV separation character.
1613
1614 =item format_fixedlenth_formats
1615
1616 Optional format hashref of fixed length format defintiions.  Keys are field
1617 names, values Parse::FixedLength listrefs of field definitions.
1618
1619 =item default_csv
1620
1621 Set true to default to CSV file type if the filename does not contain a
1622 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1623 format_types).
1624
1625 =back
1626
1627 PARAMS is a base64-encoded Storable string containing the POSTed data as
1628 a hash ref.  It normally contains at least one field, "uploaded files",
1629 generated by /elements/file-upload.html and containing the list of uploaded
1630 files.  Currently only supports a single file named "file".
1631
1632 =cut
1633
1634 use Storable qw(thaw);
1635 use Data::Dumper;
1636 use MIME::Base64;
1637 sub process_batch_import {
1638   my($job, $opt) = ( shift, shift );
1639
1640   my $table = $opt->{table};
1641   my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1642   my %formats = %{ $opt->{formats} };
1643
1644   my $param = thaw(decode_base64(shift));
1645   warn Dumper($param) if $DEBUG;
1646
1647   my $files = $param->{'uploaded_files'}
1648     or die "No files provided.\n";
1649
1650   my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1651
1652   my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1653   my $file = $dir. $files{'file'};
1654
1655   my %iopt = (
1656     #class-static
1657     table                      => $table,
1658     formats                    => \%formats,
1659     format_types               => $opt->{format_types},
1660     format_headers             => $opt->{format_headers},
1661     format_sep_chars           => $opt->{format_sep_chars},
1662     format_fixedlength_formats => $opt->{format_fixedlength_formats},
1663     format_xml_formats         => $opt->{format_xml_formats},
1664     format_asn_formats         => $opt->{format_asn_formats},
1665     format_row_callbacks       => $opt->{format_row_callbacks},
1666     #per-import
1667     job                        => $job,
1668     file                       => $file,
1669     #type                       => $type,
1670     format                     => $param->{format},
1671     params                     => { map { $_ => $param->{$_} } @pass_params },
1672     #?
1673     default_csv                => $opt->{default_csv},
1674     postinsert_callback        => $opt->{postinsert_callback},
1675   );
1676
1677   if ( $opt->{'batch_namecol'} ) {
1678     $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1679     $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1680   }
1681
1682   my $error = FS::Record::batch_import( \%iopt );
1683
1684   unlink $file;
1685
1686   die "$error\n" if $error;
1687 }
1688
1689 =item batch_import PARAM_HASHREF
1690
1691 Class method for batch imports.  Available params:
1692
1693 =over 4
1694
1695 =item table
1696
1697 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1698
1699 =item formats
1700
1701 =item format_types
1702
1703 =item format_headers
1704
1705 =item format_sep_chars
1706
1707 =item format_fixedlength_formats
1708
1709 =item format_row_callbacks
1710
1711 =item fields - Alternate way to specify import, specifying import fields directly as a listref
1712
1713 =item preinsert_callback
1714
1715 =item postinsert_callback
1716
1717 =item params
1718
1719 =item job
1720
1721 FS::queue object, will be updated with progress
1722
1723 =item file
1724
1725 =item type
1726
1727 csv, xls, fixedlength, xml
1728
1729 =item empty_ok
1730
1731 =back
1732
1733 =cut
1734
1735 use Data::Dumper;
1736 sub batch_import {
1737   my $param = shift;
1738
1739   warn "$me batch_import call with params: \n". Dumper($param)
1740     if $DEBUG;
1741
1742   my $table   = $param->{table};
1743
1744   my $job     = $param->{job};
1745   my $file    = $param->{file};
1746   my $params  = $param->{params} || {};
1747
1748   my( $type, $header, $sep_char,
1749       $fixedlength_format, $xml_format, $asn_format,
1750       $row_callback, @fields );
1751
1752   my $postinsert_callback = '';
1753   $postinsert_callback = $param->{'postinsert_callback'}
1754           if $param->{'postinsert_callback'};
1755   my $preinsert_callback = '';
1756   $preinsert_callback = $param->{'preinsert_callback'}
1757           if $param->{'preinsert_callback'};
1758
1759   if ( $param->{'format'} ) {
1760
1761     my $format  = $param->{'format'};
1762     my $formats = $param->{formats};
1763     die "unknown format $format" unless exists $formats->{ $format };
1764
1765     $type = $param->{'format_types'}
1766             ? $param->{'format_types'}{ $format }
1767             : $param->{type} || 'csv';
1768
1769
1770     $header = $param->{'format_headers'}
1771                ? $param->{'format_headers'}{ $param->{'format'} }
1772                : 0;
1773
1774     $sep_char = $param->{'format_sep_chars'}
1775                   ? $param->{'format_sep_chars'}{ $param->{'format'} }
1776                   : ',';
1777
1778     $fixedlength_format =
1779       $param->{'format_fixedlength_formats'}
1780         ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1781         : '';
1782
1783     $xml_format =
1784       $param->{'format_xml_formats'}
1785         ? $param->{'format_xml_formats'}{ $param->{'format'} }
1786         : '';
1787
1788     $asn_format =
1789       $param->{'format_asn_formats'}
1790         ? $param->{'format_asn_formats'}{ $param->{'format'} }
1791         : '';
1792
1793     $row_callback =
1794       $param->{'format_row_callbacks'}
1795         ? $param->{'format_row_callbacks'}{ $param->{'format'} }
1796         : '';
1797
1798     @fields = @{ $formats->{ $format } };
1799
1800   } elsif ( $param->{'fields'} ) {
1801
1802     $type = ''; #infer from filename
1803     $header = 0;
1804     $sep_char = ',';
1805     $fixedlength_format = '';
1806     $row_callback = '';
1807     @fields = @{ $param->{'fields'} };
1808
1809   } else {
1810     die "neither format nor fields specified";
1811   }
1812
1813   #my $file    = $param->{file};
1814
1815   unless ( $type ) {
1816     if ( $file =~ /\.(\w+)$/i ) {
1817       $type = lc($1);
1818     } else {
1819       #or error out???
1820       warn "can't parse file type from filename $file; defaulting to CSV";
1821       $type = 'csv';
1822     }
1823     $type = 'csv'
1824       if $param->{'default_csv'} && $type ne 'xls';
1825   }
1826
1827
1828   my $row = 0;
1829   my $count;
1830   my $parser;
1831   my @buffer = ();
1832   my $asn_header_buffer;
1833   if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1834
1835     if ( $type eq 'csv' ) {
1836
1837       my %attr = ( 'binary' => 1, );
1838       $attr{sep_char} = $sep_char if $sep_char;
1839       $parser = new Text::CSV_XS \%attr;
1840
1841     } elsif ( $type eq 'fixedlength' ) {
1842
1843       eval "use Parse::FixedLength;";
1844       die $@ if $@;
1845       $parser = Parse::FixedLength->new($fixedlength_format);
1846
1847     }
1848     else {
1849       die "Unknown file type $type\n";
1850     }
1851
1852     @buffer = split(/\r?\n/, slurp($file) );
1853     splice(@buffer, 0, ($header || 0) );
1854     $count = scalar(@buffer);
1855
1856   } elsif ( $type eq 'xls' ) {
1857
1858     eval "use Spreadsheet::ParseExcel;";
1859     die $@ if $@;
1860
1861     eval "use DateTime::Format::Excel;";
1862     #for now, just let the error be thrown if it is used, since only CDR
1863     # formats bill_west and troop use it, not other excel-parsing things
1864     #die $@ if $@;
1865
1866     my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
1867
1868     $parser = $excel->{Worksheet}[0]; #first sheet
1869
1870     $count = $parser->{MaxRow} || $parser->{MinRow};
1871     $count++;
1872
1873     $row = $header || 0;
1874
1875   } elsif ( $type eq 'xml' ) {
1876
1877     # FS::pay_batch
1878     eval "use XML::Simple;";
1879     die $@ if $@;
1880     my $xmlrow = $xml_format->{'xmlrow'};
1881     $parser = $xml_format->{'xmlkeys'};
1882     die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
1883     my $data = XML::Simple::XMLin(
1884       $file,
1885       'SuppressEmpty' => '', #sets empty values to ''
1886       'KeepRoot'      => 1,
1887     );
1888     my $rows = $data;
1889     $rows = $rows->{$_} foreach @$xmlrow;
1890     $rows = [ $rows ] if ref($rows) ne 'ARRAY';
1891     $count = @buffer = @$rows;
1892
1893   } elsif ( $type eq 'asn.1' ) {
1894
1895     eval "use Convert::ASN1";
1896     die $@ if $@;
1897
1898     my $asn = Convert::ASN1->new;
1899     $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
1900
1901     $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
1902
1903     my $data = slurp($file);
1904     my $asn_output = $parser->decode( $data )
1905       or return "No ". $asn_format->{'macro'}. " found\n";
1906
1907     $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
1908
1909     my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
1910     $count = @buffer = @$rows;
1911
1912   } else {
1913     die "Unknown file type $type\n";
1914   }
1915
1916   #my $columns;
1917
1918   local $SIG{HUP} = 'IGNORE';
1919   local $SIG{INT} = 'IGNORE';
1920   local $SIG{QUIT} = 'IGNORE';
1921   local $SIG{TERM} = 'IGNORE';
1922   local $SIG{TSTP} = 'IGNORE';
1923   local $SIG{PIPE} = 'IGNORE';
1924
1925   my $oldAutoCommit = $FS::UID::AutoCommit;
1926   local $FS::UID::AutoCommit = 0;
1927   my $dbh = dbh;
1928
1929   #my $params  = $param->{params} || {};
1930   if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
1931     my $batch_col   = $param->{'batch_keycol'};
1932
1933     my $batch_class = 'FS::'. $param->{'batch_table'};
1934     my $batch = $batch_class->new({
1935       $param->{'batch_namecol'} => $param->{'batch_namevalue'}
1936     });
1937     my $error = $batch->insert;
1938     if ( $error ) {
1939       $dbh->rollback if $oldAutoCommit;
1940       return "can't insert batch record: $error";
1941     }
1942     #primary key via dbdef? (so the column names don't have to match)
1943     my $batch_value = $batch->get( $param->{'batch_keycol'} );
1944
1945     $params->{ $batch_col } = $batch_value;
1946   }
1947
1948   #my $job     = $param->{job};
1949   my $line;
1950   my $imported = 0;
1951   my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
1952   while (1) {
1953
1954     my @columns = ();
1955     my %hash = %$params;
1956     if ( $type eq 'csv' ) {
1957
1958       last unless scalar(@buffer);
1959       $line = shift(@buffer);
1960
1961       next if $line =~ /^\s*$/; #skip empty lines
1962
1963       $line = &{$row_callback}($line) if $row_callback;
1964
1965       next if $line =~ /^\s*$/; #skip empty lines
1966
1967       $parser->parse($line) or do {
1968         $dbh->rollback if $oldAutoCommit;
1969         return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
1970       };
1971       @columns = $parser->fields();
1972
1973     } elsif ( $type eq 'fixedlength' ) {
1974
1975       last unless scalar(@buffer);
1976       $line = shift(@buffer);
1977
1978       @columns = $parser->parse($line);
1979
1980     } elsif ( $type eq 'xls' ) {
1981
1982       last if $row > ($parser->{MaxRow} || $parser->{MinRow})
1983            || ! $parser->{Cells}[$row];
1984
1985       my @row = @{ $parser->{Cells}[$row] };
1986       @columns = map $_->{Val}, @row;
1987
1988       #my $z = 'A';
1989       #warn $z++. ": $_\n" for @columns;
1990
1991     } elsif ( $type eq 'xml' ) {
1992
1993       # $parser = [ 'Column0Key', 'Column1Key' ... ]
1994       last unless scalar(@buffer);
1995       my $row = shift @buffer;
1996       @columns = @{ $row }{ @$parser };
1997
1998     } elsif ( $type eq 'asn.1' ) {
1999
2000       last unless scalar(@buffer);
2001       my $row = shift @buffer;
2002       &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2003         if $asn_format->{row_callback};
2004       foreach my $key ( keys %{ $asn_format->{map} } ) {
2005         $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2006       }
2007
2008     } else {
2009       die "Unknown file type $type\n";
2010     }
2011
2012     my @later = ();
2013
2014     foreach my $field ( @fields ) {
2015
2016       my $value = shift @columns;
2017
2018       if ( ref($field) eq 'CODE' ) {
2019         #&{$field}(\%hash, $value);
2020         push @later, $field, $value;
2021       } else {
2022         #??? $hash{$field} = $value if length($value);
2023         $hash{$field} = $value if defined($value) && length($value);
2024       }
2025
2026     }
2027
2028     #my $table   = $param->{table};
2029     my $class = "FS::$table";
2030
2031     my $record = $class->new( \%hash );
2032
2033     my $param = {};
2034     while ( scalar(@later) ) {
2035       my $sub = shift @later;
2036       my $data = shift @later;
2037       eval {
2038         &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2039       };
2040       if ( $@ ) {
2041         $dbh->rollback if $oldAutoCommit;
2042         return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2043       }
2044       last if exists( $param->{skiprow} );
2045     }
2046     next if exists( $param->{skiprow} );
2047
2048     if ( $preinsert_callback ) {
2049       my $error = &{$preinsert_callback}($record, $param);
2050       if ( $error ) {
2051         $dbh->rollback if $oldAutoCommit;
2052         return "preinsert_callback error". ( $line ? " for $line" : '' ).
2053                ": $error";
2054       }
2055       next if exists $param->{skiprow} && $param->{skiprow};
2056     }
2057
2058     my $error = $record->insert;
2059
2060     if ( $error ) {
2061       $dbh->rollback if $oldAutoCommit;
2062       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2063     }
2064
2065     $row++;
2066     $imported++;
2067
2068     if ( $postinsert_callback ) {
2069       my $error = &{$postinsert_callback}($record, $param);
2070       if ( $error ) {
2071         $dbh->rollback if $oldAutoCommit;
2072         return "postinsert_callback error". ( $line ? " for $line" : '' ).
2073                ": $error";
2074       }
2075     }
2076
2077     if ( $job && time - $min_sec > $last ) { #progress bar
2078       $job->update_statustext( int(100 * $imported / $count) );
2079       $last = time;
2080     }
2081
2082   }
2083
2084   unless ( $imported || $param->{empty_ok} ) {
2085     $dbh->rollback if $oldAutoCommit;
2086     return "Empty file!";
2087   }
2088
2089   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2090
2091   ''; #no error
2092
2093 }
2094
2095 sub _h_statement {
2096   my( $self, $action, $time ) = @_;
2097
2098   $time ||= time;
2099
2100   my %nohistory = map { $_=>1 } $self->nohistory_fields;
2101
2102   my @fields =
2103     grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2104     real_fields($self->table);
2105   ;
2106
2107   # If we're encrypting then don't store the payinfo in the history
2108   if ( $conf && $conf->exists('encryption') && $self->table ne 'banned_pay' ) {
2109     @fields = grep { $_ ne 'payinfo' } @fields;
2110   }
2111
2112   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2113
2114   "INSERT INTO h_". $self->table. " ( ".
2115       join(', ', qw(history_date history_usernum history_action), @fields ).
2116     ") VALUES (".
2117       join(', ', $time,
2118                  $FS::CurrentUser::CurrentUser->usernum,
2119                  dbh->quote($action),
2120                  @values
2121       ).
2122     ")"
2123   ;
2124 }
2125
2126 =item unique COLUMN
2127
2128 B<Warning>: External use is B<deprecated>.
2129
2130 Replaces COLUMN in record with a unique number, using counters in the
2131 filesystem.  Used by the B<insert> method on single-field unique columns
2132 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2133 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2134
2135 Returns the new value.
2136
2137 =cut
2138
2139 sub unique {
2140   my($self,$field) = @_;
2141   my($table)=$self->table;
2142
2143   croak "Unique called on field $field, but it is ",
2144         $self->getfield($field),
2145         ", not null!"
2146     if $self->getfield($field);
2147
2148   #warn "table $table is tainted" if is_tainted($table);
2149   #warn "field $field is tainted" if is_tainted($field);
2150
2151   my($counter) = new File::CounterFile "$table.$field",0;
2152
2153   my $index = $counter->inc;
2154   $index = $counter->inc while qsearchs($table, { $field=>$index } );
2155
2156   $index =~ /^(\d*)$/;
2157   $index=$1;
2158
2159   $self->setfield($field,$index);
2160
2161 }
2162
2163 =item ut_float COLUMN
2164
2165 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
2166 null.  If there is an error, returns the error, otherwise returns false.
2167
2168 =cut
2169
2170 sub ut_float {
2171   my($self,$field)=@_ ;
2172   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2173    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2174    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2175    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2176     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2177   $self->setfield($field,$1);
2178   '';
2179 }
2180 =item ut_floatn COLUMN
2181
2182 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2183 null.  If there is an error, returns the error, otherwise returns false.
2184
2185 =cut
2186
2187 #false laziness w/ut_ipn
2188 sub ut_floatn {
2189   my( $self, $field ) = @_;
2190   if ( $self->getfield($field) =~ /^()$/ ) {
2191     $self->setfield($field,'');
2192     '';
2193   } else {
2194     $self->ut_float($field);
2195   }
2196 }
2197
2198 =item ut_sfloat COLUMN
2199
2200 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2201 May not be null.  If there is an error, returns the error, otherwise returns
2202 false.
2203
2204 =cut
2205
2206 sub ut_sfloat {
2207   my($self,$field)=@_ ;
2208   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2209    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2210    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2211    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2212     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2213   $self->setfield($field,$1);
2214   '';
2215 }
2216 =item ut_sfloatn COLUMN
2217
2218 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2219 null.  If there is an error, returns the error, otherwise returns false.
2220
2221 =cut
2222
2223 sub ut_sfloatn {
2224   my( $self, $field ) = @_;
2225   if ( $self->getfield($field) =~ /^()$/ ) {
2226     $self->setfield($field,'');
2227     '';
2228   } else {
2229     $self->ut_sfloat($field);
2230   }
2231 }
2232
2233 =item ut_snumber COLUMN
2234
2235 Check/untaint signed numeric data (whole numbers).  If there is an error,
2236 returns the error, otherwise returns false.
2237
2238 =cut
2239
2240 sub ut_snumber {
2241   my($self, $field) = @_;
2242   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2243     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2244   $self->setfield($field, "$1$2");
2245   '';
2246 }
2247
2248 =item ut_snumbern COLUMN
2249
2250 Check/untaint signed numeric data (whole numbers).  If there is an error,
2251 returns the error, otherwise returns false.
2252
2253 =cut
2254
2255 sub ut_snumbern {
2256   my($self, $field) = @_;
2257   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2258     or return "Illegal (numeric) $field: ". $self->getfield($field);
2259   if ($1) {
2260     return "Illegal (numeric) $field: ". $self->getfield($field)
2261       unless $2;
2262   }
2263   $self->setfield($field, "$1$2");
2264   '';
2265 }
2266
2267 =item ut_number COLUMN
2268
2269 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
2270 is an error, returns the error, otherwise returns false.
2271
2272 =cut
2273
2274 sub ut_number {
2275   my($self,$field)=@_;
2276   $self->getfield($field) =~ /^\s*(\d+)\s*$/
2277     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2278   $self->setfield($field,$1);
2279   '';
2280 }
2281
2282 =item ut_numbern COLUMN
2283
2284 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
2285 an error, returns the error, otherwise returns false.
2286
2287 =cut
2288
2289 sub ut_numbern {
2290   my($self,$field)=@_;
2291   $self->getfield($field) =~ /^\s*(\d*)\s*$/
2292     or return "Illegal (numeric) $field: ". $self->getfield($field);
2293   $self->setfield($field,$1);
2294   '';
2295 }
2296
2297 =item ut_money COLUMN
2298
2299 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
2300 is an error, returns the error, otherwise returns false.
2301
2302 =cut
2303
2304 sub ut_money {
2305   my($self,$field)=@_;
2306
2307   if ( $self->getfield($field) eq '' ) {
2308     $self->setfield($field, 0);
2309   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2310     #handle one decimal place without barfing out
2311     $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2312   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2313     $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2314   } else {
2315     return "Illegal (money) $field: ". $self->getfield($field);
2316   }
2317
2318   '';
2319 }
2320
2321 =item ut_moneyn COLUMN
2322
2323 Check/untaint monetary numbers.  May be negative.  If there
2324 is an error, returns the error, otherwise returns false.
2325
2326 =cut
2327
2328 sub ut_moneyn {
2329   my($self,$field)=@_;
2330   if ($self->getfield($field) eq '') {
2331     $self->setfield($field, '');
2332     return '';
2333   }
2334   $self->ut_money($field);
2335 }
2336
2337 =item ut_currencyn COLUMN
2338
2339 Check/untaint currency indicators, such as USD or EUR.  May be null.  If there
2340 is an error, returns the error, otherwise returns false.
2341
2342 =cut
2343
2344 sub ut_currencyn {
2345   my($self, $field) = @_;
2346   if ($self->getfield($field) eq '') { #can be null
2347     $self->setfield($field, '');
2348     return '';
2349   }
2350   $self->ut_currency($field);
2351 }
2352
2353 =item ut_currency COLUMN
2354
2355 Check/untaint currency indicators, such as USD or EUR.  May not be null.  If
2356 there is an error, returns the error, otherwise returns false.
2357
2358 =cut
2359
2360 sub ut_currency {
2361   my($self, $field) = @_;
2362   my $value = uc( $self->getfield($field) );
2363   if ( code2currency($value) ) {
2364     $self->setfield($value);
2365   } else {
2366     return "Unknown currency $value";
2367   }
2368
2369   '';
2370 }
2371
2372 =item ut_text COLUMN
2373
2374 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2375 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2376 May not be null.  If there is an error, returns the error, otherwise returns
2377 false.
2378
2379 =cut
2380
2381 sub ut_text {
2382   my($self,$field)=@_;
2383   #warn "msgcat ". \&msgcat. "\n";
2384   #warn "notexist ". \&notexist. "\n";
2385   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2386   $self->getfield($field)
2387     =~ /^([\wô \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
2388       or return gettext('illegal_or_empty_text'). " $field: ".
2389                  $self->getfield($field);
2390   $self->setfield($field,$1);
2391   '';
2392 }
2393
2394 =item ut_textn COLUMN
2395
2396 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2397 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2398 May be null.  If there is an error, returns the error, otherwise returns false.
2399
2400 =cut
2401
2402 sub ut_textn {
2403   my($self,$field)=@_;
2404   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2405   $self->ut_text($field);
2406 }
2407
2408 =item ut_alpha COLUMN
2409
2410 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
2411 an error, returns the error, otherwise returns false.
2412
2413 =cut
2414
2415 sub ut_alpha {
2416   my($self,$field)=@_;
2417   $self->getfield($field) =~ /^(\w+)$/
2418     or return "Illegal or empty (alphanumeric) $field: ".
2419               $self->getfield($field);
2420   $self->setfield($field,$1);
2421   '';
2422 }
2423
2424 =item ut_alphan COLUMN
2425
2426 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
2427 error, returns the error, otherwise returns false.
2428
2429 =cut
2430
2431 sub ut_alphan {
2432   my($self,$field)=@_;
2433   $self->getfield($field) =~ /^(\w*)$/
2434     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2435   $self->setfield($field,$1);
2436   '';
2437 }
2438
2439 =item ut_alphasn COLUMN
2440
2441 Check/untaint alphanumeric strings, spaces allowed.  May be null.  If there is
2442 an error, returns the error, otherwise returns false.
2443
2444 =cut
2445
2446 sub ut_alphasn {
2447   my($self,$field)=@_;
2448   $self->getfield($field) =~ /^([\w ]*)$/
2449     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2450   $self->setfield($field,$1);
2451   '';
2452 }
2453
2454
2455 =item ut_alpha_lower COLUMN
2456
2457 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
2458 there is an error, returns the error, otherwise returns false.
2459
2460 =cut
2461
2462 sub ut_alpha_lower {
2463   my($self,$field)=@_;
2464   $self->getfield($field) =~ /[[:upper:]]/
2465     and return "Uppercase characters are not permitted in $field";
2466   $self->ut_alpha($field);
2467 }
2468
2469 =item ut_phonen COLUMN [ COUNTRY ]
2470
2471 Check/untaint phone numbers.  May be null.  If there is an error, returns
2472 the error, otherwise returns false.
2473
2474 Takes an optional two-letter ISO country code; without it or with unsupported
2475 countries, ut_phonen simply calls ut_alphan.
2476
2477 =cut
2478
2479 sub ut_phonen {
2480   my( $self, $field, $country ) = @_;
2481   return $self->ut_alphan($field) unless defined $country;
2482   my $phonen = $self->getfield($field);
2483   if ( $phonen eq '' ) {
2484     $self->setfield($field,'');
2485   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2486     $phonen =~ s/\D//g;
2487     $phonen = $conf->config('cust_main-default_areacode').$phonen
2488       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2489     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2490       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2491     $phonen = "$1-$2-$3";
2492     $phonen .= " x$4" if $4;
2493     $self->setfield($field,$phonen);
2494   } else {
2495     warn "warning: don't know how to check phone numbers for country $country";
2496     return $self->ut_textn($field);
2497   }
2498   '';
2499 }
2500
2501 =item ut_hex COLUMN
2502
2503 Check/untaint hexadecimal values.
2504
2505 =cut
2506
2507 sub ut_hex {
2508   my($self, $field) = @_;
2509   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2510     or return "Illegal (hex) $field: ". $self->getfield($field);
2511   $self->setfield($field, uc($1));
2512   '';
2513 }
2514
2515 =item ut_hexn COLUMN
2516
2517 Check/untaint hexadecimal values.  May be null.
2518
2519 =cut
2520
2521 sub ut_hexn {
2522   my($self, $field) = @_;
2523   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2524     or return "Illegal (hex) $field: ". $self->getfield($field);
2525   $self->setfield($field, uc($1));
2526   '';
2527 }
2528
2529 =item ut_mac_addr COLUMN
2530
2531 Check/untaint mac addresses.  May be null.
2532
2533 =cut
2534
2535 sub ut_mac_addr {
2536   my($self, $field) = @_;
2537
2538   my $mac = $self->get($field);
2539   $mac =~ s/\s+//g;
2540   $mac =~ s/://g;
2541   $self->set($field, $mac);
2542
2543   my $e = $self->ut_hex($field);
2544   return $e if $e;
2545
2546   return "Illegal (mac address) $field: ". $self->getfield($field)
2547     unless length($self->getfield($field)) == 12;
2548
2549   '';
2550
2551 }
2552
2553 =item ut_mac_addrn COLUMN
2554
2555 Check/untaint mac addresses.  May be null.
2556
2557 =cut
2558
2559 sub ut_mac_addrn {
2560   my($self, $field) = @_;
2561   ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2562 }
2563
2564 =item ut_ip COLUMN
2565
2566 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2567 to 127.0.0.1.
2568
2569 =cut
2570
2571 sub ut_ip {
2572   my( $self, $field ) = @_;
2573   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2574   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2575     or return "Illegal (IP address) $field: ". $self->getfield($field);
2576   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2577   $self->setfield($field, "$1.$2.$3.$4");
2578   '';
2579 }
2580
2581 =item ut_ipn COLUMN
2582
2583 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2584 to 127.0.0.1.  May be null.
2585
2586 =cut
2587
2588 sub ut_ipn {
2589   my( $self, $field ) = @_;
2590   if ( $self->getfield($field) =~ /^()$/ ) {
2591     $self->setfield($field,'');
2592     '';
2593   } else {
2594     $self->ut_ip($field);
2595   }
2596 }
2597
2598 =item ut_ip46 COLUMN
2599
2600 Check/untaint IPv4 or IPv6 address.
2601
2602 =cut
2603
2604 sub ut_ip46 {
2605   my( $self, $field ) = @_;
2606   my $ip = NetAddr::IP->new($self->getfield($field))
2607     or return "Illegal (IP address) $field: ".$self->getfield($field);
2608   $self->setfield($field, lc($ip->addr));
2609   return '';
2610 }
2611
2612 =item ut_ip46n
2613
2614 Check/untaint IPv6 or IPv6 address.  May be null.
2615
2616 =cut
2617
2618 sub ut_ip46n {
2619   my( $self, $field ) = @_;
2620   if ( $self->getfield($field) =~ /^$/ ) {
2621     $self->setfield($field, '');
2622     return '';
2623   }
2624   $self->ut_ip46($field);
2625 }
2626
2627 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2628
2629 Check/untaint coordinates.
2630 Accepts the following forms:
2631 DDD.DDDDD
2632 -DDD.DDDDD
2633 DDD MM.MMM
2634 -DDD MM.MMM
2635 DDD MM SS
2636 -DDD MM SS
2637 DDD MM MMM
2638 -DDD MM MMM
2639
2640 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2641 The latter form (that is, the MMM are thousands of minutes) is
2642 assumed if the "MMM" is exactly three digits or two digits > 59.
2643
2644 To be safe, just use the DDD.DDDDD form.
2645
2646 If LOWER or UPPER are specified, then the coordinate is checked
2647 for lower and upper bounds, respectively.
2648
2649 =cut
2650
2651 sub ut_coord {
2652   my ($self, $field) = (shift, shift);
2653
2654   my($lower, $upper);
2655   if ( $field =~ /latitude/ ) {
2656     $lower = $lat_lower;
2657     $upper = 90;
2658   } elsif ( $field =~ /longitude/ ) {
2659     $lower = -180;
2660     $upper = $lon_upper;
2661   }
2662
2663   my $coord = $self->getfield($field);
2664   my $neg = $coord =~ s/^(-)//;
2665
2666   my ($d, $m, $s) = (0, 0, 0);
2667
2668   if (
2669     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2670     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2671     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2672   ) {
2673     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2674     $m = $m / 60;
2675     if ($m > 59) {
2676       return "Invalid (coordinate with minutes > 59) $field: "
2677              . $self->getfield($field);
2678     }
2679
2680     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2681
2682     if (defined($lower) and ($coord < $lower)) {
2683       return "Invalid (coordinate < $lower) $field: "
2684              . $self->getfield($field);;
2685     }
2686
2687     if (defined($upper) and ($coord > $upper)) {
2688       return "Invalid (coordinate > $upper) $field: "
2689              . $self->getfield($field);;
2690     }
2691
2692     $self->setfield($field, $coord);
2693     return '';
2694   }
2695
2696   return "Invalid (coordinate) $field: " . $self->getfield($field);
2697
2698 }
2699
2700 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2701
2702 Same as ut_coord, except optionally null.
2703
2704 =cut
2705
2706 sub ut_coordn {
2707
2708   my ($self, $field) = (shift, shift);
2709
2710   if ($self->getfield($field) =~ /^\s*$/) {
2711     return '';
2712   } else {
2713     return $self->ut_coord($field, @_);
2714   }
2715
2716 }
2717
2718 =item ut_domain COLUMN
2719
2720 Check/untaint host and domain names.  May not be null.
2721
2722 =cut
2723
2724 sub ut_domain {
2725   my( $self, $field ) = @_;
2726   #$self->getfield($field) =~/^(\w+\.)*\w+$/
2727   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2728     or return "Illegal (hostname) $field: ". $self->getfield($field);
2729   $self->setfield($field,$1);
2730   '';
2731 }
2732
2733 =item ut_domainn COLUMN
2734
2735 Check/untaint host and domain names.  May be null.
2736
2737 =cut
2738
2739 sub ut_domainn {
2740   my( $self, $field ) = @_;
2741   if ( $self->getfield($field) =~ /^()$/ ) {
2742     $self->setfield($field,'');
2743     '';
2744   } else {
2745     $self->ut_domain($field);
2746   }
2747 }
2748
2749 =item ut_name COLUMN
2750
2751 Check/untaint proper names; allows alphanumerics, spaces and the following
2752 punctuation: , . - '
2753
2754 May not be null.
2755
2756 =cut
2757
2758 sub ut_name {
2759   my( $self, $field ) = @_;
2760 #  warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
2761   $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
2762     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2763   my $name = $1;
2764   $name =~ s/^\s+//;
2765   $name =~ s/\s+$//;
2766   $name =~ s/\s+/ /g;
2767   $self->setfield($field, $name);
2768   '';
2769 }
2770
2771 =item ut_namen COLUMN
2772
2773 Check/untaint proper names; allows alphanumerics, spaces and the following
2774 punctuation: , . - '
2775
2776 May not be null.
2777
2778 =cut
2779
2780 sub ut_namen {
2781   my( $self, $field ) = @_;
2782   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2783   $self->ut_name($field);
2784 }
2785
2786 =item ut_zip COLUMN
2787
2788 Check/untaint zip codes.
2789
2790 =cut
2791
2792 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2793
2794 sub ut_zip {
2795   my( $self, $field, $country ) = @_;
2796
2797   if ( $country eq 'US' ) {
2798
2799     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2800       or return gettext('illegal_zip'). " $field for country $country: ".
2801                 $self->getfield($field);
2802     $self->setfield($field, $1);
2803
2804   } elsif ( $country eq 'CA' ) {
2805
2806     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2807       or return gettext('illegal_zip'). " $field for country $country: ".
2808                 $self->getfield($field);
2809     $self->setfield($field, "$1 $2");
2810
2811   } else {
2812
2813     if ( $self->getfield($field) =~ /^\s*$/
2814          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2815        )
2816     {
2817       $self->setfield($field,'');
2818     } else {
2819       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
2820         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2821       $self->setfield($field,$1);
2822     }
2823
2824   }
2825
2826   '';
2827 }
2828
2829 =item ut_country COLUMN
2830
2831 Check/untaint country codes.  Country names are changed to codes, if possible -
2832 see L<Locale::Country>.
2833
2834 =cut
2835
2836 sub ut_country {
2837   my( $self, $field ) = @_;
2838   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2839     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2840          && country2code($1) ) {
2841       $self->setfield($field,uc(country2code($1)));
2842     }
2843   }
2844   $self->getfield($field) =~ /^(\w\w)$/
2845     or return "Illegal (country) $field: ". $self->getfield($field);
2846   $self->setfield($field,uc($1));
2847   '';
2848 }
2849
2850 =item ut_anything COLUMN
2851
2852 Untaints arbitrary data.  Be careful.
2853
2854 =cut
2855
2856 sub ut_anything {
2857   my( $self, $field ) = @_;
2858   $self->getfield($field) =~ /^(.*)$/s
2859     or return "Illegal $field: ". $self->getfield($field);
2860   $self->setfield($field,$1);
2861   '';
2862 }
2863
2864 =item ut_enum COLUMN CHOICES_ARRAYREF
2865
2866 Check/untaint a column, supplying all possible choices, like the "enum" type.
2867
2868 =cut
2869
2870 sub ut_enum {
2871   my( $self, $field, $choices ) = @_;
2872   foreach my $choice ( @$choices ) {
2873     if ( $self->getfield($field) eq $choice ) {
2874       $self->setfield($field, $choice);
2875       return '';
2876     }
2877   }
2878   return "Illegal (enum) field $field: ". $self->getfield($field);
2879 }
2880
2881 =item ut_enumn COLUMN CHOICES_ARRAYREF
2882
2883 Like ut_enum, except the null value is also allowed.
2884
2885 =cut
2886
2887 sub ut_enumn {
2888   my( $self, $field, $choices ) = @_;
2889   $self->getfield($field)
2890     ? $self->ut_enum($field, $choices)
2891     : '';
2892 }
2893
2894 =item ut_flag COLUMN
2895
2896 Check/untaint a column if it contains either an empty string or 'Y'.  This
2897 is the standard form for boolean flags in Freeside.
2898
2899 =cut
2900
2901 sub ut_flag {
2902   my( $self, $field ) = @_;
2903   my $value = uc($self->getfield($field));
2904   if ( $value eq '' or $value eq 'Y' ) {
2905     $self->setfield($field, $value);
2906     return '';
2907   }
2908   return "Illegal (flag) field $field: $value";
2909 }
2910
2911 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2912
2913 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
2914 on the column first.
2915
2916 =cut
2917
2918 sub ut_foreign_key {
2919   my( $self, $field, $table, $foreign ) = @_;
2920   return '' if $no_check_foreign;
2921   qsearchs($table, { $foreign => $self->getfield($field) })
2922     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
2923               " in $table.$foreign";
2924   '';
2925 }
2926
2927 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2928
2929 Like ut_foreign_key, except the null value is also allowed.
2930
2931 =cut
2932
2933 sub ut_foreign_keyn {
2934   my( $self, $field, $table, $foreign ) = @_;
2935   $self->getfield($field)
2936     ? $self->ut_foreign_key($field, $table, $foreign)
2937     : '';
2938 }
2939
2940 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
2941
2942 Checks this column as an agentnum, taking into account the current users's
2943 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
2944 right or rights allowing no agentnum.
2945
2946 =cut
2947
2948 sub ut_agentnum_acl {
2949   my( $self, $field ) = (shift, shift);
2950   my $null_acl = scalar(@_) ? shift : [];
2951   $null_acl = [ $null_acl ] unless ref($null_acl);
2952
2953   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
2954   return "Illegal agentnum: $error" if $error;
2955
2956   my $curuser = $FS::CurrentUser::CurrentUser;
2957
2958   if ( $self->$field() ) {
2959
2960     return "Access denied"
2961       unless $curuser->agentnum($self->$field());
2962
2963   } else {
2964
2965     return "Access denied"
2966       unless grep $curuser->access_right($_), @$null_acl;
2967
2968   }
2969
2970   '';
2971
2972 }
2973
2974 =item fields [ TABLE ]
2975
2976 This is a wrapper for real_fields.  Code that called
2977 fields before should probably continue to call fields.
2978
2979 =cut
2980
2981 sub fields {
2982   my $something = shift;
2983   my $table;
2984   if($something->isa('FS::Record')) {
2985     $table = $something->table;
2986   } else {
2987     $table = $something;
2988     $something = "FS::$table";
2989   }
2990   return (real_fields($table));
2991 }
2992
2993
2994 =item encrypt($value)
2995
2996 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2997
2998 Returns the encrypted string.
2999
3000 You should generally not have to worry about calling this, as the system handles this for you.
3001
3002 =cut
3003
3004 sub encrypt {
3005   my ($self, $value) = @_;
3006   my $encrypted;
3007
3008   if ($conf->exists('encryption')) {
3009     if ($self->is_encrypted($value)) {
3010       # Return the original value if it isn't plaintext.
3011       $encrypted = $value;
3012     } else {
3013       $self->loadRSA;
3014       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
3015         # RSA doesn't like the empty string so let's pack it up
3016         # The database doesn't like the RSA data so uuencode it
3017         my $length = length($value)+1;
3018         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
3019       } else {
3020         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
3021       }
3022     }
3023   }
3024   return $encrypted;
3025 }
3026
3027 =item is_encrypted($value)
3028
3029 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
3030
3031 =cut
3032
3033
3034 sub is_encrypted {
3035   my ($self, $value) = @_;
3036   # could be more precise about it, but this will do for now
3037   $value =~ /^M/ && length($value) > 80;
3038 }
3039
3040 =item decrypt($value)
3041
3042 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
3043
3044 You should generally not have to worry about calling this, as the system handles this for you.
3045
3046 =cut
3047
3048 sub decrypt {
3049   my ($self,$value) = @_;
3050   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
3051   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
3052     $self->loadRSA;
3053     if (ref($rsa_decrypt) =~ /::RSA/) {
3054       my $encrypted = unpack ("u*", $value);
3055       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
3056       if ($@) {warn "Decryption Failed"};
3057     }
3058   }
3059   return $decrypted;
3060 }
3061
3062 sub loadRSA {
3063     my $self = shift;
3064     #Initialize the Module
3065     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
3066
3067     if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
3068       $rsa_module = $conf->config('encryptionmodule');
3069     }
3070
3071     if (!$rsa_loaded) {
3072         eval ("require $rsa_module"); # No need to import the namespace
3073         $rsa_loaded++;
3074     }
3075     # Initialize Encryption
3076     if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
3077       my $public_key = join("\n",$conf->config('encryptionpublickey'));
3078       $rsa_encrypt = $rsa_module->new_public_key($public_key);
3079     }
3080
3081     # Intitalize Decryption
3082     if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
3083       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
3084       $rsa_decrypt = $rsa_module->new_private_key($private_key);
3085     }
3086 }
3087
3088 =item h_search ACTION
3089
3090 Given an ACTION, either "insert", or "delete", returns the appropriate history
3091 record corresponding to this record, if any.
3092
3093 =cut
3094
3095 sub h_search {
3096   my( $self, $action ) = @_;
3097
3098   my $table = $self->table;
3099   $table =~ s/^h_//;
3100
3101   my $primary_key = dbdef->table($table)->primary_key;
3102
3103   qsearchs({
3104     'table'   => "h_$table",
3105     'hashref' => { $primary_key     => $self->$primary_key(),
3106                    'history_action' => $action,
3107                  },
3108   });
3109
3110 }
3111
3112 =item h_date ACTION
3113
3114 Given an ACTION, either "insert", or "delete", returns the timestamp of the
3115 appropriate history record corresponding to this record, if any.
3116
3117 =cut
3118
3119 sub h_date {
3120   my($self, $action) = @_;
3121   my $h = $self->h_search($action);
3122   $h ? $h->history_date : '';
3123 }
3124
3125 =item scalar_sql SQL [ PLACEHOLDER, ... ]
3126
3127 A class or object method.  Executes the sql statement represented by SQL and
3128 returns a scalar representing the result: the first column of the first row.
3129
3130 Dies on bogus SQL.  Returns an empty string if no row is returned.
3131
3132 Typically used for statments which return a single value such as "SELECT
3133 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
3134
3135 =cut
3136
3137 sub scalar_sql {
3138   my($self, $sql) = (shift, shift);
3139   my $sth = dbh->prepare($sql) or die dbh->errstr;
3140   $sth->execute(@_)
3141     or die "Unexpected error executing statement $sql: ". $sth->errstr;
3142   my $row = $sth->fetchrow_arrayref or return '';
3143   my $scalar = $row->[0];
3144   defined($scalar) ? $scalar : '';
3145 }
3146
3147 =item count [ WHERE ]
3148
3149 Convenience method for the common case of "SELECT COUNT(*) FROM table",
3150 with optional WHERE.  Must be called as method on a class with an
3151 associated table.
3152
3153 =cut
3154
3155 sub count {
3156   my($self, $where) = (shift, shift);
3157   my $table = $self->table or die 'count called on object of class '.ref($self);
3158   my $sql = "SELECT COUNT(*) FROM $table";
3159   $sql .= " WHERE $where" if $where;
3160   $self->scalar_sql($sql);
3161 }
3162
3163 =back
3164
3165 =head1 SUBROUTINES
3166
3167 =over 4
3168
3169 =item real_fields [ TABLE ]
3170
3171 Returns a list of the real columns in the specified table.  Called only by
3172 fields() and other subroutines elsewhere in FS::Record.
3173
3174 =cut
3175
3176 sub real_fields {
3177   my $table = shift;
3178
3179   my($table_obj) = dbdef->table($table);
3180   confess "Unknown table $table" unless $table_obj;
3181   $table_obj->columns;
3182 }
3183
3184 =item pvf FIELD_NAME
3185
3186 Returns the FS::part_virtual_field object corresponding to a field in the
3187 record (specified by FIELD_NAME).
3188
3189 =cut
3190
3191 sub pvf {
3192   my ($self, $name) = (shift, shift);
3193
3194   if(grep /^$name$/, $self->virtual_fields) {
3195     $name =~ s/^cf_//;
3196     my $concat = [ "'cf_'", "name" ];
3197     return qsearchs({   table   =>  'part_virtual_field',
3198                         hashref =>  { dbtable => $self->table,
3199                                       name    => $name
3200                                     },
3201                         select  =>  'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
3202                     });
3203   }
3204   ''
3205 }
3206
3207 =item _quote VALUE, TABLE, COLUMN
3208
3209 This is an internal function used to construct SQL statements.  It returns
3210 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3211 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3212
3213 =cut
3214
3215 sub _quote {
3216   my($value, $table, $column) = @_;
3217   my $column_obj = dbdef->table($table)->column($column);
3218   my $column_type = $column_obj->type;
3219   my $nullable = $column_obj->null;
3220
3221   warn "  $table.$column: $value ($column_type".
3222        ( $nullable ? ' NULL' : ' NOT NULL' ).
3223        ")\n" if $DEBUG > 2;
3224
3225   if ( $value eq '' && $nullable ) {
3226     'NULL';
3227   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3228     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3229           "using 0 instead";
3230     0;
3231   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3232             ! $column_type =~ /(char|binary|text)$/i ) {
3233     $value;
3234   } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3235            && driver_name eq 'Pg'
3236           )
3237   {
3238     no strict 'subs';
3239 #    dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right
3240     # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\,
3241     # single-quote the whole mess, and put an "E" in front.
3242     return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'");
3243   } else {
3244     dbh->quote($value);
3245   }
3246 }
3247
3248 =item hfields TABLE
3249
3250 This is deprecated.  Don't use it.
3251
3252 It returns a hash-type list with the fields of this record's table set true.
3253
3254 =cut
3255
3256 sub hfields {
3257   carp "warning: hfields is deprecated";
3258   my($table)=@_;
3259   my(%hash);
3260   foreach (fields($table)) {
3261     $hash{$_}=1;
3262   }
3263   \%hash;
3264 }
3265
3266 sub _dump {
3267   my($self)=@_;
3268   join("\n", map {
3269     "$_: ". $self->getfield($_). "|"
3270   } (fields($self->table)) );
3271 }
3272
3273 sub DESTROY { return; }
3274
3275 #sub DESTROY {
3276 #  my $self = shift;
3277 #  #use Carp qw(cluck);
3278 #  #cluck "DESTROYING $self";
3279 #  warn "DESTROYING $self";
3280 #}
3281
3282 #sub is_tainted {
3283 #             return ! eval { join('',@_), kill 0; 1; };
3284 #         }
3285
3286 =item str2time_sql [ DRIVER_NAME ]
3287
3288 Returns a function to convert to unix time based on database type, such as
3289 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
3290 the str2time_sql_closing method to return a closing string rather than just
3291 using a closing parenthesis as previously suggested.
3292
3293 You can pass an optional driver name such as "Pg", "mysql" or
3294 $dbh->{Driver}->{Name} to return a function for that database instead of
3295 the current database.
3296
3297 =cut
3298
3299 sub str2time_sql {
3300   my $driver = shift || driver_name;
3301
3302   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
3303   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3304
3305   warn "warning: unknown database type $driver; guessing how to convert ".
3306        "dates to UNIX timestamps";
3307   return 'EXTRACT(EPOCH FROM ';
3308
3309 }
3310
3311 =item str2time_sql_closing [ DRIVER_NAME ]
3312
3313 Returns the closing suffix of a function to convert to unix time based on
3314 database type, such as ")::integer" for Pg or ")" for mysql.
3315
3316 You can pass an optional driver name such as "Pg", "mysql" or
3317 $dbh->{Driver}->{Name} to return a function for that database instead of
3318 the current database.
3319
3320 =cut
3321
3322 sub str2time_sql_closing {
3323   my $driver = shift || driver_name;
3324
3325   return ' )::INTEGER ' if $driver =~ /^Pg/i;
3326   return ' ) ';
3327 }
3328
3329 =item regexp_sql [ DRIVER_NAME ]
3330
3331 Returns the operator to do a regular expression comparison based on database
3332 type, such as '~' for Pg or 'REGEXP' for mysql.
3333
3334 You can pass an optional driver name such as "Pg", "mysql" or
3335 $dbh->{Driver}->{Name} to return a function for that database instead of
3336 the current database.
3337
3338 =cut
3339
3340 sub regexp_sql {
3341   my $driver = shift || driver_name;
3342
3343   return '~'      if $driver =~ /^Pg/i;
3344   return 'REGEXP' if $driver =~ /^mysql/i;
3345
3346   die "don't know how to use regular expressions in ". driver_name." databases";
3347
3348 }
3349
3350 =item not_regexp_sql [ DRIVER_NAME ]
3351
3352 Returns the operator to do a regular expression negation based on database
3353 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3354
3355 You can pass an optional driver name such as "Pg", "mysql" or
3356 $dbh->{Driver}->{Name} to return a function for that database instead of
3357 the current database.
3358
3359 =cut
3360
3361 sub not_regexp_sql {
3362   my $driver = shift || driver_name;
3363
3364   return '!~'         if $driver =~ /^Pg/i;
3365   return 'NOT REGEXP' if $driver =~ /^mysql/i;
3366
3367   die "don't know how to use regular expressions in ". driver_name." databases";
3368
3369 }
3370
3371 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3372
3373 Returns the items concatenated based on database type, using "CONCAT()" for
3374 mysql and " || " for Pg and other databases.
3375
3376 You can pass an optional driver name such as "Pg", "mysql" or
3377 $dbh->{Driver}->{Name} to return a function for that database instead of
3378 the current database.
3379
3380 =cut
3381
3382 sub concat_sql {
3383   my $driver = ref($_[0]) ? driver_name : shift;
3384   my $items = shift;
3385
3386   if ( $driver =~ /^mysql/i ) {
3387     'CONCAT('. join(',', @$items). ')';
3388   } else {
3389     join('||', @$items);
3390   }
3391
3392 }
3393
3394 =item midnight_sql DATE
3395
3396 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3397 on that day in the system timezone, using the default driver name.
3398
3399 =cut
3400
3401 sub midnight_sql {
3402   my $driver = driver_name;
3403   my $expr = shift;
3404   if ( $driver =~ /^mysql/i ) {
3405     "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3406   }
3407   else {
3408     "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3409   }
3410 }
3411
3412 =back
3413
3414 =head1 BUGS
3415
3416 This module should probably be renamed, since much of the functionality is
3417 of general use.  It is not completely unlike Adapter::DBI (see below).
3418
3419 Exported qsearch and qsearchs should be deprecated in favor of method calls
3420 (against an FS::Record object like the old search and searchs that qsearch
3421 and qsearchs were on top of.)
3422
3423 The whole fields / hfields mess should be removed.
3424
3425 The various WHERE clauses should be subroutined.
3426
3427 table string should be deprecated in favor of DBIx::DBSchema::Table.
3428
3429 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
3430 true maps to the database (and WHERE clauses) would also help.
3431
3432 The ut_ methods should ask the dbdef for a default length.
3433
3434 ut_sqltype (like ut_varchar) should all be defined
3435
3436 A fallback check method should be provided which uses the dbdef.
3437
3438 The ut_money method assumes money has two decimal digits.
3439
3440 The Pg money kludge in the new method only strips `$'.
3441
3442 The ut_phonen method only checks US-style phone numbers.
3443
3444 The _quote function should probably use ut_float instead of a regex.
3445
3446 All the subroutines probably should be methods, here or elsewhere.
3447
3448 Probably should borrow/use some dbdef methods where appropriate (like sub
3449 fields)
3450
3451 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3452 or allow it to be set.  Working around it is ugly any way around - DBI should
3453 be fixed.  (only affects RDBMS which return uppercase column names)
3454
3455 ut_zip should take an optional country like ut_phone.
3456
3457 =head1 SEE ALSO
3458
3459 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3460
3461 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
3462
3463 http://poop.sf.net/
3464
3465 =cut
3466
3467 1;
3468