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