FS/FS/Record.pm

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