FS/FS/Record.pm

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