FS/FS/Record.pm

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