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