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