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