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