FS/FS/Record.pm

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