FS/FS/Record.pm

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