FS/FS/Record.pm

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