FS/FS/Record.pm

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