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