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