FS/FS/Record.pm

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