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