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