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