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