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