FS/FS/Record.pm

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