FS/FS/Record.pm

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