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