FS/FS/Record.pm

   1 package FS::Record;
   2 use base qw( Exporter );
   3
   4 use strict;
   5 use charnames ':full';
   6 use vars qw( $AUTOLOAD
   7              %virtual_fields_cache %fk_method_cache $fk_table_cache
   8              $money_char $lat_lower $lon_upper
   9            );
  10 use Carp qw(carp cluck croak confess);
  11 use Scalar::Util qw( blessed );
  12 use File::Slurp qw( slurp );
  13 use File::CounterFile;
  14 use Text::CSV_XS;
  15 use DBI qw(:sql_types);
  16 use DBIx::DBSchema 0.43; #0.43 for foreign keys
  17 use Locale::Country;
  18 use Locale::Currency;
  19 use NetAddr::IP; # for validation
  20 use FS::UID qw(dbh datasrc driver_name);
  21 use FS::CurrentUser;
  22 use FS::Schema qw(dbdef);
  23 use FS::SearchCache;
  24 use FS::Msgcat qw(gettext);
  25 #use FS::Conf; #dependency loop bs, in install_callback below instead
  26
  27 use FS::part_virtual_field;
  28
  29 use Tie::IxHash;
  30
  31 our @encrypt_payby = qw( CARD DCRD CHEK DCHK );
  32
  33 #export dbdef for now... everything else expects to find it here
  34 our @EXPORT_OK = qw(
  35   dbh fields hfields qsearch qsearchs dbdef jsearch
  36   str2time_sql str2time_sql_closing regexp_sql not_regexp_sql
  37   concat_sql group_concat_sql
  38   midnight_sql fk_methods_init
  39 );
  40
  41 our $DEBUG = 0;
  42 our $me = '[FS::Record]';
  43
  44 our $nowarn_identical = 0;
  45 our $nowarn_classload = 0;
  46 our $no_update_diff = 0;
  47 our $no_history = 0;
  48
  49 our $qsearch_qualify_columns = 1;
  50
  51 our $no_check_foreign = 1; #well, not inefficiently in perl by default anymore
  52
  53 my $rsa_module;
  54 my $rsa_loaded;
  55 my $rsa_encrypt;
  56 my $rsa_decrypt;
  57
  58 our $conf = '';
  59 our $conf_encryption = '';
  60 our $conf_encryptionmodule = '';
  61 our $conf_encryptionpublickey = '';
  62 our $conf_encryptionprivatekey = '';
  63 FS::UID->install_callback( sub {
  64
  65   eval "use FS::Conf;";
  66   die $@ if $@;
  67   $conf = FS::Conf->new;
  68   $conf_encryption           = $conf->exists('encryption');
  69   $conf_encryptionmodule     = $conf->config('encryptionmodule');
  70   $conf_encryptionpublickey  = join("\n",$conf->config('encryptionpublickey'));
  71   $conf_encryptionprivatekey = join("\n",$conf->config('encryptionprivatekey'));
  72   $money_char = $conf->config('money_char') || '$';
  73   my $nw_coords = $conf->exists('geocode-require_nw_coordinates');
  74   $lat_lower = $nw_coords ? 1 : -90;
  75   $lon_upper = $nw_coords ? -1 : 180;
  76
  77   $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
  78
  79   if ( driver_name eq 'Pg' ) {
  80     eval "use DBD::Pg ':pg_types'";
  81     die $@ if $@;
  82   } else {
  83     eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }";
  84   }
  85
  86   #fk_methods_init();
  87
  88 } );
  89
  90 =head1 NAME
  91
  92 FS::Record - Database record objects
  93
  94 =head1 SYNOPSIS
  95
  96     use FS::Record;
  97     use FS::Record qw(dbh fields qsearch qsearchs);
  98
  99     $record = new FS::Record 'table', \%hash;
 100     $record = new FS::Record 'table', { 'column' => 'value', ... };
 101
 102     $record  = qsearchs FS::Record 'table', \%hash;
 103     $record  = qsearchs FS::Record 'table', { 'column' => 'value', ... };
 104     @records = qsearch  FS::Record 'table', \%hash;
 105     @records = qsearch  FS::Record 'table', { 'column' => 'value', ... };
 106
 107     $table = $record->table;
 108     $dbdef_table = $record->dbdef_table;
 109
 110     $value = $record->get('column');
 111     $value = $record->getfield('column');
 112     $value = $record->column;
 113
 114     $record->set( 'column' => 'value' );
 115     $record->setfield( 'column' => 'value' );
 116     $record->column('value');
 117
 118     %hash = $record->hash;
 119
 120     $hashref = $record->hashref;
 121
 122     $error = $record->insert;
 123
 124     $error = $record->delete;
 125
 126     $error = $new_record->replace($old_record);
 127
 128     # external use deprecated - handled by the database (at least for Pg, mysql)
 129     $value = $record->unique('column');
 130
 131     $error = $record->ut_float('column');
 132     $error = $record->ut_floatn('column');
 133     $error = $record->ut_number('column');
 134     $error = $record->ut_numbern('column');
 135     $error = $record->ut_decimal('column');
 136     $error = $record->ut_decimaln('column');
 137     $error = $record->ut_snumber('column');
 138     $error = $record->ut_snumbern('column');
 139     $error = $record->ut_money('column');
 140     $error = $record->ut_text('column');
 141     $error = $record->ut_textn('column');
 142     $error = $record->ut_alpha('column');
 143     $error = $record->ut_alphan('column');
 144     $error = $record->ut_phonen('column');
 145     $error = $record->ut_anything('column');
 146     $error = $record->ut_name('column');
 147
 148     $quoted_value = _quote($value,'table','field');
 149
 150     #deprecated
 151     $fields = hfields('table');
 152     if ( $fields->{Field} ) { # etc.
 153
 154     @fields = fields 'table'; #as a subroutine
 155     @fields = $record->fields; #as a method call
 156
 157
 158 =head1 DESCRIPTION
 159
 160 (Mostly) object-oriented interface to database records.  Records are currently
 161 implemented on top of DBI.  FS::Record is intended as a base class for
 162 table-specific classes to inherit from, i.e. FS::cust_main.
 163
 164 =head1 CONSTRUCTORS
 165
 166 =over 4
 167
 168 =item new [ TABLE, ] HASHREF
 169
 170 Creates a new record.  It doesn't store it in the database, though.  See
 171 L<"insert"> for that.
 172
 173 Note that the object stores this hash reference, not a distinct copy of the
 174 hash it points to.  You can ask the object for a copy with the I<hash>
 175 method.
 176
 177 TABLE can only be omitted when a dervived class overrides the table method.
 178
 179 =cut
 180
 181 sub new {
 182   my $proto = shift;
 183   my $class = ref($proto) || $proto;
 184   my $self = {};
 185   bless ($self, $class);
 186
 187   unless ( defined ( $self->table ) ) {
 188     $self->{'Table'} = shift;
 189     carp "warning: FS::Record::new called with table name ". $self->{'Table'}
 190       unless $nowarn_classload;
 191   }
 192
 193   $self->{'Hash'} = shift;
 194
 195   foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
 196     $self->{'Hash'}{$field}='';
 197   }
 198
 199   $self->_rebless if $self->can('_rebless');
 200
 201   $self->{'modified'} = 0;
 202
 203   $self->_simplecache($self->{'Hash'})  if $self->can('_simplecache');
 204   $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
 205
 206   $self;
 207 }
 208
 209 sub new_or_cached {
 210   my $proto = shift;
 211   my $class = ref($proto) || $proto;
 212   my $self = {};
 213   bless ($self, $class);
 214
 215   $self->{'Table'} = shift unless defined ( $self->table );
 216
 217   my $hashref = $self->{'Hash'} = shift;
 218   my $cache = shift;
 219   if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
 220     my $obj = $cache->cache->{$hashref->{$cache->key}};
 221     $obj->_cache($hashref, $cache) if $obj->can('_cache');
 222     $obj;
 223   } else {
 224     $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
 225   }
 226
 227 }
 228
 229 sub create {
 230   my $proto = shift;
 231   my $class = ref($proto) || $proto;
 232   my $self = {};
 233   bless ($self, $class);
 234   if ( defined $self->table ) {
 235     cluck "create constructor is deprecated, use new!";
 236     $self->new(@_);
 237   } else {
 238     croak "FS::Record::create called (not from a subclass)!";
 239   }
 240 }
 241
 242 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 243
 244 Searches the database for all records matching (at least) the key/value pairs
 245 in HASHREF.  Returns all the records found as `FS::TABLE' objects if that
 246 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
 247 objects.
 248
 249 The preferred usage is to pass a hash reference of named parameters:
 250
 251   @records = qsearch( {
 252                         'table'       => 'table_name',
 253                         'hashref'     => { 'field' => 'value'
 254                                            'field' => { 'op'    => '<',
 255                                                         'value' => '420',
 256                                                       },
 257                                          },
 258
 259                         #these are optional...
 260                         'select'      => '*',
 261                         'extra_sql'   => 'AND field = ? AND intfield = ?',
 262                         'extra_param' => [ 'value', [ 5, 'int' ] ],
 263                         'order_by'    => 'ORDER BY something',
 264                         #'cache_obj'   => '', #optional
 265                         'addl_from'   => 'LEFT JOIN othtable USING ( field )',
 266                         'debug'       => 1,
 267                       }
 268                     );
 269
 270 Much code still uses old-style positional parameters, this is also probably
 271 fine in the common case where there are only two parameters:
 272
 273   my @records = qsearch( 'table', { 'field' => 'value' } );
 274
 275 Also possible is an experimental LISTREF of PARAMS_HASHREFs for a UNION of
 276 the individual PARAMS_HASHREF queries
 277
 278 ###oops, argh, FS::Record::new only lets us create database fields.
 279 #Normal behaviour if SELECT is not specified is `*', as in
 280 #C<SELECT * FROM table WHERE ...>.  However, there is an experimental new
 281 #feature where you can specify SELECT - remember, the objects returned,
 282 #although blessed into the appropriate `FS::TABLE' package, will only have the
 283 #fields you specify.  This might have unwanted results if you then go calling
 284 #regular FS::TABLE methods
 285 #on it.
 286
 287 =cut
 288
 289 my %TYPE = (); #for debugging
 290
 291 sub _bind_type {
 292   my($type, $value) = @_;
 293
 294   my $bind_type = { TYPE => SQL_VARCHAR };
 295
 296   if ( $type =~ /(big)?(int|serial)/i && $value =~ /^-?\d+(\.\d+)?$/ ) {
 297
 298     $bind_type = { TYPE => SQL_INTEGER };
 299
 300   } elsif ( $type =~ /^bytea$/i || $type =~ /(blob|varbinary)/i ) {
 301
 302     if ( driver_name eq 'Pg' ) {
 303       no strict 'subs';
 304       $bind_type = { pg_type => PG_BYTEA };
 305     #} else {
 306     #  $bind_type = ? #SQL_VARCHAR could be fine?
 307     }
 308
 309   #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT
 310   #fixed by DBD::Pg 2.11.8
 311   #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded
 312   #(make a Tron test first)
 313   } elsif ( _is_fs_float( $type, $value ) ) {
 314
 315     $bind_type = { TYPE => SQL_DECIMAL };
 316
 317   }
 318
 319   $bind_type;
 320
 321 }
 322
 323 sub _is_fs_float {
 324   my($type, $value) = @_;
 325   if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) ||
 326        ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/)
 327      ) {
 328     return 1;
 329   }
 330   '';
 331 }
 332
 333 sub qsearch {
 334   my( @stable, @record, @cache );
 335   my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
 336   my @debug = ();
 337   my %union_options = ();
 338   if ( ref($_[0]) eq 'ARRAY' ) {
 339     my $optlist = shift;
 340     %union_options = @_;
 341     foreach my $href ( @$optlist ) {
 342       push @stable,      ( $href->{'table'} or die "table name is required" );
 343       push @record,      ( $href->{'hashref'}     || {} );
 344       push @select,      ( $href->{'select'}      || '*' );
 345       push @extra_sql,   ( $href->{'extra_sql'}   || '' );
 346       push @extra_param, ( $href->{'extra_param'} || [] );
 347       push @order_by,    ( $href->{'order_by'}    || '' );
 348       push @cache,       ( $href->{'cache_obj'}   || '' );
 349       push @addl_from,   ( $href->{'addl_from'}   || '' );
 350       push @debug,       ( $href->{'debug'}       || '' );
 351     }
 352     die "at least one hashref is required" unless scalar(@stable);
 353   } elsif ( ref($_[0]) eq 'HASH' ) {
 354     my $opt = shift;
 355     $stable[0]      = $opt->{'table'}       or die "table name is required";
 356     $record[0]      = $opt->{'hashref'}     || {};
 357     $select[0]      = $opt->{'select'}      || '*';
 358     $extra_sql[0]   = $opt->{'extra_sql'}   || '';
 359     $extra_param[0] = $opt->{'extra_param'} || [];
 360     $order_by[0]    = $opt->{'order_by'}    || '';
 361     $cache[0]       = $opt->{'cache_obj'}   || '';
 362     $addl_from[0]   = $opt->{'addl_from'}   || '';
 363     $debug[0]       = $opt->{'debug'}       || '';
 364   } else {
 365     ( $stable[0],
 366       $record[0],
 367       $select[0],
 368       $extra_sql[0],
 369       $cache[0],
 370       $addl_from[0]
 371     ) = @_;
 372     $select[0] ||= '*';
 373   }
 374   my $cache = $cache[0];
 375
 376   my @statement = ();
 377   my @value = ();
 378   my @bind_type = ();
 379   my $dbh = dbh;
 380   foreach my $stable ( @stable ) {
 381
 382     carp '->qsearch on cust_main called' if $stable eq 'cust_main' && $DEBUG;
 383
 384     #stop altering the caller's hashref
 385     my $record      = { %{ shift(@record) || {} } };#and be liberal in receipt
 386     my $select      = shift @select;
 387     my $extra_sql   = shift @extra_sql;
 388     my $extra_param = shift @extra_param;
 389     my $order_by    = shift @order_by;
 390     my $cache       = shift @cache;
 391     my $addl_from   = shift @addl_from;
 392     my $debug       = shift @debug;
 393
 394     #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
 395     #for jsearch
 396     $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
 397     $stable = $1;
 398
 399     my $table = $cache ? $cache->table : $stable;
 400     my $dbdef_table = dbdef->table($table)
 401       or die "No schema for table $table found - ".
 402              "do you need to run freeside-upgrade?";
 403     my $pkey = $dbdef_table->primary_key;
 404
 405     my @real_fields = grep exists($record->{$_}), real_fields($table);
 406
 407     my $statement .= "SELECT $select FROM $stable";
 408     my $alias_main;
 409     if ( $addl_from ) {
 410       $statement .= " $addl_from";
 411       # detect aliasing of the main table
 412       if ( $addl_from =~ /^\s*AS\s+(\w+)/i ) {
 413         $alias_main = $1;
 414       }
 415     }
 416     if ( @real_fields ) {
 417       $statement .= ' WHERE '. join(' AND ',
 418         get_real_fields($table, $record, \@real_fields, $alias_main));
 419     }
 420
 421     $statement .= " $extra_sql" if defined($extra_sql);
 422     $statement .= " $order_by"  if defined($order_by);
 423
 424     push @statement, $statement;
 425
 426     warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
 427
 428     foreach my $field (
 429       grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
 430     ) {
 431
 432       my $value = $record->{$field};
 433       my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
 434       $value = $value->{'value'} if ref($value);
 435       my $type = dbdef->table($table)->column($field)->type;
 436
 437       my $bind_type = _bind_type($type, $value);
 438
 439       #if ( $DEBUG > 2 ) {
 440       #  no strict 'refs';
 441       #  %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
 442       #    unless keys %TYPE;
 443       #  warn "  bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
 444       #}
 445
 446       push @value, $value;
 447       push @bind_type, $bind_type;
 448
 449     }
 450
 451     foreach my $param ( @$extra_param ) {
 452       my $bind_type = { TYPE => SQL_VARCHAR };
 453       my $value = $param;
 454       if ( ref($param) ) {
 455         $value = $param->[0];
 456         my $type = $param->[1];
 457         $bind_type = _bind_type($type, $value);
 458       }
 459       push @value, $value;
 460       push @bind_type, $bind_type;
 461     }
 462   }
 463
 464   my $statement = join( ' ) UNION ( ', @statement );
 465   $statement = "( $statement )" if scalar(@statement) > 1;
 466   $statement .= " $union_options{order_by}" if $union_options{order_by};
 467
 468   my $sth = $dbh->prepare($statement)
 469     or croak "$dbh->errstr doing $statement";
 470
 471   my $bind = 1;
 472   foreach my $value ( @value ) {
 473     my $bind_type = shift @bind_type;
 474     $sth->bind_param($bind++, $value, $bind_type );
 475   }
 476
 477 #  $sth->execute( map $record->{$_},
 478 #    grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
 479 #  ) or croak "Error executing \"$statement\": ". $sth->errstr;
 480
 481   my $ok = $sth->execute;
 482   if (!$ok) {
 483     my $error = "Error executing \"$statement\"";
 484     $error .= ' (' . join(', ', map {"'$_'"} @value) . ')' if @value;
 485     $error .= ': '. $sth->errstr;
 486     croak $error;
 487   }
 488
 489   my $table = $stable[0];
 490   my $pkey = '';
 491   $table = '' if grep { $_ ne $table } @stable;
 492   $pkey = dbdef->table($table)->primary_key if $table;
 493
 494   my %result;
 495   tie %result, "Tie::IxHash";
 496   my @stuff = @{ $sth->fetchall_arrayref( {} ) };
 497   if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
 498     %result = map { $_->{$pkey}, $_ } @stuff;
 499   } else {
 500     @result{@stuff} = @stuff;
 501   }
 502
 503   $sth->finish;
 504
 505   #below was refactored out to _from_hashref, this should use it at some point
 506
 507   my @return;
 508   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
 509     if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
 510       #derivied class didn't override new method, so this optimization is safe
 511       if ( $cache ) {
 512         @return = map {
 513           new_or_cached( "FS::$table", { %{$_} }, $cache )
 514         } values(%result);
 515       } else {
 516         @return = map {
 517           new( "FS::$table", { %{$_} } )
 518         } values(%result);
 519       }
 520     } else {
 521       #okay, its been tested
 522       # warn "untested code (class FS::$table uses custom new method)";
 523       @return = map {
 524         eval 'FS::'. $table. '->new( { %{$_} } )';
 525       } values(%result);
 526     }
 527
 528     # Check for encrypted fields and decrypt them.
 529    ## only in the local copy, not the cached object
 530     no warnings 'deprecated'; # XXX silence the warning for now
 531     if ( $conf_encryption
 532          && eval '@FS::'. $table . '::encrypted_fields' ) {
 533       foreach my $record (@return) {
 534         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 535           next if $field eq 'payinfo'
 536                     && ($record->isa('FS::payinfo_transaction_Mixin')
 537                         || $record->isa('FS::payinfo_Mixin') )
 538                     && $record->payby
 539                     && !grep { $record->payby eq $_ } @encrypt_payby;
 540           # Set it directly... This may cause a problem in the future...
 541           $record->setfield($field, $record->decrypt($record->getfield($field)));
 542         }
 543       }
 544     }
 545   } else {
 546     cluck "warning: FS::$table not loaded; returning FS::Record objects"
 547       unless $nowarn_classload;
 548     @return = map {
 549       FS::Record->new( $table, { %{$_} } );
 550     } values(%result);
 551   }
 552   return @return;
 553 }
 554
 555 =item _query
 556
 557 Construct the SQL statement and parameter-binding list for qsearch.  Takes
 558 the qsearch parameters.
 559
 560 Returns a hash containing:
 561 'table':      The primary table name (if there is one).
 562 'statement':  The SQL statement itself.
 563 'bind_type':  An arrayref of bind types.
 564 'value':      An arrayref of parameter values.
 565 'cache':      The cache object, if one was passed.
 566
 567 =cut
 568
 569 sub _query {
 570   my( @stable, @record, @cache );
 571   my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
 572   my @debug = ();
 573   my $cursor = '';
 574   my %union_options = ();
 575   if ( ref($_[0]) eq 'ARRAY' ) {
 576     my $optlist = shift;
 577     %union_options = @_;
 578     foreach my $href ( @$optlist ) {
 579       push @stable,      ( $href->{'table'} or die "table name is required" );
 580       push @record,      ( $href->{'hashref'}     || {} );
 581       push @select,      ( $href->{'select'}      || '*' );
 582       push @extra_sql,   ( $href->{'extra_sql'}   || '' );
 583       push @extra_param, ( $href->{'extra_param'} || [] );
 584       push @order_by,    ( $href->{'order_by'}    || '' );
 585       push @cache,       ( $href->{'cache_obj'}   || '' );
 586       push @addl_from,   ( $href->{'addl_from'}   || '' );
 587       push @debug,       ( $href->{'debug'}       || '' );
 588     }
 589     die "at least one hashref is required" unless scalar(@stable);
 590   } elsif ( ref($_[0]) eq 'HASH' ) {
 591     my $opt = shift;
 592     $stable[0]      = $opt->{'table'}       or die "table name is required";
 593     $record[0]      = $opt->{'hashref'}     || {};
 594     $select[0]      = $opt->{'select'}      || '*';
 595     $extra_sql[0]   = $opt->{'extra_sql'}   || '';
 596     $extra_param[0] = $opt->{'extra_param'} || [];
 597     $order_by[0]    = $opt->{'order_by'}    || '';
 598     $cache[0]       = $opt->{'cache_obj'}   || '';
 599     $addl_from[0]   = $opt->{'addl_from'}   || '';
 600     $debug[0]       = $opt->{'debug'}       || '';
 601   } else {
 602     ( $stable[0],
 603       $record[0],
 604       $select[0],
 605       $extra_sql[0],
 606       $cache[0],
 607       $addl_from[0]
 608     ) = @_;
 609     $select[0] ||= '*';
 610   }
 611   my $cache = $cache[0];
 612
 613   my @statement = ();
 614   my @value = ();
 615   my @bind_type = ();
 616
 617   my $result_table = $stable[0];
 618   foreach my $stable ( @stable ) {
 619     #stop altering the caller's hashref
 620     my $record      = { %{ shift(@record) || {} } };#and be liberal in receipt
 621     my $select      = shift @select;
 622     my $extra_sql   = shift @extra_sql;
 623     my $extra_param = shift @extra_param;
 624     my $order_by    = shift @order_by;
 625     my $cache       = shift @cache;
 626     my $addl_from   = shift @addl_from;
 627     my $debug       = shift @debug;
 628
 629     #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
 630     #for jsearch
 631     $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
 632     $stable = $1;
 633
 634     $result_table = '' if $result_table ne $stable;
 635
 636     my $table = $cache ? $cache->table : $stable;
 637     my $dbdef_table = dbdef->table($table)
 638       or die "No schema for table $table found - ".
 639              "do you need to run freeside-upgrade?";
 640     my $pkey = $dbdef_table->primary_key;
 641
 642     my @real_fields = grep exists($record->{$_}), real_fields($table);
 643
 644     my $statement .= "SELECT $select FROM $stable";
 645     $statement .= " $addl_from" if $addl_from;
 646     if ( @real_fields ) {
 647       $statement .= ' WHERE '. join(' AND ',
 648         get_real_fields($table, $record, \@real_fields));
 649     }
 650
 651     $statement .= " $extra_sql" if defined($extra_sql);
 652     $statement .= " $order_by"  if defined($order_by);
 653
 654     push @statement, $statement;
 655
 656     warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
 657
 658
 659     foreach my $field (
 660       grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
 661     ) {
 662
 663       my $value = $record->{$field};
 664       my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
 665       $value = $value->{'value'} if ref($value);
 666       my $type = dbdef->table($table)->column($field)->type;
 667
 668       my $bind_type = _bind_type($type, $value);
 669
 670       #if ( $DEBUG > 2 ) {
 671       #  no strict 'refs';
 672       #  %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
 673       #    unless keys %TYPE;
 674       #  warn "  bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
 675       #}
 676
 677       push @value, $value;
 678       push @bind_type, $bind_type;
 679
 680     }
 681
 682     foreach my $param ( @$extra_param ) {
 683       my $bind_type = { TYPE => SQL_VARCHAR };
 684       my $value = $param;
 685       if ( ref($param) ) {
 686         $value = $param->[0];
 687         my $type = $param->[1];
 688         $bind_type = _bind_type($type, $value);
 689       }
 690       push @value, $value;
 691       push @bind_type, $bind_type;
 692     }
 693   }
 694
 695   my $statement = join( ' ) UNION ( ', @statement );
 696   $statement = "( $statement )" if scalar(@statement) > 1;
 697   $statement .= " $union_options{order_by}" if $union_options{order_by};
 698
 699   return {
 700     statement => $statement,
 701     bind_type => \@bind_type,
 702     value     => \@value,
 703     table     => $result_table,
 704     cache     => $cache,
 705   };
 706 }
 707
 708 # qsearch should eventually use this
 709 sub _from_hashref {
 710   my ($table, $cache, @hashrefs) = @_;
 711   my @return;
 712   # XXX get rid of these string evals at some point
 713   # (when we have time to test it)
 714   # my $class = "FS::$table" if $table;
 715   # if ( $class and $class->isa('FS::Record') )
 716   #   if ( $class->can('new') eq \&new )
 717   #
 718   if ( $table && eval 'scalar(@FS::'. $table. '::ISA);' ) {
 719     if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
 720       #derivied class didn't override new method, so this optimization is safe
 721       if ( $cache ) {
 722         @return = map {
 723           new_or_cached( "FS::$table", { %{$_} }, $cache )
 724         } @hashrefs;
 725       } else {
 726         @return = map {
 727           new( "FS::$table", { %{$_} } )
 728         } @hashrefs;
 729       }
 730     } else {
 731       #okay, its been tested
 732       # warn "untested code (class FS::$table uses custom new method)";
 733       @return = map {
 734         eval 'FS::'. $table. '->new( { %{$_} } )';
 735       } @hashrefs;
 736     }
 737
 738     # Check for encrypted fields and decrypt them.
 739    ## only in the local copy, not the cached object
 740     if ( $conf_encryption
 741          && eval '@FS::'. $table . '::encrypted_fields' ) {
 742       foreach my $record (@return) {
 743         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 744           next if $field eq 'payinfo'
 745                     && ($record->isa('FS::payinfo_transaction_Mixin')
 746                         || $record->isa('FS::payinfo_Mixin') )
 747                     && $record->payby
 748                     && !grep { $record->payby eq $_ } @encrypt_payby;
 749           # Set it directly... This may cause a problem in the future...
 750           $record->setfield($field, $record->decrypt($record->getfield($field)));
 751         }
 752       }
 753     }
 754   } else {
 755     cluck "warning: FS::$table not loaded; returning FS::Record objects"
 756       unless $nowarn_classload;
 757     @return = map {
 758       FS::Record->new( $table, { %{$_} } );
 759     } @hashrefs;
 760   }
 761   return @return;
 762 }
 763
 764 sub get_real_fields {
 765   my $table = shift;
 766   my $record = shift;
 767   my $real_fields = shift;
 768   my $alias_main = shift; # defaults to undef
 769   $alias_main ||= $table;
 770
 771   ## could be optimized more for readability
 772   return (
 773     map {
 774
 775       my $op = '=';
 776       my $column = $_;
 777       my $table_column = $qsearch_qualify_columns ? "$alias_main.$column" : $column;
 778       my $type = dbdef->table($table)->column($column)->type;
 779       my $value = $record->{$column};
 780       $value = $value->{'value'} if ref($value);
 781
 782       if ( ref($record->{$column}) ) {
 783         $op = $record->{$column}{'op'} if $record->{$column}{'op'};
 784         #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
 785         if ( uc($op) eq 'ILIKE' ) {
 786           $op = 'LIKE';
 787           $record->{$column}{'value'} = lc($record->{$column}{'value'});
 788           $table_column = "LOWER($table_column)";
 789         }
 790         $record->{$column} = $record->{$column}{'value'}
 791       }
 792
 793       if ( ! defined( $record->{$column} ) || $record->{$column} eq '' ) {
 794         if ( $op eq '=' ) {
 795           if ( driver_name eq 'Pg' ) {
 796             if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
 797               qq-( $table_column IS NULL )-;
 798             } else {
 799               qq-( $table_column IS NULL OR $table_column = '' )-;
 800             }
 801           } else {
 802             qq-( $table_column IS NULL OR $table_column = "" )-;
 803           }
 804         } elsif ( $op eq '!=' ) {
 805           if ( driver_name eq 'Pg' ) {
 806             if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
 807               qq-( $table_column IS NOT NULL )-;
 808             } else {
 809               qq-( $table_column IS NOT NULL AND $table_column != '' )-;
 810             }
 811           } else {
 812             qq-( $table_column IS NOT NULL AND $table_column != "" )-;
 813           }
 814         } else {
 815           if ( driver_name eq 'Pg' ) {
 816             qq-( $table_column $op '' )-;
 817           } else {
 818             qq-( $table_column $op "" )-;
 819           }
 820         }
 821       } elsif ( $op eq '!=' ) {
 822         qq-( $table_column IS NULL OR $table_column != ? )-;
 823       #if this needs to be re-enabled, it needs to use a custom op like
 824       #"APPROX=" or something (better name?, not '=', to avoid affecting other
 825       # searches
 826       #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
 827       #  ( "$table_column <= ?", "$table_column >= ?" );
 828       } else {
 829         "$table_column $op ?";
 830       }
 831
 832     } @{ $real_fields }
 833   );
 834 }
 835
 836 =item by_key PRIMARY_KEY_VALUE
 837
 838 This is a class method that returns the record with the given primary key
 839 value.  This method is only useful in FS::Record subclasses.  For example:
 840
 841   my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
 842
 843 is equivalent to:
 844
 845   my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
 846
 847 =cut
 848
 849 sub by_key {
 850   my ($class, $pkey_value) = @_;
 851
 852   my $table = $class->table
 853     or croak "No table for $class found";
 854
 855   my $dbdef_table = dbdef->table($table)
 856     or die "No schema for table $table found - ".
 857            "do you need to create it or run dbdef-create?";
 858   my $pkey = $dbdef_table->primary_key
 859     or die "No primary key for table $table";
 860
 861   return qsearchs($table, { $pkey => $pkey_value });
 862 }
 863
 864 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
 865
 866 Experimental JOINed search method.  Using this method, you can execute a
 867 single SELECT spanning multiple tables, and cache the results for subsequent
 868 method calls.  Interface will almost definately change in an incompatible
 869 fashion.
 870
 871 Arguments:
 872
 873 =cut
 874
 875 sub jsearch {
 876   my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
 877   my $cache = FS::SearchCache->new( $ptable, $pkey );
 878   my %saw;
 879   ( $cache,
 880     grep { !$saw{$_->getfield($pkey)}++ }
 881       qsearch($table, $record, $select, $extra_sql, $cache )
 882   );
 883 }
 884
 885 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 886
 887 Same as qsearch, except that if more than one record matches, it B<carp>s but
 888 returns the first.  If this happens, you either made a logic error in asking
 889 for a single item, or your data is corrupted.
 890
 891 =cut
 892
 893 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
 894   my $table = $_[0];
 895   my(@result) = qsearch(@_);
 896   cluck "warning: Multiple records in scalar search ($table)"
 897         #.join(' / ', map "$_=>".$_[1]->{$_}, keys %{ $_[1] } )
 898     if scalar(@result) > 1;
 899   #should warn more vehemently if the search was on a primary key?
 900   scalar(@result) ? ($result[0]) : ();
 901 }
 902
 903 =back
 904
 905 =head1 METHODS
 906
 907 =over 4
 908
 909 =item table
 910
 911 Returns the table name.
 912
 913 =cut
 914
 915 sub table {
 916 #  cluck "warning: FS::Record::table deprecated; supply one in subclass!";
 917   my $self = shift;
 918   $self -> {'Table'};
 919 }
 920
 921 =item dbdef_table
 922
 923 Returns the DBIx::DBSchema::Table object for the table.
 924
 925 =cut
 926
 927 sub dbdef_table {
 928   my($self)=@_;
 929   my($table)=$self->table;
 930   dbdef->table($table);
 931 }
 932
 933 =item primary_key
 934
 935 Returns the primary key for the table.
 936
 937 =cut
 938
 939 sub primary_key {
 940   my $self = shift;
 941   my $pkey = $self->dbdef_table->primary_key;
 942 }
 943
 944 =item get, getfield COLUMN
 945
 946 Returns the value of the column/field/key COLUMN.
 947
 948 =cut
 949
 950 sub get {
 951   my($self,$field) = @_;
 952   # to avoid "Use of unitialized value" errors
 953   if ( defined ( $self->{Hash}->{$field} ) ) {
 954     $self->{Hash}->{$field};
 955   } else {
 956     '';
 957   }
 958 }
 959 sub getfield {
 960   my $self = shift;
 961   $self->get(@_);
 962 }
 963
 964 =item set, setfield COLUMN, VALUE
 965
 966 Sets the value of the column/field/key COLUMN to VALUE.  Returns VALUE.
 967
 968 =cut
 969
 970 sub set {
 971   my($self,$field,$value) = @_;
 972   $self->{'modified'} = 1;
 973   $self->{'Hash'}->{$field} = $value;
 974 }
 975 sub setfield {
 976   my $self = shift;
 977   $self->set(@_);
 978 }
 979
 980 =item exists COLUMN
 981
 982 Returns true if the column/field/key COLUMN exists.
 983
 984 =cut
 985
 986 sub exists {
 987   my($self,$field) = @_;
 988   exists($self->{Hash}->{$field});
 989 }
 990
 991 =item AUTOLOADED METHODS
 992
 993 $record->column is a synonym for $record->get('column');
 994
 995 $record->column('value') is a synonym for $record->set('column','value');
 996
 997 $record->foreign_table_name calls qsearchs and returns a single
 998 FS::foreign_table record (for tables referenced by a column of this table) or
 999 qsearch and returns an array of FS::foreign_table records (for tables
1000 referenced by a column in the foreign table).
1001
1002 =cut
1003
1004 # readable/safe
1005 sub AUTOLOAD {
1006   my($self,$value)=@_;
1007   my($field)=$AUTOLOAD;
1008   $field =~ s/.*://;
1009
1010   confess "errant AUTOLOAD $field for $self (arg $value)"
1011     unless blessed($self) && $self->can('setfield');
1012
1013   if ( my $fk_info = get_fk_method($self->table, $field) ) {
1014
1015     my $method = $fk_info->{method} || 'qsearchs';
1016     my $table = $fk_info->{table} || $field;
1017     my $column = $fk_info->{column};
1018     my $foreign_column = $fk_info->{references} || $column;
1019
1020     eval "use FS::$table";
1021     die $@ if $@;
1022
1023     carp '->cust_main called' if $table eq 'cust_main' && $DEBUG;
1024
1025     my $pkey_value = $self->$column();
1026     my %search = ( $foreign_column => $pkey_value );
1027
1028     # FS::Record->$method() ?  they're actually just subs :/
1029     if ( $method eq 'qsearchs' ) {
1030       return $pkey_value ? qsearchs( $table, \%search ) : '';
1031     } elsif ( $method eq 'qsearch' ) {
1032       return $pkey_value ? qsearch(  $table, \%search ) : ();
1033     } else {
1034       die "unknown method $method";
1035     }
1036
1037   }
1038
1039   if ( defined($value) ) {
1040     $self->setfield($field,$value);
1041   } else {
1042     $self->getfield($field);
1043   }
1044 }
1045
1046 # efficient (also, old, doesn't support FK stuff)
1047 #sub AUTOLOAD {
1048 #  my $field = $AUTOLOAD;
1049 #  $field =~ s/.*://;
1050 #  if ( defined($_[1]) ) {
1051 #    $_[0]->setfield($field, $_[1]);
1052 #  } else {
1053 #    $_[0]->getfield($field);
1054 #  }
1055 #}
1056
1057 # get_fk_method(TABLE, FIELD)
1058 # Internal subroutine for fetching the foreign key descriptor for TABLE.FIELD
1059 # if there is one. If not, returns undef.
1060 # This will initialize fk_method_cache if it hasn't happened yet. It is the
1061 # _only_ allowed way to access the contents of %fk_method_cache.
1062
1063 # if we wanted to be even more efficient we'd create the fk methods in the
1064 # symbol table instead of relying on AUTOLOAD every time
1065
1066 sub get_fk_method {
1067   my ($table, $field) = @_;
1068
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( $last, $min_sec ) = ( time, 5 ); #progressbar foo
2156   while (1) {
2157
2158     my @columns = ();
2159     my %hash = %$params;
2160     if ( $type eq 'csv' ) {
2161
2162       last unless scalar(@buffer);
2163       $line = shift(@buffer);
2164
2165       next if $line =~ /^\s*$/; #skip empty lines
2166
2167       $line = &{$row_callback}($line) if $row_callback;
2168
2169       next if $line =~ /^\s*$/; #skip empty lines
2170
2171       $parser->parse($line) or do {
2172         $dbh->rollback if $oldAutoCommit;
2173         return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
2174       };
2175       @columns = $parser->fields();
2176
2177     } elsif ( $type eq 'fixedlength' ) {
2178
2179       last unless scalar(@buffer);
2180       $line = shift(@buffer);
2181
2182       @columns = $parser->parse($line);
2183
2184     } elsif ( $type eq 'xls' ) {
2185
2186       last if $row > ($parser->{MaxRow} || $parser->{MinRow})
2187            || ! $parser->{Cells}[$row];
2188
2189       my @row = @{ $parser->{Cells}[$row] };
2190       @columns = map $_->{Val}, @row;
2191
2192       #my $z = 'A';
2193       #warn $z++. ": $_\n" for @columns;
2194
2195     } elsif ( $type eq 'xml' ) {
2196
2197       # $parser = [ 'Column0Key', 'Column1Key' ... ]
2198       last unless scalar(@buffer);
2199       my $row = shift @buffer;
2200       @columns = @{ $row }{ @$parser };
2201
2202     } elsif ( $type eq 'asn.1' ) {
2203
2204       last unless scalar(@buffer);
2205       my $row = shift @buffer;
2206       &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2207         if $asn_format->{row_callback};
2208       foreach my $key ( keys %{ $asn_format->{map} } ) {
2209         $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2210       }
2211
2212     } else {
2213       die "Unknown file type $type\n";
2214     }
2215
2216     my @later = ();
2217
2218     foreach my $field ( @fields ) {
2219
2220       my $value = shift @columns;
2221
2222       if ( ref($field) eq 'CODE' ) {
2223         #&{$field}(\%hash, $value);
2224         push @later, $field, $value;
2225       } else {
2226         #??? $hash{$field} = $value if length($value);
2227         $hash{$field} = $value if defined($value) && length($value);
2228       }
2229
2230     }
2231
2232     if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
2233                          && length($1) == $custnum_length ) {
2234       $hash{custnum} = $2;
2235     }
2236
2237     %hash = &{$hash_callback}(%hash) if $hash_callback;
2238
2239     #my $table   = $param->{table};
2240     my $class = "FS::$table";
2241
2242     my $record = $class->new( \%hash );
2243
2244     my $param = {};
2245     while ( scalar(@later) ) {
2246       my $sub = shift @later;
2247       my $data = shift @later;
2248       eval {
2249         &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2250       };
2251       if ( $@ ) {
2252         $dbh->rollback if $oldAutoCommit;
2253         return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2254       }
2255       last if exists( $param->{skiprow} );
2256     }
2257     next if exists( $param->{skiprow} );
2258
2259     if ( $preinsert_callback ) {
2260       my $error = &{$preinsert_callback}($record, $param);
2261       if ( $error ) {
2262         $dbh->rollback if $oldAutoCommit;
2263         return "preinsert_callback error". ( $line ? " for $line" : '' ).
2264                ": $error";
2265       }
2266       next if exists $param->{skiprow} && $param->{skiprow};
2267     }
2268
2269     my @insert_args = ();
2270     if ( $insert_args_callback ) {
2271       @insert_args = &{$insert_args_callback}($record, $param);
2272     }
2273
2274     my $error = $record->insert(@insert_args);
2275
2276     if ( $error ) {
2277       $dbh->rollback if $oldAutoCommit;
2278       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2279     }
2280
2281     $row++;
2282     $imported++;
2283
2284     if ( $postinsert_callback ) {
2285       my $error = &{$postinsert_callback}($record, $param);
2286       if ( $error ) {
2287         $dbh->rollback if $oldAutoCommit;
2288         return "postinsert_callback error". ( $line ? " for $line" : '' ).
2289                ": $error";
2290       }
2291     }
2292
2293     if ( $job && time - $min_sec > $last ) { #progress bar
2294       $job->update_statustext( int(100 * $imported / $count) );
2295       $last = time;
2296     }
2297
2298   }
2299
2300   unless ( $imported || $param->{empty_ok} ) {
2301     $dbh->rollback if $oldAutoCommit;
2302     return "Empty file!";
2303   }
2304
2305   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2306
2307   ''; #no error
2308
2309 }
2310
2311 sub _h_statement {
2312   my( $self, $action, $time ) = @_;
2313
2314   $time ||= time;
2315
2316   my %nohistory = map { $_=>1 } $self->nohistory_fields;
2317
2318   my @fields =
2319     grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2320     real_fields($self->table);
2321   ;
2322
2323   # If we're encrypting then don't store the payinfo in the history
2324   if ( $conf_encryption && $self->table ne 'banned_pay' ) {
2325     @fields = grep { $_ ne 'payinfo' } @fields;
2326   }
2327
2328   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2329
2330   "INSERT INTO h_". $self->table. " ( ".
2331       join(', ', qw(history_date history_usernum history_action), @fields ).
2332     ") VALUES (".
2333       join(', ', $time,
2334                  $FS::CurrentUser::CurrentUser->usernum,
2335                  dbh->quote($action),
2336                  @values
2337       ).
2338     ")"
2339   ;
2340 }
2341
2342 =item unique COLUMN
2343
2344 B<Warning>: External use is B<deprecated>.
2345
2346 Replaces COLUMN in record with a unique number, using counters in the
2347 filesystem.  Used by the B<insert> method on single-field unique columns
2348 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2349 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2350
2351 Returns the new value.
2352
2353 =cut
2354
2355 sub unique {
2356   my($self,$field) = @_;
2357   my($table)=$self->table;
2358
2359   croak "Unique called on field $field, but it is ",
2360         $self->getfield($field),
2361         ", not null!"
2362     if $self->getfield($field);
2363
2364   #warn "table $table is tainted" if is_tainted($table);
2365   #warn "field $field is tainted" if is_tainted($field);
2366
2367   my($counter) = new File::CounterFile "$table.$field",0;
2368
2369   my $index = $counter->inc;
2370   $index = $counter->inc while qsearchs($table, { $field=>$index } );
2371
2372   $index =~ /^(\d*)$/;
2373   $index=$1;
2374
2375   $self->setfield($field,$index);
2376
2377 }
2378
2379 =item ut_float COLUMN
2380
2381 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
2382 null.  If there is an error, returns the error, otherwise returns false.
2383
2384 =cut
2385
2386 sub ut_float {
2387   my($self,$field)=@_ ;
2388   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2389    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2390    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2391    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2392     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2393   $self->setfield($field,$1);
2394   '';
2395 }
2396 =item ut_floatn COLUMN
2397
2398 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2399 null.  If there is an error, returns the error, otherwise returns false.
2400
2401 =cut
2402
2403 #false laziness w/ut_ipn
2404 sub ut_floatn {
2405   my( $self, $field ) = @_;
2406   if ( $self->getfield($field) =~ /^()$/ ) {
2407     $self->setfield($field,'');
2408     '';
2409   } else {
2410     $self->ut_float($field);
2411   }
2412 }
2413
2414 =item ut_sfloat COLUMN
2415
2416 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2417 May not be null.  If there is an error, returns the error, otherwise returns
2418 false.
2419
2420 =cut
2421
2422 sub ut_sfloat {
2423   my($self,$field)=@_ ;
2424   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2425    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2426    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2427    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2428     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2429   $self->setfield($field,$1);
2430   '';
2431 }
2432 =item ut_sfloatn COLUMN
2433
2434 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2435 null.  If there is an error, returns the error, otherwise returns false.
2436
2437 =cut
2438
2439 sub ut_sfloatn {
2440   my( $self, $field ) = @_;
2441   if ( $self->getfield($field) =~ /^()$/ ) {
2442     $self->setfield($field,'');
2443     '';
2444   } else {
2445     $self->ut_sfloat($field);
2446   }
2447 }
2448
2449 =item ut_snumber COLUMN
2450
2451 Check/untaint signed numeric data (whole numbers).  If there is an error,
2452 returns the error, otherwise returns false.
2453
2454 =cut
2455
2456 sub ut_snumber {
2457   my($self, $field) = @_;
2458   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2459     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2460   $self->setfield($field, "$1$2");
2461   '';
2462 }
2463
2464 =item ut_snumbern COLUMN
2465
2466 Check/untaint signed numeric data (whole numbers).  If there is an error,
2467 returns the error, otherwise returns false.
2468
2469 =cut
2470
2471 sub ut_snumbern {
2472   my($self, $field) = @_;
2473   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2474     or return "Illegal (numeric) $field: ". $self->getfield($field);
2475   if ($1) {
2476     return "Illegal (numeric) $field: ". $self->getfield($field)
2477       unless $2;
2478   }
2479   $self->setfield($field, "$1$2");
2480   '';
2481 }
2482
2483 =item ut_number COLUMN
2484
2485 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
2486 is an error, returns the error, otherwise returns false.
2487
2488 =cut
2489
2490 sub ut_number {
2491   my($self,$field)=@_;
2492   $self->getfield($field) =~ /^\s*(\d+)\s*$/
2493     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2494   $self->setfield($field,$1);
2495   '';
2496 }
2497
2498 =item ut_numbern COLUMN
2499
2500 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
2501 an error, returns the error, otherwise returns false.
2502
2503 =cut
2504
2505 sub ut_numbern {
2506   my($self,$field)=@_;
2507   $self->getfield($field) =~ /^\s*(\d*)\s*$/
2508     or return "Illegal (numeric) $field: ". $self->getfield($field);
2509   $self->setfield($field,$1);
2510   '';
2511 }
2512
2513 =item ut_decimal COLUMN[, DIGITS]
2514
2515 Check/untaint decimal numbers (up to DIGITS decimal places.  If there is an
2516 error, returns the error, otherwise returns false.
2517
2518 =item ut_decimaln COLUMN[, DIGITS]
2519
2520 Check/untaint decimal numbers.  May be null.  If there is an error, returns
2521 the error, otherwise returns false.
2522
2523 =cut
2524
2525 sub ut_decimal {
2526   my($self, $field, $digits) = @_;
2527   $digits ||= '';
2528   $self->getfield($field) =~ /^\s*(\d+(\.\d{0,$digits})?)\s*$/
2529     or return "Illegal or empty (decimal) $field: ".$self->getfield($field);
2530   $self->setfield($field, $1);
2531   '';
2532 }
2533
2534 sub ut_decimaln {
2535   my($self, $field, $digits) = @_;
2536   $self->getfield($field) =~ /^\s*(\d*(\.\d{0,$digits})?)\s*$/
2537     or return "Illegal (decimal) $field: ".$self->getfield($field);
2538   $self->setfield($field, $1);
2539   '';
2540 }
2541
2542 =item ut_money COLUMN
2543
2544 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
2545 is an error, returns the error, otherwise returns false.
2546
2547 =cut
2548
2549 sub ut_money {
2550   my($self,$field)=@_;
2551
2552   if ( $self->getfield($field) eq '' ) {
2553     $self->setfield($field, 0);
2554   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2555     #handle one decimal place without barfing out
2556     $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2557   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2558     $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2559   } else {
2560     return "Illegal (money) $field: ". $self->getfield($field);
2561   }
2562
2563   '';
2564 }
2565
2566 =item ut_moneyn COLUMN
2567
2568 Check/untaint monetary numbers.  May be negative.  If there
2569 is an error, returns the error, otherwise returns false.
2570
2571 =cut
2572
2573 sub ut_moneyn {
2574   my($self,$field)=@_;
2575   if ($self->getfield($field) eq '') {
2576     $self->setfield($field, '');
2577     return '';
2578   }
2579   $self->ut_money($field);
2580 }
2581
2582 =item ut_currencyn COLUMN
2583
2584 Check/untaint currency indicators, such as USD or EUR.  May be null.  If there
2585 is an error, returns the error, otherwise returns false.
2586
2587 =cut
2588
2589 sub ut_currencyn {
2590   my($self, $field) = @_;
2591   if ($self->getfield($field) eq '') { #can be null
2592     $self->setfield($field, '');
2593     return '';
2594   }
2595   $self->ut_currency($field);
2596 }
2597
2598 =item ut_currency COLUMN
2599
2600 Check/untaint currency indicators, such as USD or EUR.  May not be null.  If
2601 there is an error, returns the error, otherwise returns false.
2602
2603 =cut
2604
2605 sub ut_currency {
2606   my($self, $field) = @_;
2607   my $value = uc( $self->getfield($field) );
2608   if ( code2currency($value) ) {
2609     $self->setfield($value);
2610   } else {
2611     return "Unknown currency $value";
2612   }
2613
2614   '';
2615 }
2616
2617 =item ut_text COLUMN
2618
2619 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2620 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2621 May not be null.  If there is an error, returns the error, otherwise returns
2622 false.
2623
2624 =cut
2625
2626 sub ut_text {
2627   my($self,$field)=@_;
2628   #warn "msgcat ". \&msgcat. "\n";
2629   #warn "notexist ". \&notexist. "\n";
2630   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2631   # \p{Word} = alphanumerics, marks (diacritics), and connectors
2632   # see perldoc perluniprops
2633   $self->getfield($field)
2634     =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
2635       or return gettext('illegal_or_empty_text'). " $field: ".
2636                  $self->getfield($field);
2637   $self->setfield($field,$1);
2638   '';
2639 }
2640
2641 =item ut_textn COLUMN
2642
2643 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2644 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2645 May be null.  If there is an error, returns the error, otherwise returns false.
2646
2647 =cut
2648
2649 sub ut_textn {
2650   my($self,$field)=@_;
2651   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2652   $self->ut_text($field);
2653 }
2654
2655 =item ut_alpha COLUMN
2656
2657 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
2658 an error, returns the error, otherwise returns false.
2659
2660 =cut
2661
2662 sub ut_alpha {
2663   my($self,$field)=@_;
2664   $self->getfield($field) =~ /^(\w+)$/
2665     or return "Illegal or empty (alphanumeric) $field: ".
2666               $self->getfield($field);
2667   $self->setfield($field,$1);
2668   '';
2669 }
2670
2671 =item ut_alphan COLUMN
2672
2673 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
2674 error, returns the error, otherwise returns false.
2675
2676 =cut
2677
2678 sub ut_alphan {
2679   my($self,$field)=@_;
2680   $self->getfield($field) =~ /^(\w*)$/
2681     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2682   $self->setfield($field,$1);
2683   '';
2684 }
2685
2686 =item ut_alphasn COLUMN
2687
2688 Check/untaint alphanumeric strings, spaces allowed.  May be null.  If there is
2689 an error, returns the error, otherwise returns false.
2690
2691 =cut
2692
2693 sub ut_alphasn {
2694   my($self,$field)=@_;
2695   $self->getfield($field) =~ /^([\w ]*)$/
2696     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2697   $self->setfield($field,$1);
2698   '';
2699 }
2700
2701
2702 =item ut_alpha_lower COLUMN
2703
2704 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
2705 there is an error, returns the error, otherwise returns false.
2706
2707 =cut
2708
2709 sub ut_alpha_lower {
2710   my($self,$field)=@_;
2711   $self->getfield($field) =~ /[[:upper:]]/
2712     and return "Uppercase characters are not permitted in $field";
2713   $self->ut_alpha($field);
2714 }
2715
2716 =item ut_phonen COLUMN [ COUNTRY ]
2717
2718 Check/untaint phone numbers.  May be null.  If there is an error, returns
2719 the error, otherwise returns false.
2720
2721 Takes an optional two-letter ISO 3166-1 alpha-2 country code; without
2722 it or with unsupported countries, ut_phonen simply calls ut_alphan.
2723
2724 =cut
2725
2726 sub ut_phonen {
2727   my( $self, $field, $country ) = @_;
2728   return $self->ut_alphan($field) unless defined $country;
2729   my $phonen = $self->getfield($field);
2730   if ( $phonen eq '' ) {
2731     $self->setfield($field,'');
2732   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2733     $phonen =~ s/\D//g;
2734     $phonen = $conf->config('cust_main-default_areacode').$phonen
2735       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2736     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2737       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2738     $phonen = "$1-$2-$3";
2739     $phonen .= " x$4" if $4;
2740     $self->setfield($field,$phonen);
2741   } else {
2742     warn "warning: don't know how to check phone numbers for country $country";
2743     return $self->ut_textn($field);
2744   }
2745   '';
2746 }
2747
2748 =item ut_hex COLUMN
2749
2750 Check/untaint hexadecimal values.
2751
2752 =cut
2753
2754 sub ut_hex {
2755   my($self, $field) = @_;
2756   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2757     or return "Illegal (hex) $field: ". $self->getfield($field);
2758   $self->setfield($field, uc($1));
2759   '';
2760 }
2761
2762 =item ut_hexn COLUMN
2763
2764 Check/untaint hexadecimal values.  May be null.
2765
2766 =cut
2767
2768 sub ut_hexn {
2769   my($self, $field) = @_;
2770   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2771     or return "Illegal (hex) $field: ". $self->getfield($field);
2772   $self->setfield($field, uc($1));
2773   '';
2774 }
2775
2776 =item ut_mac_addr COLUMN
2777
2778 Check/untaint mac addresses.  May be null.
2779
2780 =cut
2781
2782 sub ut_mac_addr {
2783   my($self, $field) = @_;
2784
2785   my $mac = $self->get($field);
2786   $mac =~ s/\s+//g;
2787   $mac =~ s/://g;
2788   $self->set($field, $mac);
2789
2790   my $e = $self->ut_hex($field);
2791   return $e if $e;
2792
2793   return "Illegal (mac address) $field: ". $self->getfield($field)
2794     unless length($self->getfield($field)) == 12;
2795
2796   '';
2797
2798 }
2799
2800 =item ut_mac_addrn COLUMN
2801
2802 Check/untaint mac addresses.  May be null.
2803
2804 =cut
2805
2806 sub ut_mac_addrn {
2807   my($self, $field) = @_;
2808   ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2809 }
2810
2811 =item ut_ip COLUMN
2812
2813 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2814 to 127.0.0.1.
2815
2816 =cut
2817
2818 sub ut_ip {
2819   my( $self, $field ) = @_;
2820   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2821   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2822     or return "Illegal (IP address) $field: ". $self->getfield($field);
2823   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2824   $self->setfield($field, "$1.$2.$3.$4");
2825   '';
2826 }
2827
2828 =item ut_ipn COLUMN
2829
2830 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2831 to 127.0.0.1.  May be null.
2832
2833 =cut
2834
2835 sub ut_ipn {
2836   my( $self, $field ) = @_;
2837   if ( $self->getfield($field) =~ /^()$/ ) {
2838     $self->setfield($field,'');
2839     '';
2840   } else {
2841     $self->ut_ip($field);
2842   }
2843 }
2844
2845 =item ut_ip46 COLUMN
2846
2847 Check/untaint IPv4 or IPv6 address.
2848
2849 =cut
2850
2851 sub ut_ip46 {
2852   my( $self, $field ) = @_;
2853   my $ip = NetAddr::IP->new($self->getfield($field))
2854     or return "Illegal (IP address) $field: ".$self->getfield($field);
2855   $self->setfield($field, lc($ip->addr));
2856   return '';
2857 }
2858
2859 =item ut_ip46n
2860
2861 Check/untaint IPv6 or IPv6 address.  May be null.
2862
2863 =cut
2864
2865 sub ut_ip46n {
2866   my( $self, $field ) = @_;
2867   if ( $self->getfield($field) =~ /^$/ ) {
2868     $self->setfield($field, '');
2869     return '';
2870   }
2871   $self->ut_ip46($field);
2872 }
2873
2874 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2875
2876 Check/untaint coordinates.
2877 Accepts the following forms:
2878 DDD.DDDDD
2879 -DDD.DDDDD
2880 DDD MM.MMM
2881 -DDD MM.MMM
2882 DDD MM SS
2883 -DDD MM SS
2884 DDD MM MMM
2885 -DDD MM MMM
2886
2887 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2888 The latter form (that is, the MMM are thousands of minutes) is
2889 assumed if the "MMM" is exactly three digits or two digits > 59.
2890
2891 To be safe, just use the DDD.DDDDD form.
2892
2893 If LOWER or UPPER are specified, then the coordinate is checked
2894 for lower and upper bounds, respectively.
2895
2896 =cut
2897
2898 sub ut_coord {
2899   my ($self, $field) = (shift, shift);
2900
2901   my($lower, $upper);
2902   if ( $field =~ /latitude/ ) {
2903     $lower = $lat_lower;
2904     $upper = 90;
2905   } elsif ( $field =~ /longitude/ ) {
2906     $lower = -180;
2907     $upper = $lon_upper;
2908   }
2909
2910   my $coord = $self->getfield($field);
2911   my $neg = $coord =~ s/^(-)//;
2912
2913   # ignore degree symbol at the end,
2914   #   but not otherwise supporting degree/minutes/seconds symbols
2915   $coord =~ s/\N{DEGREE SIGN}\s*$//;
2916
2917   my ($d, $m, $s) = (0, 0, 0);
2918
2919   if (
2920     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2921     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2922     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2923   ) {
2924     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2925     $m = $m / 60;
2926     if ($m > 59) {
2927       return "Invalid (coordinate with minutes > 59) $field: "
2928              . $self->getfield($field);
2929     }
2930
2931     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2932
2933     if (defined($lower) and ($coord < $lower)) {
2934       return "Invalid (coordinate < $lower) $field: "
2935              . $self->getfield($field);;
2936     }
2937
2938     if (defined($upper) and ($coord > $upper)) {
2939       return "Invalid (coordinate > $upper) $field: "
2940              . $self->getfield($field);;
2941     }
2942
2943     $self->setfield($field, $coord);
2944     return '';
2945   }
2946
2947   return "Invalid (coordinate) $field: " . $self->getfield($field);
2948
2949 }
2950
2951 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2952
2953 Same as ut_coord, except optionally null.
2954
2955 =cut
2956
2957 sub ut_coordn {
2958
2959   my ($self, $field) = (shift, shift);
2960
2961   if ($self->getfield($field) =~ /^\s*$/) {
2962     return '';
2963   } else {
2964     return $self->ut_coord($field, @_);
2965   }
2966
2967 }
2968
2969 =item ut_domain COLUMN
2970
2971 Check/untaint host and domain names.  May not be null.
2972
2973 =cut
2974
2975 sub ut_domain {
2976   my( $self, $field ) = @_;
2977   #$self->getfield($field) =~/^(\w+\.)*\w+$/
2978   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2979     or return "Illegal (hostname) $field: ". $self->getfield($field);
2980   $self->setfield($field,$1);
2981   '';
2982 }
2983
2984 =item ut_domainn COLUMN
2985
2986 Check/untaint host and domain names.  May be null.
2987
2988 =cut
2989
2990 sub ut_domainn {
2991   my( $self, $field ) = @_;
2992   if ( $self->getfield($field) =~ /^()$/ ) {
2993     $self->setfield($field,'');
2994     '';
2995   } else {
2996     $self->ut_domain($field);
2997   }
2998 }
2999
3000 =item ut_name COLUMN
3001
3002 Check/untaint proper names; allows alphanumerics, spaces and the following
3003 punctuation: , . - '
3004
3005 May not be null.
3006
3007 =cut
3008
3009 sub ut_name {
3010   my( $self, $field ) = @_;
3011   $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
3012     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
3013   my $name = $1;
3014   $name =~ s/^\s+//;
3015   $name =~ s/\s+$//;
3016   $name =~ s/\s+/ /g;
3017   $self->setfield($field, $name);
3018   '';
3019 }
3020
3021 =item ut_namen COLUMN
3022
3023 Check/untaint proper names; allows alphanumerics, spaces and the following
3024 punctuation: , . - '
3025
3026 May not be null.
3027
3028 =cut
3029
3030 sub ut_namen {
3031   my( $self, $field ) = @_;
3032   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
3033   $self->ut_name($field);
3034 }
3035
3036 =item ut_zip COLUMN
3037
3038 Check/untaint zip codes.
3039
3040 =cut
3041
3042 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
3043
3044 sub ut_zip {
3045   my( $self, $field, $country ) = @_;
3046
3047   if ( $country eq 'US' ) {
3048
3049     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
3050       or return gettext('illegal_zip'). " $field for country $country: ".
3051                 $self->getfield($field);
3052     $self->setfield($field, $1);
3053
3054   } elsif ( $country eq 'CA' ) {
3055
3056     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
3057       or return gettext('illegal_zip'). " $field for country $country: ".
3058                 $self->getfield($field);
3059     $self->setfield($field, "$1 $2");
3060
3061   } else {
3062
3063     if ( $self->getfield($field) =~ /^\s*$/
3064          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
3065        )
3066     {
3067       $self->setfield($field,'');
3068     } else {
3069       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
3070         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
3071       $self->setfield($field,$1);
3072     }
3073
3074   }
3075
3076   '';
3077 }
3078
3079 =item ut_country COLUMN
3080
3081 Check/untaint country codes.  Country names are changed to codes, if possible -
3082 see L<Locale::Country>.
3083
3084 =cut
3085
3086 sub ut_country {
3087   my( $self, $field ) = @_;
3088   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
3089     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
3090          && country2code($1) ) {
3091       $self->setfield($field,uc(country2code($1)));
3092     }
3093   }
3094   $self->getfield($field) =~ /^(\w\w)$/
3095     or return "Illegal (country) $field: ". $self->getfield($field);
3096   $self->setfield($field,uc($1));
3097   '';
3098 }
3099
3100 =item ut_anything COLUMN
3101
3102 Untaints arbitrary data.  Be careful.
3103
3104 =cut
3105
3106 sub ut_anything {
3107   my( $self, $field ) = @_;
3108   $self->getfield($field) =~ /^(.*)$/s
3109     or return "Illegal $field: ". $self->getfield($field);
3110   $self->setfield($field,$1);
3111   '';
3112 }
3113
3114 =item ut_enum COLUMN CHOICES_ARRAYREF
3115
3116 Check/untaint a column, supplying all possible choices, like the "enum" type.
3117
3118 =cut
3119
3120 sub ut_enum {
3121   my( $self, $field, $choices ) = @_;
3122   foreach my $choice ( @$choices ) {
3123     if ( $self->getfield($field) eq $choice ) {
3124       $self->setfield($field, $choice);
3125       return '';
3126     }
3127   }
3128   return "Illegal (enum) field $field: ". $self->getfield($field);
3129 }
3130
3131 =item ut_enumn COLUMN CHOICES_ARRAYREF
3132
3133 Like ut_enum, except the null value is also allowed.
3134
3135 =cut
3136
3137 sub ut_enumn {
3138   my( $self, $field, $choices ) = @_;
3139   $self->getfield($field)
3140     ? $self->ut_enum($field, $choices)
3141     : '';
3142 }
3143
3144 =item ut_flag COLUMN
3145
3146 Check/untaint a column if it contains either an empty string or 'Y'.  This
3147 is the standard form for boolean flags in Freeside.
3148
3149 =cut
3150
3151 sub ut_flag {
3152   my( $self, $field ) = @_;
3153   my $value = uc($self->getfield($field));
3154   if ( $value eq '' or $value eq 'Y' ) {
3155     $self->setfield($field, $value);
3156     return '';
3157   }
3158   return "Illegal (flag) field $field: $value";
3159 }
3160
3161 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3162
3163 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
3164 on the column first.
3165
3166 =cut
3167
3168 sub ut_foreign_key {
3169   my( $self, $field, $table, $foreign ) = @_;
3170   return $self->ut_number($field) if $no_check_foreign;
3171   qsearchs($table, { $foreign => $self->getfield($field) })
3172     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
3173               " in $table.$foreign";
3174   '';
3175 }
3176
3177 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3178
3179 Like ut_foreign_key, except the null value is also allowed.
3180
3181 =cut
3182
3183 sub ut_foreign_keyn {
3184   my( $self, $field, $table, $foreign ) = @_;
3185   $self->getfield($field)
3186     ? $self->ut_foreign_key($field, $table, $foreign)
3187     : '';
3188 }
3189
3190 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
3191
3192 Checks this column as an agentnum, taking into account the current users's
3193 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
3194 right or rights allowing no agentnum.
3195
3196 =cut
3197
3198 sub ut_agentnum_acl {
3199   my( $self, $field ) = (shift, shift);
3200   my $null_acl = scalar(@_) ? shift : [];
3201   $null_acl = [ $null_acl ] unless ref($null_acl);
3202
3203   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
3204   return "Illegal agentnum: $error" if $error;
3205
3206   my $curuser = $FS::CurrentUser::CurrentUser;
3207
3208   if ( $self->$field() ) {
3209
3210     return 'Access denied to agent '. $self->$field()
3211       unless $curuser->agentnum($self->$field());
3212
3213   } else {
3214
3215     return 'Access denied to global'
3216       unless grep $curuser->access_right($_), @$null_acl;
3217
3218   }
3219
3220   '';
3221
3222 }
3223
3224 =item trim_whitespace FIELD[, FIELD ... ]
3225
3226 Strip leading and trailing spaces from the value in the named FIELD(s).
3227
3228 =cut
3229
3230 sub trim_whitespace {
3231   my $self = shift;
3232   foreach my $field (@_) {
3233     my $value = $self->get($field);
3234     $value =~ s/^\s+//;
3235     $value =~ s/\s+$//;
3236     $self->set($field, $value);
3237   }
3238 }
3239
3240 =item fields [ TABLE ]
3241
3242 This is a wrapper for real_fields.  Code that called
3243 fields before should probably continue to call fields.
3244
3245 =cut
3246
3247 sub fields {
3248   my $something = shift;
3249   my $table;
3250   if($something->isa('FS::Record')) {
3251     $table = $something->table;
3252   } else {
3253     $table = $something;
3254     #$something = "FS::$table";
3255   }
3256   return (real_fields($table));
3257 }
3258
3259
3260 =item encrypt($value)
3261
3262 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
3263
3264 Returns the encrypted string.
3265
3266 You should generally not have to worry about calling this, as the system handles this for you.
3267
3268 =cut
3269
3270 sub encrypt {
3271   my ($self, $value) = @_;
3272   my $encrypted = $value;
3273
3274   if ($conf_encryption) {
3275     if ($self->is_encrypted($value)) {
3276       # Return the original value if it isn't plaintext.
3277       $encrypted = $value;
3278     } else {
3279       $self->loadRSA;
3280       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
3281         # RSA doesn't like the empty string so let's pack it up
3282         # The database doesn't like the RSA data so uuencode it
3283         my $length = length($value)+1;
3284         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
3285       } else {
3286         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
3287       }
3288     }
3289   }
3290   return $encrypted;
3291 }
3292
3293 =item is_encrypted($value)
3294
3295 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
3296
3297 =cut
3298
3299
3300 sub is_encrypted {
3301   my ($self, $value) = @_;
3302   # could be more precise about it, but this will do for now
3303   $value =~ /^M/ && length($value) > 80;
3304 }
3305
3306 =item decrypt($value)
3307
3308 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
3309
3310 You should generally not have to worry about calling this, as the system handles this for you.
3311
3312 =cut
3313
3314 sub decrypt {
3315   my ($self,$value) = @_;
3316   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
3317   if ($conf_encryption && $self->is_encrypted($value)) {
3318     $self->loadRSA;
3319     if (ref($rsa_decrypt) =~ /::RSA/) {
3320       my $encrypted = unpack ("u*", $value);
3321       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
3322       if ($@) {warn "Decryption Failed"};
3323     }
3324   }
3325   return $decrypted;
3326 }
3327
3328 sub loadRSA {
3329     my $self = shift;
3330     #Initialize the Module
3331     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
3332
3333     if ($conf_encryptionmodule && $conf_encryptionmodule ne '') {
3334       $rsa_module = $conf_encryptionmodule;
3335     }
3336
3337     if (!$rsa_loaded) {
3338         eval ("require $rsa_module"); # No need to import the namespace
3339         $rsa_loaded++;
3340     }
3341     # Initialize Encryption
3342     if ($conf_encryptionpublickey && $conf_encryptionpublickey ne '') {
3343       $rsa_encrypt = $rsa_module->new_public_key($conf_encryptionpublickey);
3344     }
3345
3346     # Intitalize Decryption
3347     if ($conf_encryptionprivatekey && $conf_encryptionprivatekey ne '') {
3348       $rsa_decrypt = $rsa_module->new_private_key($conf_encryptionprivatekey);
3349     }
3350 }
3351
3352 =item h_search ACTION
3353
3354 Given an ACTION, either "insert", or "delete", returns the appropriate history
3355 record corresponding to this record, if any.
3356
3357 =cut
3358
3359 sub h_search {
3360   my( $self, $action ) = @_;
3361
3362   my $table = $self->table;
3363   $table =~ s/^h_//;
3364
3365   my $primary_key = dbdef->table($table)->primary_key;
3366
3367   qsearchs({
3368     'table'   => "h_$table",
3369     'hashref' => { $primary_key     => $self->$primary_key(),
3370                    'history_action' => $action,
3371                  },
3372   });
3373
3374 }
3375
3376 =item h_date ACTION
3377
3378 Given an ACTION, either "insert", or "delete", returns the timestamp of the
3379 appropriate history record corresponding to this record, if any.
3380
3381 =cut
3382
3383 sub h_date {
3384   my($self, $action) = @_;
3385   my $h = $self->h_search($action);
3386   $h ? $h->history_date : '';
3387 }
3388
3389 =item scalar_sql SQL [ PLACEHOLDER, ... ]
3390
3391 A class or object method.  Executes the sql statement represented by SQL and
3392 returns a scalar representing the result: the first column of the first row.
3393
3394 Dies on bogus SQL.  Returns an empty string if no row is returned.
3395
3396 Typically used for statments which return a single value such as "SELECT
3397 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
3398
3399 =cut
3400
3401 sub scalar_sql {
3402   my($self, $sql) = (shift, shift);
3403   my $sth = dbh->prepare($sql) or die dbh->errstr;
3404   $sth->execute(@_)
3405     or die "Unexpected error executing statement $sql: ". $sth->errstr;
3406   my $row = $sth->fetchrow_arrayref or return '';
3407   my $scalar = $row->[0];
3408   defined($scalar) ? $scalar : '';
3409 }
3410
3411 =item count [ WHERE [, PLACEHOLDER ...] ]
3412
3413 Convenience method for the common case of "SELECT COUNT(*) FROM table",
3414 with optional WHERE.  Must be called as method on a class with an
3415 associated table.
3416
3417 =cut
3418
3419 sub count {
3420   my($self, $where) = (shift, shift);
3421   my $table = $self->table or die 'count called on object of class '.ref($self);
3422   my $sql = "SELECT COUNT(*) FROM $table";
3423   $sql .= " WHERE $where" if $where;
3424   $self->scalar_sql($sql, @_);
3425 }
3426
3427 =item row_exists [ WHERE [, PLACEHOLDER ...] ]
3428
3429 Convenience method for the common case of "SELECT 1 FROM table ... LIMIT 1"
3430 with optional (but almost always needed) WHERE.
3431
3432 =cut
3433
3434 sub row_exists {
3435   my($self, $where) = (shift, shift);
3436   my $table = $self->table or die 'row_exists called on object of class '.ref($self);
3437   my $sql = "SELECT 1 FROM $table";
3438   $sql .= " WHERE $where" if $where;
3439   $sql .= " LIMIT 1";
3440   $self->scalar_sql($sql, @_);
3441 }
3442
3443 =back
3444
3445 =head1 SUBROUTINES
3446
3447 =over 4
3448
3449 =item real_fields [ TABLE ]
3450
3451 Returns a list of the real columns in the specified table.  Called only by
3452 fields() and other subroutines elsewhere in FS::Record.
3453
3454 =cut
3455
3456 sub real_fields {
3457   my $table = shift;
3458
3459   my($table_obj) = dbdef->table($table);
3460   confess "Unknown table $table" unless $table_obj;
3461   $table_obj->columns;
3462 }
3463
3464 =item pvf FIELD_NAME
3465
3466 Returns the FS::part_virtual_field object corresponding to a field in the
3467 record (specified by FIELD_NAME).
3468
3469 =cut
3470
3471 sub pvf {
3472   my ($self, $name) = (shift, shift);
3473
3474   if(grep /^$name$/, $self->virtual_fields) {
3475     $name =~ s/^cf_//;
3476     my $concat = [ "'cf_'", "name" ];
3477     return qsearchs({   table   =>  'part_virtual_field',
3478                         hashref =>  { dbtable => $self->table,
3479                                       name    => $name
3480                                     },
3481                         select  =>  'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
3482                     });
3483   }
3484   ''
3485 }
3486
3487 =item _quote VALUE, TABLE, COLUMN
3488
3489 This is an internal function used to construct SQL statements.  It returns
3490 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3491 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3492
3493 =cut
3494
3495 sub _quote {
3496   my($value, $table, $column) = @_;
3497   my $column_obj = dbdef->table($table)->column($column);
3498   my $column_type = $column_obj->type;
3499   my $nullable = $column_obj->null;
3500
3501   utf8::upgrade($value);
3502
3503   warn "  $table.$column: $value ($column_type".
3504        ( $nullable ? ' NULL' : ' NOT NULL' ).
3505        ")\n" if $DEBUG > 2;
3506
3507   if ( $value eq '' && $nullable ) {
3508     'NULL';
3509   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3510     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3511           "using 0 instead";
3512     0;
3513   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3514             ! $column_type =~ /(char|binary|text)$/i ) {
3515     $value;
3516   } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3517            && driver_name eq 'Pg'
3518           )
3519   {
3520     no strict 'subs';
3521 #    dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right
3522     # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\,
3523     # single-quote the whole mess, and put an "E" in front.
3524     return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'");
3525   } else {
3526     dbh->quote($value);
3527   }
3528 }
3529
3530 =item hfields TABLE
3531
3532 This is deprecated.  Don't use it.
3533
3534 It returns a hash-type list with the fields of this record's table set true.
3535
3536 =cut
3537
3538 sub hfields {
3539   carp "warning: hfields is deprecated";
3540   my($table)=@_;
3541   my(%hash);
3542   foreach (fields($table)) {
3543     $hash{$_}=1;
3544   }
3545   \%hash;
3546 }
3547
3548 sub _dump {
3549   my($self)=@_;
3550   join("\n", map {
3551     "$_: ". $self->getfield($_). "|"
3552   } (fields($self->table)) );
3553 }
3554
3555 sub DESTROY { return; }
3556
3557 #sub DESTROY {
3558 #  my $self = shift;
3559 #  #use Carp qw(cluck);
3560 #  #cluck "DESTROYING $self";
3561 #  warn "DESTROYING $self";
3562 #}
3563
3564 #sub is_tainted {
3565 #             return ! eval { join('',@_), kill 0; 1; };
3566 #         }
3567
3568 =item str2time_sql [ DRIVER_NAME ]
3569
3570 Returns a function to convert to unix time based on database type, such as
3571 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
3572 the str2time_sql_closing method to return a closing string rather than just
3573 using a closing parenthesis as previously suggested.
3574
3575 You can pass an optional driver name such as "Pg", "mysql" or
3576 $dbh->{Driver}->{Name} to return a function for that database instead of
3577 the current database.
3578
3579 =cut
3580
3581 sub str2time_sql {
3582   my $driver = shift || driver_name;
3583
3584   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
3585   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3586
3587   warn "warning: unknown database type $driver; guessing how to convert ".
3588        "dates to UNIX timestamps";
3589   return 'EXTRACT(EPOCH FROM ';
3590
3591 }
3592
3593 =item str2time_sql_closing [ DRIVER_NAME ]
3594
3595 Returns the closing suffix of a function to convert to unix time based on
3596 database type, such as ")::integer" for Pg or ")" for mysql.
3597
3598 You can pass an optional driver name such as "Pg", "mysql" or
3599 $dbh->{Driver}->{Name} to return a function for that database instead of
3600 the current database.
3601
3602 =cut
3603
3604 sub str2time_sql_closing {
3605   my $driver = shift || driver_name;
3606
3607   return ' )::INTEGER ' if $driver =~ /^Pg/i;
3608   return ' ) ';
3609 }
3610
3611 =item regexp_sql [ DRIVER_NAME ]
3612
3613 Returns the operator to do a regular expression comparison based on database
3614 type, such as '~' for Pg or 'REGEXP' for mysql.
3615
3616 You can pass an optional driver name such as "Pg", "mysql" or
3617 $dbh->{Driver}->{Name} to return a function for that database instead of
3618 the current database.
3619
3620 =cut
3621
3622 sub regexp_sql {
3623   my $driver = shift || driver_name;
3624
3625   return '~'      if $driver =~ /^Pg/i;
3626   return 'REGEXP' if $driver =~ /^mysql/i;
3627
3628   die "don't know how to use regular expressions in ". driver_name." databases";
3629
3630 }
3631
3632 =item not_regexp_sql [ DRIVER_NAME ]
3633
3634 Returns the operator to do a regular expression negation based on database
3635 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3636
3637 You can pass an optional driver name such as "Pg", "mysql" or
3638 $dbh->{Driver}->{Name} to return a function for that database instead of
3639 the current database.
3640
3641 =cut
3642
3643 sub not_regexp_sql {
3644   my $driver = shift || driver_name;
3645
3646   return '!~'         if $driver =~ /^Pg/i;
3647   return 'NOT REGEXP' if $driver =~ /^mysql/i;
3648
3649   die "don't know how to use regular expressions in ". driver_name." databases";
3650
3651 }
3652
3653 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3654
3655 Returns the items concatenated based on database type, using "CONCAT()" for
3656 mysql and " || " for Pg and other databases.
3657
3658 You can pass an optional driver name such as "Pg", "mysql" or
3659 $dbh->{Driver}->{Name} to return a function for that database instead of
3660 the current database.
3661
3662 =cut
3663
3664 sub concat_sql {
3665   my $driver = ref($_[0]) ? driver_name : shift;
3666   my $items = shift;
3667
3668   if ( $driver =~ /^mysql/i ) {
3669     'CONCAT('. join(',', @$items). ')';
3670   } else {
3671     join('||', @$items);
3672   }
3673
3674 }
3675
3676 =item group_concat_sql COLUMN, DELIMITER
3677
3678 Returns an SQL expression to concatenate an aggregate column, using
3679 GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg.
3680
3681 =cut
3682
3683 sub group_concat_sql {
3684   my ($col, $delim) = @_;
3685   $delim = dbh->quote($delim);
3686   if ( driver_name() =~ /^mysql/i ) {
3687     # DISTINCT(foo) is valid as $col
3688     return "GROUP_CONCAT($col SEPARATOR $delim)";
3689   } else {
3690     return "array_to_string(array_agg($col), $delim)";
3691   }
3692 }
3693
3694 =item midnight_sql DATE
3695
3696 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3697 on that day in the system timezone, using the default driver name.
3698
3699 =cut
3700
3701 sub midnight_sql {
3702   my $driver = driver_name;
3703   my $expr = shift;
3704   if ( $driver =~ /^mysql/i ) {
3705     "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3706   }
3707   else {
3708     "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3709   }
3710 }
3711
3712 =back
3713
3714 =head1 BUGS
3715
3716 This module should probably be renamed, since much of the functionality is
3717 of general use.  It is not completely unlike Adapter::DBI (see below).
3718
3719 Exported qsearch and qsearchs should be deprecated in favor of method calls
3720 (against an FS::Record object like the old search and searchs that qsearch
3721 and qsearchs were on top of.)
3722
3723 The whole fields / hfields mess should be removed.
3724
3725 The various WHERE clauses should be subroutined.
3726
3727 table string should be deprecated in favor of DBIx::DBSchema::Table.
3728
3729 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
3730 true maps to the database (and WHERE clauses) would also help.
3731
3732 The ut_ methods should ask the dbdef for a default length.
3733
3734 ut_sqltype (like ut_varchar) should all be defined
3735
3736 A fallback check method should be provided which uses the dbdef.
3737
3738 The ut_money method assumes money has two decimal digits.
3739
3740 The Pg money kludge in the new method only strips `$'.
3741
3742 The ut_phonen method only checks US-style phone numbers.
3743
3744 The _quote function should probably use ut_float instead of a regex.
3745
3746 All the subroutines probably should be methods, here or elsewhere.
3747
3748 Probably should borrow/use some dbdef methods where appropriate (like sub
3749 fields)
3750
3751 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3752 or allow it to be set.  Working around it is ugly any way around - DBI should
3753 be fixed.  (only affects RDBMS which return uppercase column names)
3754
3755 ut_zip should take an optional country like ut_phone.
3756
3757 =head1 SEE ALSO
3758
3759 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3760
3761 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
3762
3763 http://poop.sf.net/
3764
3765 =cut
3766
3767 1;
3768