FS/FS/Record.pm

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