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   confess "errant AUTOLOAD $field for $self (arg $value)"
 983     unless blessed($self) && $self->can('setfield');
 984
 985   #$fk_method_cache{$self->table} ||= fk_methods($self->table);
 986   if ( exists($fk_method_cache{$self->table}->{$field}) ) {
 987
 988     my $fk_info = $fk_method_cache{$self->table}->{$field};
 989     my $method = $fk_info->{method} || 'qsearchs';
 990     my $table = $fk_info->{table} || $field;
 991     my $column = $fk_info->{column};
 992     my $foreign_column = $fk_info->{references} || $column;
 993
 994     eval "use FS::$table";
 995     die $@ if $@;
 996
 997     my $pkey_value = $self->$column();
 998     my %search = ( $foreign_column => $pkey_value );
 999
1000     # FS::Record->$method() ?  they're actually just subs :/
1001     if ( $method eq 'qsearchs' ) {
1002       return $pkey_value ? qsearchs( $table, \%search ) : '';
1003     } elsif ( $method eq 'qsearch' ) {
1004       return $pkey_value ? qsearch(  $table, \%search ) : ();
1005     } else {
1006       die "unknown method $method";
1007     }
1008
1009   }
1010
1011   if ( defined($value) ) {
1012     $self->setfield($field,$value);
1013   } else {
1014     $self->getfield($field);
1015   }
1016 }
1017
1018 # efficient (also, old, doesn't support FK stuff)
1019 #sub AUTOLOAD {
1020 #  my $field = $AUTOLOAD;
1021 #  $field =~ s/.*://;
1022 #  if ( defined($_[1]) ) {
1023 #    $_[0]->setfield($field, $_[1]);
1024 #  } else {
1025 #    $_[0]->getfield($field);
1026 #  }
1027 #}
1028
1029 sub fk_methods {
1030   my $table = shift;
1031
1032   my %hash = ();
1033
1034   # foreign keys we reference in other tables
1035   foreach my $fk (dbdef->table($table)->foreign_keys) {
1036
1037     my $method = '';
1038     if ( scalar( @{$fk->columns} ) == 1 ) {
1039       if ( ! @{$fk->references} || $fk->columns->[0] eq $fk->references->[0] ){
1040         $method = $fk->table;
1041       } else {
1042         #some sort of hint in the table.pm or schema for methods not named
1043         # after their foreign table (well, not a whole lot different than
1044         # just providing a small subroutine...)
1045       }
1046
1047       if ( $method ) {
1048         $hash{$method} = { #fk_info
1049                            'method' => 'qsearchs',
1050                            'column' => $fk->columns->[0],
1051                            #'references' => $fk->references->[0],
1052                          };
1053       }
1054
1055     }
1056
1057   }
1058
1059   # foreign keys referenced in other tables to us
1060   #  (alas.  why we're cached.  still, might this loop better be done once at
1061   #   schema load time insetad of every time we AUTOLOAD a method on a new
1062   #   class?)
1063   foreach my $f_table ( dbdef->tables ) {
1064     foreach my $fk (dbdef->table($f_table)->foreign_keys) {
1065
1066       next unless $fk->table eq $table;
1067
1068       my $method = '';
1069       if ( scalar( @{$fk->columns} ) == 1 ) {
1070         if ( ! @{$fk->references} || $fk->columns->[0] eq $fk->references->[0] ){
1071           $method = $f_table;
1072         } else {
1073           #some sort of hint in the table.pm or schema for methods not named
1074           # after their foreign table (well, not a whole lot different than
1075           # just providing a small subroutine...)
1076         }
1077
1078         if ( $method ) {
1079           $hash{$method} = { #fk_info
1080                              'method' => 'qsearch',
1081                              'column' => $fk->columns->[0], #references||column
1082                              #'references' => $fk->column->[0],
1083                            };
1084         }
1085
1086       }
1087
1088     }
1089
1090   }
1091
1092   \%hash;
1093 }
1094
1095 =item hash
1096
1097 Returns a list of the column/value pairs, usually for assigning to a new hash.
1098
1099 To make a distinct duplicate of an FS::Record object, you can do:
1100
1101     $new = new FS::Record ( $old->table, { $old->hash } );
1102
1103 =cut
1104
1105 sub hash {
1106   my($self) = @_;
1107   confess $self. ' -> hash: Hash attribute is undefined'
1108     unless defined($self->{'Hash'});
1109   %{ $self->{'Hash'} };
1110 }
1111
1112 =item hashref
1113
1114 Returns a reference to the column/value hash.  This may be deprecated in the
1115 future; if there's a reason you can't just use the autoloaded or get/set
1116 methods, speak up.
1117
1118 =cut
1119
1120 sub hashref {
1121   my($self) = @_;
1122   $self->{'Hash'};
1123 }
1124
1125 =item modified
1126
1127 Returns true if any of this object's values have been modified with set (or via
1128 an autoloaded method).  Doesn't yet recognize when you retreive a hashref and
1129 modify that.
1130
1131 =cut
1132
1133 sub modified {
1134   my $self = shift;
1135   $self->{'modified'};
1136 }
1137
1138 =item select_for_update
1139
1140 Selects this record with the SQL "FOR UPDATE" command.  This can be useful as
1141 a mutex.
1142
1143 =cut
1144
1145 sub select_for_update {
1146   my $self = shift;
1147   my $primary_key = $self->primary_key;
1148   qsearchs( {
1149     'select'    => '*',
1150     'table'     => $self->table,
1151     'hashref'   => { $primary_key => $self->$primary_key() },
1152     'extra_sql' => 'FOR UPDATE',
1153   } );
1154 }
1155
1156 =item lock_table
1157
1158 Locks this table with a database-driver specific lock method.  This is used
1159 as a mutex in order to do a duplicate search.
1160
1161 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
1162
1163 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
1164
1165 Errors are fatal; no useful return value.
1166
1167 Note: To use this method for new tables other than svc_acct and svc_phone,
1168 edit freeside-upgrade and add those tables to the duplicate_lock list.
1169
1170 =cut
1171
1172 sub lock_table {
1173   my $self = shift;
1174   my $table = $self->table;
1175
1176   warn "$me locking $table table\n" if $DEBUG;
1177
1178   if ( driver_name =~ /^Pg/i ) {
1179
1180     dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
1181       or die dbh->errstr;
1182
1183   } elsif ( driver_name =~ /^mysql/i ) {
1184
1185     dbh->do("SELECT * FROM duplicate_lock
1186                WHERE lockname = '$table'
1187                FOR UPDATE"
1188            ) or die dbh->errstr;
1189
1190   } else {
1191
1192     die "unknown database ". driver_name. "; don't know how to lock table";
1193
1194   }
1195
1196   warn "$me acquired $table table lock\n" if $DEBUG;
1197
1198 }
1199
1200 =item insert
1201
1202 Inserts this record to the database.  If there is an error, returns the error,
1203 otherwise returns false.
1204
1205 =cut
1206
1207 sub insert {
1208   my $self = shift;
1209   my $saved = {};
1210
1211   warn "$self -> insert" if $DEBUG;
1212
1213   my $error = $self->check;
1214   return $error if $error;
1215
1216   #single-field non-null unique keys are given a value if empty
1217   #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
1218   foreach ( $self->dbdef_table->unique_singles) {
1219     next if $self->getfield($_);
1220     next if $self->dbdef_table->column($_)->null eq 'NULL';
1221     $self->unique($_);
1222   }
1223
1224   #and also the primary key, if the database isn't going to
1225   my $primary_key = $self->dbdef_table->primary_key;
1226   my $db_seq = 0;
1227   if ( $primary_key ) {
1228     my $col = $self->dbdef_table->column($primary_key);
1229
1230     $db_seq =
1231       uc($col->type) =~ /^(BIG)?SERIAL\d?/
1232       || ( driver_name eq 'Pg'
1233              && defined($col->default)
1234              && $col->quoted_default =~ /^nextval\(/i
1235          )
1236       || ( driver_name eq 'mysql'
1237              && defined($col->local)
1238              && $col->local =~ /AUTO_INCREMENT/i
1239          );
1240     $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
1241   }
1242
1243   my $table = $self->table;
1244
1245   # Encrypt before the database
1246   if (    defined(eval '@FS::'. $table . '::encrypted_fields')
1247        && scalar( eval '@FS::'. $table . '::encrypted_fields')
1248        && $conf->exists('encryption')
1249   ) {
1250     foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
1251       next if $field eq 'payinfo'
1252                 && ($self->isa('FS::payinfo_transaction_Mixin')
1253                     || $self->isa('FS::payinfo_Mixin') )
1254                 && $self->payby
1255                 && !grep { $self->payby eq $_ } @encrypt_payby;
1256       $saved->{$field} = $self->getfield($field);
1257       $self->setfield($field, $self->encrypt($self->getfield($field)));
1258     }
1259   }
1260
1261   #false laziness w/delete
1262   my @real_fields =
1263     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1264     real_fields($table)
1265   ;
1266   my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
1267   #eslaf
1268
1269   my $statement = "INSERT INTO $table ";
1270   if ( @real_fields ) {
1271     $statement .=
1272       "( ".
1273         join( ', ', @real_fields ).
1274       ") VALUES (".
1275         join( ', ', @values ).
1276        ")"
1277     ;
1278   } else {
1279     $statement .= 'DEFAULT VALUES';
1280   }
1281   warn "[debug]$me $statement\n" if $DEBUG > 1;
1282   my $sth = dbh->prepare($statement) or return dbh->errstr;
1283
1284   local $SIG{HUP} = 'IGNORE';
1285   local $SIG{INT} = 'IGNORE';
1286   local $SIG{QUIT} = 'IGNORE';
1287   local $SIG{TERM} = 'IGNORE';
1288   local $SIG{TSTP} = 'IGNORE';
1289   local $SIG{PIPE} = 'IGNORE';
1290
1291   $sth->execute or return $sth->errstr;
1292
1293   # get inserted id from the database, if applicable & needed
1294   if ( $db_seq && ! $self->getfield($primary_key) ) {
1295     warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
1296
1297     my $insertid = '';
1298
1299     if ( driver_name eq 'Pg' ) {
1300
1301       #my $oid = $sth->{'pg_oid_status'};
1302       #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
1303
1304       my $default = $self->dbdef_table->column($primary_key)->quoted_default;
1305       unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
1306         dbh->rollback if $FS::UID::AutoCommit;
1307         return "can't parse $table.$primary_key default value".
1308                " for sequence name: $default";
1309       }
1310       my $sequence = $1;
1311
1312       my $i_sql = "SELECT currval('$sequence')";
1313       my $i_sth = dbh->prepare($i_sql) or do {
1314         dbh->rollback if $FS::UID::AutoCommit;
1315         return dbh->errstr;
1316       };
1317       $i_sth->execute() or do { #$i_sth->execute($oid)
1318         dbh->rollback if $FS::UID::AutoCommit;
1319         return $i_sth->errstr;
1320       };
1321       $insertid = $i_sth->fetchrow_arrayref->[0];
1322
1323     } elsif ( driver_name eq 'mysql' ) {
1324
1325       $insertid = dbh->{'mysql_insertid'};
1326       # work around mysql_insertid being null some of the time, ala RT :/
1327       unless ( $insertid ) {
1328         warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
1329              "using SELECT LAST_INSERT_ID();";
1330         my $i_sql = "SELECT LAST_INSERT_ID()";
1331         my $i_sth = dbh->prepare($i_sql) or do {
1332           dbh->rollback if $FS::UID::AutoCommit;
1333           return dbh->errstr;
1334         };
1335         $i_sth->execute or do {
1336           dbh->rollback if $FS::UID::AutoCommit;
1337           return $i_sth->errstr;
1338         };
1339         $insertid = $i_sth->fetchrow_arrayref->[0];
1340       }
1341
1342     } else {
1343
1344       dbh->rollback if $FS::UID::AutoCommit;
1345       return "don't know how to retreive inserted ids from ". driver_name.
1346              ", try using counterfiles (maybe run dbdef-create?)";
1347
1348     }
1349
1350     $self->setfield($primary_key, $insertid);
1351
1352   }
1353
1354   my $h_sth;
1355   if ( defined( dbdef->table('h_'. $table) ) && ! $no_history ) {
1356     my $h_statement = $self->_h_statement('insert');
1357     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1358     $h_sth = dbh->prepare($h_statement) or do {
1359       dbh->rollback if $FS::UID::AutoCommit;
1360       return dbh->errstr;
1361     };
1362   } else {
1363     $h_sth = '';
1364   }
1365   $h_sth->execute or return $h_sth->errstr if $h_sth;
1366
1367   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1368
1369   # Now that it has been saved, reset the encrypted fields so that $new
1370   # can still be used.
1371   foreach my $field (keys %{$saved}) {
1372     $self->setfield($field, $saved->{$field});
1373   }
1374
1375   '';
1376 }
1377
1378 =item add
1379
1380 Depriciated (use insert instead).
1381
1382 =cut
1383
1384 sub add {
1385   cluck "warning: FS::Record::add deprecated!";
1386   insert @_; #call method in this scope
1387 }
1388
1389 =item delete
1390
1391 Delete this record from the database.  If there is an error, returns the error,
1392 otherwise returns false.
1393
1394 =cut
1395
1396 sub delete {
1397   my $self = shift;
1398
1399   my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1400     map {
1401       $self->getfield($_) eq ''
1402         #? "( $_ IS NULL OR $_ = \"\" )"
1403         ? ( driver_name eq 'Pg'
1404               ? "$_ IS NULL"
1405               : "( $_ IS NULL OR $_ = \"\" )"
1406           )
1407         : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1408     } ( $self->dbdef_table->primary_key )
1409           ? ( $self->dbdef_table->primary_key)
1410           : real_fields($self->table)
1411   );
1412   warn "[debug]$me $statement\n" if $DEBUG > 1;
1413   my $sth = dbh->prepare($statement) or return dbh->errstr;
1414
1415   my $h_sth;
1416   if ( defined dbdef->table('h_'. $self->table) ) {
1417     my $h_statement = $self->_h_statement('delete');
1418     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1419     $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1420   } else {
1421     $h_sth = '';
1422   }
1423
1424   my $primary_key = $self->dbdef_table->primary_key;
1425
1426   local $SIG{HUP} = 'IGNORE';
1427   local $SIG{INT} = 'IGNORE';
1428   local $SIG{QUIT} = 'IGNORE';
1429   local $SIG{TERM} = 'IGNORE';
1430   local $SIG{TSTP} = 'IGNORE';
1431   local $SIG{PIPE} = 'IGNORE';
1432
1433   my $rc = $sth->execute or return $sth->errstr;
1434   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1435   $h_sth->execute or return $h_sth->errstr if $h_sth;
1436
1437   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1438
1439   #no need to needlessly destoy the data either (causes problems actually)
1440   #undef $self; #no need to keep object!
1441
1442   '';
1443 }
1444
1445 =item del
1446
1447 Depriciated (use delete instead).
1448
1449 =cut
1450
1451 sub del {
1452   cluck "warning: FS::Record::del deprecated!";
1453   &delete(@_); #call method in this scope
1454 }
1455
1456 =item replace OLD_RECORD
1457
1458 Replace the OLD_RECORD with this one in the database.  If there is an error,
1459 returns the error, otherwise returns false.
1460
1461 =cut
1462
1463 sub replace {
1464   my ($new, $old) = (shift, shift);
1465
1466   $old = $new->replace_old unless defined($old);
1467
1468   warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1469
1470   if ( $new->can('replace_check') ) {
1471     my $error = $new->replace_check($old);
1472     return $error if $error;
1473   }
1474
1475   return "Records not in same table!" unless $new->table eq $old->table;
1476
1477   my $primary_key = $old->dbdef_table->primary_key;
1478   return "Can't change primary key $primary_key ".
1479          'from '. $old->getfield($primary_key).
1480          ' to ' . $new->getfield($primary_key)
1481     if $primary_key
1482        && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1483
1484   my $error = $new->check;
1485   return $error if $error;
1486
1487   # Encrypt for replace
1488   my $saved = {};
1489   if (    $conf->exists('encryption')
1490        && defined(eval '@FS::'. $new->table . '::encrypted_fields')
1491        && scalar( eval '@FS::'. $new->table . '::encrypted_fields')
1492   ) {
1493     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1494       next if $field eq 'payinfo'
1495                 && ($new->isa('FS::payinfo_transaction_Mixin')
1496                     || $new->isa('FS::payinfo_Mixin') )
1497                 && $new->payby
1498                 && !grep { $new->payby eq $_ } @encrypt_payby;
1499       $saved->{$field} = $new->getfield($field);
1500       $new->setfield($field, $new->encrypt($new->getfield($field)));
1501     }
1502   }
1503
1504   #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1505   my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1506                    ? ($_, $new->getfield($_)) : () } $old->fields;
1507
1508   unless (keys(%diff) || $no_update_diff ) {
1509     carp "[warning]$me ". ref($new)."->replace ".
1510            ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
1511          ": records identical"
1512       unless $nowarn_identical;
1513     return '';
1514   }
1515
1516   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1517     map {
1518       "$_ = ". _quote($new->getfield($_),$old->table,$_)
1519     } real_fields($old->table)
1520   ). ' WHERE '.
1521     join(' AND ',
1522       map {
1523
1524         if ( $old->getfield($_) eq '' ) {
1525
1526          #false laziness w/qsearch
1527          if ( driver_name eq 'Pg' ) {
1528             my $type = $old->dbdef_table->column($_)->type;
1529             if ( $type =~ /(int|(big)?serial)/i ) {
1530               qq-( $_ IS NULL )-;
1531             } else {
1532               qq-( $_ IS NULL OR $_ = '' )-;
1533             }
1534           } else {
1535             qq-( $_ IS NULL OR $_ = "" )-;
1536           }
1537
1538         } else {
1539           "$_ = ". _quote($old->getfield($_),$old->table,$_);
1540         }
1541
1542       } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1543     )
1544   ;
1545   warn "[debug]$me $statement\n" if $DEBUG > 1;
1546   my $sth = dbh->prepare($statement) or return dbh->errstr;
1547
1548   my $h_old_sth;
1549   if ( defined dbdef->table('h_'. $old->table) ) {
1550     my $h_old_statement = $old->_h_statement('replace_old');
1551     warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1552     $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1553   } else {
1554     $h_old_sth = '';
1555   }
1556
1557   my $h_new_sth;
1558   if ( defined dbdef->table('h_'. $new->table) ) {
1559     my $h_new_statement = $new->_h_statement('replace_new');
1560     warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1561     $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1562   } else {
1563     $h_new_sth = '';
1564   }
1565
1566   local $SIG{HUP} = 'IGNORE';
1567   local $SIG{INT} = 'IGNORE';
1568   local $SIG{QUIT} = 'IGNORE';
1569   local $SIG{TERM} = 'IGNORE';
1570   local $SIG{TSTP} = 'IGNORE';
1571   local $SIG{PIPE} = 'IGNORE';
1572
1573   my $rc = $sth->execute or return $sth->errstr;
1574   #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1575   $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1576   $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1577
1578   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1579
1580   # Now that it has been saved, reset the encrypted fields so that $new
1581   # can still be used.
1582   foreach my $field (keys %{$saved}) {
1583     $new->setfield($field, $saved->{$field});
1584   }
1585
1586   '';
1587
1588 }
1589
1590 sub replace_old {
1591   my( $self ) = shift;
1592   warn "[$me] replace called with no arguments; autoloading old record\n"
1593     if $DEBUG;
1594
1595   my $primary_key = $self->dbdef_table->primary_key;
1596   if ( $primary_key ) {
1597     $self->by_key( $self->$primary_key() ) #this is what's returned
1598       or croak "can't find ". $self->table. ".$primary_key ".
1599         $self->$primary_key();
1600   } else {
1601     croak $self->table. " has no primary key; pass old record as argument";
1602   }
1603
1604 }
1605
1606 =item rep
1607
1608 Depriciated (use replace instead).
1609
1610 =cut
1611
1612 sub rep {
1613   cluck "warning: FS::Record::rep deprecated!";
1614   replace @_; #call method in this scope
1615 }
1616
1617 =item check
1618
1619 Checks custom fields. Subclasses should still provide a check method to validate
1620 non-custom fields, etc., and call this method via $self->SUPER::check.
1621
1622 =cut
1623
1624 sub check {
1625     my $self = shift;
1626     foreach my $field ($self->virtual_fields) {
1627         my $error = $self->ut_textn($field);
1628         return $error if $error;
1629     }
1630     '';
1631 }
1632
1633 =item virtual_fields [ TABLE ]
1634
1635 Returns a list of virtual fields defined for the table.  This should not
1636 be exported, and should only be called as an instance or class method.
1637
1638 =cut
1639
1640 sub virtual_fields {
1641   my $self = shift;
1642   my $table;
1643   $table = $self->table or confess "virtual_fields called on non-table";
1644
1645   confess "Unknown table $table" unless dbdef->table($table);
1646
1647   return () unless dbdef->table('part_virtual_field');
1648
1649   unless ( $virtual_fields_cache{$table} ) {
1650     my $concat = [ "'cf_'", "name" ];
1651     my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' .
1652                 "WHERE dbtable = '$table'";
1653     my $dbh = dbh;
1654     my $result = $dbh->selectcol_arrayref($query);
1655     confess "Error executing virtual fields query: $query: ". $dbh->errstr
1656       if $dbh->err;
1657     $virtual_fields_cache{$table} = $result;
1658   }
1659
1660   @{$virtual_fields_cache{$table}};
1661
1662 }
1663
1664 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1665
1666 Processes a batch import as a queued JSRPC job
1667
1668 JOB is an FS::queue entry.
1669
1670 OPTIONS_HASHREF can have the following keys:
1671
1672 =over 4
1673
1674 =item table
1675
1676 Table name (required).
1677
1678 =item params
1679
1680 Listref of field names for static fields.  They will be given values from the
1681 PARAMS hashref and passed as a "params" hashref to batch_import.
1682
1683 =item formats
1684
1685 Formats hashref.  Keys are field names, values are listrefs that define the
1686 format.
1687
1688 Each listref value can be a column name or a code reference.  Coderefs are run
1689 with the row object, data and a FS::Conf object as the three parameters.
1690 For example, this coderef does the same thing as using the "columnname" string:
1691
1692   sub {
1693     my( $record, $data, $conf ) = @_;
1694     $record->columnname( $data );
1695   },
1696
1697 Coderefs are run after all "column name" fields are assigned.
1698
1699 =item format_types
1700
1701 Optional format hashref of types.  Keys are field names, values are "csv",
1702 "xls" or "fixedlength".  Overrides automatic determination of file type
1703 from extension.
1704
1705 =item format_headers
1706
1707 Optional format hashref of header lines.  Keys are field names, values are 0
1708 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1709 number of lines.
1710
1711 =item format_sep_chars
1712
1713 Optional format hashref of CSV sep_chars.  Keys are field names, values are the
1714 CSV separation character.
1715
1716 =item format_fixedlenth_formats
1717
1718 Optional format hashref of fixed length format defintiions.  Keys are field
1719 names, values Parse::FixedLength listrefs of field definitions.
1720
1721 =item default_csv
1722
1723 Set true to default to CSV file type if the filename does not contain a
1724 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1725 format_types).
1726
1727 =back
1728
1729 PARAMS is a base64-encoded Storable string containing the POSTed data as
1730 a hash ref.  It normally contains at least one field, "uploaded files",
1731 generated by /elements/file-upload.html and containing the list of uploaded
1732 files.  Currently only supports a single file named "file".
1733
1734 =cut
1735
1736 use Storable qw(thaw);
1737 use Data::Dumper;
1738 use MIME::Base64;
1739 sub process_batch_import {
1740   my($job, $opt) = ( shift, shift );
1741
1742   my $table = $opt->{table};
1743   my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1744   my %formats = %{ $opt->{formats} };
1745
1746   my $param = thaw(decode_base64(shift));
1747   warn Dumper($param) if $DEBUG;
1748
1749   my $files = $param->{'uploaded_files'}
1750     or die "No files provided.\n";
1751
1752   my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1753
1754   my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1755   my $file = $dir. $files{'file'};
1756
1757   my %iopt = (
1758     #class-static
1759     table                      => $table,
1760     formats                    => \%formats,
1761     format_types               => $opt->{format_types},
1762     format_headers             => $opt->{format_headers},
1763     format_sep_chars           => $opt->{format_sep_chars},
1764     format_fixedlength_formats => $opt->{format_fixedlength_formats},
1765     format_xml_formats         => $opt->{format_xml_formats},
1766     format_asn_formats         => $opt->{format_asn_formats},
1767     format_row_callbacks       => $opt->{format_row_callbacks},
1768     #per-import
1769     job                        => $job,
1770     file                       => $file,
1771     #type                       => $type,
1772     format                     => $param->{format},
1773     params                     => { map { $_ => $param->{$_} } @pass_params },
1774     #?
1775     default_csv                => $opt->{default_csv},
1776     postinsert_callback        => $opt->{postinsert_callback},
1777   );
1778
1779   if ( $opt->{'batch_namecol'} ) {
1780     $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1781     $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1782   }
1783
1784   my $error = FS::Record::batch_import( \%iopt );
1785
1786   unlink $file;
1787
1788   die "$error\n" if $error;
1789 }
1790
1791 =item batch_import PARAM_HASHREF
1792
1793 Class method for batch imports.  Available params:
1794
1795 =over 4
1796
1797 =item table
1798
1799 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1800
1801 =item formats
1802
1803 =item format_types
1804
1805 =item format_headers
1806
1807 =item format_sep_chars
1808
1809 =item format_fixedlength_formats
1810
1811 =item format_row_callbacks
1812
1813 =item fields - Alternate way to specify import, specifying import fields directly as a listref
1814
1815 =item preinsert_callback
1816
1817 =item postinsert_callback
1818
1819 =item params
1820
1821 =item job
1822
1823 FS::queue object, will be updated with progress
1824
1825 =item file
1826
1827 =item type
1828
1829 csv, xls, fixedlength, xml
1830
1831 =item empty_ok
1832
1833 =back
1834
1835 =cut
1836
1837 use Data::Dumper;
1838 sub batch_import {
1839   my $param = shift;
1840
1841   warn "$me batch_import call with params: \n". Dumper($param)
1842     if $DEBUG;
1843
1844   my $table   = $param->{table};
1845
1846   my $job     = $param->{job};
1847   my $file    = $param->{file};
1848   my $params  = $param->{params} || {};
1849
1850   my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
1851   my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
1852
1853   my( $type, $header, $sep_char,
1854       $fixedlength_format, $xml_format, $asn_format,
1855       $parser_opt, $row_callback, @fields );
1856
1857   my $postinsert_callback = '';
1858   $postinsert_callback = $param->{'postinsert_callback'}
1859           if $param->{'postinsert_callback'};
1860   my $preinsert_callback = '';
1861   $preinsert_callback = $param->{'preinsert_callback'}
1862           if $param->{'preinsert_callback'};
1863
1864   if ( $param->{'format'} ) {
1865
1866     my $format  = $param->{'format'};
1867     my $formats = $param->{formats};
1868     die "unknown format $format" unless exists $formats->{ $format };
1869
1870     $type = $param->{'format_types'}
1871             ? $param->{'format_types'}{ $format }
1872             : $param->{type} || 'csv';
1873
1874
1875     $header = $param->{'format_headers'}
1876                ? $param->{'format_headers'}{ $param->{'format'} }
1877                : 0;
1878
1879     $sep_char = $param->{'format_sep_chars'}
1880                   ? $param->{'format_sep_chars'}{ $param->{'format'} }
1881                   : ',';
1882
1883     $fixedlength_format =
1884       $param->{'format_fixedlength_formats'}
1885         ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1886         : '';
1887
1888     $parser_opt =
1889       $param->{'format_parser_opts'}
1890         ? $param->{'format_parser_opts'}{ $param->{'format'} }
1891         : {};
1892
1893     $xml_format =
1894       $param->{'format_xml_formats'}
1895         ? $param->{'format_xml_formats'}{ $param->{'format'} }
1896         : '';
1897
1898     $asn_format =
1899       $param->{'format_asn_formats'}
1900         ? $param->{'format_asn_formats'}{ $param->{'format'} }
1901         : '';
1902
1903     $row_callback =
1904       $param->{'format_row_callbacks'}
1905         ? $param->{'format_row_callbacks'}{ $param->{'format'} }
1906         : '';
1907
1908     @fields = @{ $formats->{ $format } };
1909
1910   } elsif ( $param->{'fields'} ) {
1911
1912     $type = ''; #infer from filename
1913     $header = 0;
1914     $sep_char = ',';
1915     $fixedlength_format = '';
1916     $row_callback = '';
1917     @fields = @{ $param->{'fields'} };
1918
1919   } else {
1920     die "neither format nor fields specified";
1921   }
1922
1923   #my $file    = $param->{file};
1924
1925   unless ( $type ) {
1926     if ( $file =~ /\.(\w+)$/i ) {
1927       $type = lc($1);
1928     } else {
1929       #or error out???
1930       warn "can't parse file type from filename $file; defaulting to CSV";
1931       $type = 'csv';
1932     }
1933     $type = 'csv'
1934       if $param->{'default_csv'} && $type ne 'xls';
1935   }
1936
1937
1938   my $row = 0;
1939   my $count;
1940   my $parser;
1941   my @buffer = ();
1942   my $asn_header_buffer;
1943   if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1944
1945     if ( $type eq 'csv' ) {
1946
1947       $parser_opt->{'binary'} = 1;
1948       $parser_opt->{'sep_char'} = $sep_char if $sep_char;
1949       $parser = Text::CSV_XS->new($parser_opt);
1950
1951     } elsif ( $type eq 'fixedlength' ) {
1952
1953       eval "use Parse::FixedLength;";
1954       die $@ if $@;
1955       $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
1956
1957     } else {
1958       die "Unknown file type $type\n";
1959     }
1960
1961     @buffer = split(/\r?\n/, slurp($file) );
1962     splice(@buffer, 0, ($header || 0) );
1963     $count = scalar(@buffer);
1964
1965   } elsif ( $type eq 'xls' ) {
1966
1967     eval "use Spreadsheet::ParseExcel;";
1968     die $@ if $@;
1969
1970     eval "use DateTime::Format::Excel;";
1971     #for now, just let the error be thrown if it is used, since only CDR
1972     # formats bill_west and troop use it, not other excel-parsing things
1973     #die $@ if $@;
1974
1975     my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
1976
1977     $parser = $excel->{Worksheet}[0]; #first sheet
1978
1979     $count = $parser->{MaxRow} || $parser->{MinRow};
1980     $count++;
1981
1982     $row = $header || 0;
1983
1984   } elsif ( $type eq 'xml' ) {
1985
1986     # FS::pay_batch
1987     eval "use XML::Simple;";
1988     die $@ if $@;
1989     my $xmlrow = $xml_format->{'xmlrow'};
1990     $parser = $xml_format->{'xmlkeys'};
1991     die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
1992     my $data = XML::Simple::XMLin(
1993       $file,
1994       'SuppressEmpty' => '', #sets empty values to ''
1995       'KeepRoot'      => 1,
1996     );
1997     my $rows = $data;
1998     $rows = $rows->{$_} foreach @$xmlrow;
1999     $rows = [ $rows ] if ref($rows) ne 'ARRAY';
2000     $count = @buffer = @$rows;
2001
2002   } elsif ( $type eq 'asn.1' ) {
2003
2004     eval "use Convert::ASN1";
2005     die $@ if $@;
2006
2007     my $asn = Convert::ASN1->new;
2008     $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
2009
2010     $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
2011
2012     my $data = slurp($file);
2013     my $asn_output = $parser->decode( $data )
2014       or return "No ". $asn_format->{'macro'}. " found\n";
2015
2016     $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
2017
2018     my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
2019     $count = @buffer = @$rows;
2020
2021   } else {
2022     die "Unknown file type $type\n";
2023   }
2024
2025   #my $columns;
2026
2027   local $SIG{HUP} = 'IGNORE';
2028   local $SIG{INT} = 'IGNORE';
2029   local $SIG{QUIT} = 'IGNORE';
2030   local $SIG{TERM} = 'IGNORE';
2031   local $SIG{TSTP} = 'IGNORE';
2032   local $SIG{PIPE} = 'IGNORE';
2033
2034   my $oldAutoCommit = $FS::UID::AutoCommit;
2035   local $FS::UID::AutoCommit = 0;
2036   my $dbh = dbh;
2037
2038   #my $params  = $param->{params} || {};
2039   if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
2040     my $batch_col   = $param->{'batch_keycol'};
2041
2042     my $batch_class = 'FS::'. $param->{'batch_table'};
2043     my $batch = $batch_class->new({
2044       $param->{'batch_namecol'} => $param->{'batch_namevalue'}
2045     });
2046     my $error = $batch->insert;
2047     if ( $error ) {
2048       $dbh->rollback if $oldAutoCommit;
2049       return "can't insert batch record: $error";
2050     }
2051     #primary key via dbdef? (so the column names don't have to match)
2052     my $batch_value = $batch->get( $param->{'batch_keycol'} );
2053
2054     $params->{ $batch_col } = $batch_value;
2055   }
2056
2057   #my $job     = $param->{job};
2058   my $line;
2059   my $imported = 0;
2060   my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
2061   while (1) {
2062
2063     my @columns = ();
2064     my %hash = %$params;
2065     if ( $type eq 'csv' ) {
2066
2067       last unless scalar(@buffer);
2068       $line = shift(@buffer);
2069
2070       next if $line =~ /^\s*$/; #skip empty lines
2071
2072       $line = &{$row_callback}($line) if $row_callback;
2073
2074       next if $line =~ /^\s*$/; #skip empty lines
2075
2076       $parser->parse($line) or do {
2077         $dbh->rollback if $oldAutoCommit;
2078         return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
2079       };
2080       @columns = $parser->fields();
2081
2082     } elsif ( $type eq 'fixedlength' ) {
2083
2084       last unless scalar(@buffer);
2085       $line = shift(@buffer);
2086
2087       @columns = $parser->parse($line);
2088
2089     } elsif ( $type eq 'xls' ) {
2090
2091       last if $row > ($parser->{MaxRow} || $parser->{MinRow})
2092            || ! $parser->{Cells}[$row];
2093
2094       my @row = @{ $parser->{Cells}[$row] };
2095       @columns = map $_->{Val}, @row;
2096
2097       #my $z = 'A';
2098       #warn $z++. ": $_\n" for @columns;
2099
2100     } elsif ( $type eq 'xml' ) {
2101
2102       # $parser = [ 'Column0Key', 'Column1Key' ... ]
2103       last unless scalar(@buffer);
2104       my $row = shift @buffer;
2105       @columns = @{ $row }{ @$parser };
2106
2107     } elsif ( $type eq 'asn.1' ) {
2108
2109       last unless scalar(@buffer);
2110       my $row = shift @buffer;
2111       &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2112         if $asn_format->{row_callback};
2113       foreach my $key ( keys %{ $asn_format->{map} } ) {
2114         $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2115       }
2116
2117     } else {
2118       die "Unknown file type $type\n";
2119     }
2120
2121     my @later = ();
2122
2123     foreach my $field ( @fields ) {
2124
2125       my $value = shift @columns;
2126
2127       if ( ref($field) eq 'CODE' ) {
2128         #&{$field}(\%hash, $value);
2129         push @later, $field, $value;
2130       } else {
2131         #??? $hash{$field} = $value if length($value);
2132         $hash{$field} = $value if defined($value) && length($value);
2133       }
2134
2135     }
2136
2137     if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
2138                          && length($1) == $custnum_length ) {
2139       $hash{custnum} = $2;
2140     }
2141
2142     #my $table   = $param->{table};
2143     my $class = "FS::$table";
2144
2145     my $record = $class->new( \%hash );
2146
2147     my $param = {};
2148     while ( scalar(@later) ) {
2149       my $sub = shift @later;
2150       my $data = shift @later;
2151       eval {
2152         &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2153       };
2154       if ( $@ ) {
2155         $dbh->rollback if $oldAutoCommit;
2156         return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2157       }
2158       last if exists( $param->{skiprow} );
2159     }
2160     next if exists( $param->{skiprow} );
2161
2162     if ( $preinsert_callback ) {
2163       my $error = &{$preinsert_callback}($record, $param);
2164       if ( $error ) {
2165         $dbh->rollback if $oldAutoCommit;
2166         return "preinsert_callback error". ( $line ? " for $line" : '' ).
2167                ": $error";
2168       }
2169       next if exists $param->{skiprow} && $param->{skiprow};
2170     }
2171
2172     my $error = $record->insert;
2173
2174     if ( $error ) {
2175       $dbh->rollback if $oldAutoCommit;
2176       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2177     }
2178
2179     $row++;
2180     $imported++;
2181
2182     if ( $postinsert_callback ) {
2183       my $error = &{$postinsert_callback}($record, $param);
2184       if ( $error ) {
2185         $dbh->rollback if $oldAutoCommit;
2186         return "postinsert_callback error". ( $line ? " for $line" : '' ).
2187                ": $error";
2188       }
2189     }
2190
2191     if ( $job && time - $min_sec > $last ) { #progress bar
2192       $job->update_statustext( int(100 * $imported / $count) );
2193       $last = time;
2194     }
2195
2196   }
2197
2198   unless ( $imported || $param->{empty_ok} ) {
2199     $dbh->rollback if $oldAutoCommit;
2200     return "Empty file!";
2201   }
2202
2203   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2204
2205   ''; #no error
2206
2207 }
2208
2209 sub _h_statement {
2210   my( $self, $action, $time ) = @_;
2211
2212   $time ||= time;
2213
2214   my %nohistory = map { $_=>1 } $self->nohistory_fields;
2215
2216   my @fields =
2217     grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2218     real_fields($self->table);
2219   ;
2220
2221   # If we're encrypting then don't store the payinfo in the history
2222   if ( $conf && $conf->exists('encryption') && $self->table ne 'banned_pay' ) {
2223     @fields = grep { $_ ne 'payinfo' } @fields;
2224   }
2225
2226   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2227
2228   "INSERT INTO h_". $self->table. " ( ".
2229       join(', ', qw(history_date history_usernum history_action), @fields ).
2230     ") VALUES (".
2231       join(', ', $time,
2232                  $FS::CurrentUser::CurrentUser->usernum,
2233                  dbh->quote($action),
2234                  @values
2235       ).
2236     ")"
2237   ;
2238 }
2239
2240 =item unique COLUMN
2241
2242 B<Warning>: External use is B<deprecated>.
2243
2244 Replaces COLUMN in record with a unique number, using counters in the
2245 filesystem.  Used by the B<insert> method on single-field unique columns
2246 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2247 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2248
2249 Returns the new value.
2250
2251 =cut
2252
2253 sub unique {
2254   my($self,$field) = @_;
2255   my($table)=$self->table;
2256
2257   croak "Unique called on field $field, but it is ",
2258         $self->getfield($field),
2259         ", not null!"
2260     if $self->getfield($field);
2261
2262   #warn "table $table is tainted" if is_tainted($table);
2263   #warn "field $field is tainted" if is_tainted($field);
2264
2265   my($counter) = new File::CounterFile "$table.$field",0;
2266
2267   my $index = $counter->inc;
2268   $index = $counter->inc while qsearchs($table, { $field=>$index } );
2269
2270   $index =~ /^(\d*)$/;
2271   $index=$1;
2272
2273   $self->setfield($field,$index);
2274
2275 }
2276
2277 =item ut_float COLUMN
2278
2279 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
2280 null.  If there is an error, returns the error, otherwise returns false.
2281
2282 =cut
2283
2284 sub ut_float {
2285   my($self,$field)=@_ ;
2286   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2287    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2288    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2289    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2290     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2291   $self->setfield($field,$1);
2292   '';
2293 }
2294 =item ut_floatn COLUMN
2295
2296 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2297 null.  If there is an error, returns the error, otherwise returns false.
2298
2299 =cut
2300
2301 #false laziness w/ut_ipn
2302 sub ut_floatn {
2303   my( $self, $field ) = @_;
2304   if ( $self->getfield($field) =~ /^()$/ ) {
2305     $self->setfield($field,'');
2306     '';
2307   } else {
2308     $self->ut_float($field);
2309   }
2310 }
2311
2312 =item ut_sfloat COLUMN
2313
2314 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2315 May not be null.  If there is an error, returns the error, otherwise returns
2316 false.
2317
2318 =cut
2319
2320 sub ut_sfloat {
2321   my($self,$field)=@_ ;
2322   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2323    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2324    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2325    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2326     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2327   $self->setfield($field,$1);
2328   '';
2329 }
2330 =item ut_sfloatn COLUMN
2331
2332 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2333 null.  If there is an error, returns the error, otherwise returns false.
2334
2335 =cut
2336
2337 sub ut_sfloatn {
2338   my( $self, $field ) = @_;
2339   if ( $self->getfield($field) =~ /^()$/ ) {
2340     $self->setfield($field,'');
2341     '';
2342   } else {
2343     $self->ut_sfloat($field);
2344   }
2345 }
2346
2347 =item ut_snumber COLUMN
2348
2349 Check/untaint signed numeric data (whole numbers).  If there is an error,
2350 returns the error, otherwise returns false.
2351
2352 =cut
2353
2354 sub ut_snumber {
2355   my($self, $field) = @_;
2356   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2357     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2358   $self->setfield($field, "$1$2");
2359   '';
2360 }
2361
2362 =item ut_snumbern COLUMN
2363
2364 Check/untaint signed numeric data (whole numbers).  If there is an error,
2365 returns the error, otherwise returns false.
2366
2367 =cut
2368
2369 sub ut_snumbern {
2370   my($self, $field) = @_;
2371   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2372     or return "Illegal (numeric) $field: ". $self->getfield($field);
2373   if ($1) {
2374     return "Illegal (numeric) $field: ". $self->getfield($field)
2375       unless $2;
2376   }
2377   $self->setfield($field, "$1$2");
2378   '';
2379 }
2380
2381 =item ut_number COLUMN
2382
2383 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
2384 is an error, returns the error, otherwise returns false.
2385
2386 =cut
2387
2388 sub ut_number {
2389   my($self,$field)=@_;
2390   $self->getfield($field) =~ /^\s*(\d+)\s*$/
2391     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2392   $self->setfield($field,$1);
2393   '';
2394 }
2395
2396 =item ut_numbern COLUMN
2397
2398 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
2399 an error, returns the error, otherwise returns false.
2400
2401 =cut
2402
2403 sub ut_numbern {
2404   my($self,$field)=@_;
2405   $self->getfield($field) =~ /^\s*(\d*)\s*$/
2406     or return "Illegal (numeric) $field: ". $self->getfield($field);
2407   $self->setfield($field,$1);
2408   '';
2409 }
2410
2411 =item ut_money COLUMN
2412
2413 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
2414 is an error, returns the error, otherwise returns false.
2415
2416 =cut
2417
2418 sub ut_money {
2419   my($self,$field)=@_;
2420
2421   if ( $self->getfield($field) eq '' ) {
2422     $self->setfield($field, 0);
2423   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2424     #handle one decimal place without barfing out
2425     $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2426   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2427     $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2428   } else {
2429     return "Illegal (money) $field: ". $self->getfield($field);
2430   }
2431
2432   '';
2433 }
2434
2435 =item ut_moneyn COLUMN
2436
2437 Check/untaint monetary numbers.  May be negative.  If there
2438 is an error, returns the error, otherwise returns false.
2439
2440 =cut
2441
2442 sub ut_moneyn {
2443   my($self,$field)=@_;
2444   if ($self->getfield($field) eq '') {
2445     $self->setfield($field, '');
2446     return '';
2447   }
2448   $self->ut_money($field);
2449 }
2450
2451 =item ut_currencyn COLUMN
2452
2453 Check/untaint currency indicators, such as USD or EUR.  May be null.  If there
2454 is an error, returns the error, otherwise returns false.
2455
2456 =cut
2457
2458 sub ut_currencyn {
2459   my($self, $field) = @_;
2460   if ($self->getfield($field) eq '') { #can be null
2461     $self->setfield($field, '');
2462     return '';
2463   }
2464   $self->ut_currency($field);
2465 }
2466
2467 =item ut_currency COLUMN
2468
2469 Check/untaint currency indicators, such as USD or EUR.  May not be null.  If
2470 there is an error, returns the error, otherwise returns false.
2471
2472 =cut
2473
2474 sub ut_currency {
2475   my($self, $field) = @_;
2476   my $value = uc( $self->getfield($field) );
2477   if ( code2currency($value) ) {
2478     $self->setfield($value);
2479   } else {
2480     return "Unknown currency $value";
2481   }
2482
2483   '';
2484 }
2485
2486 =item ut_text COLUMN
2487
2488 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2489 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2490 May not be null.  If there is an error, returns the error, otherwise returns
2491 false.
2492
2493 =cut
2494
2495 sub ut_text {
2496   my($self,$field)=@_;
2497   #warn "msgcat ". \&msgcat. "\n";
2498   #warn "notexist ". \&notexist. "\n";
2499   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2500   # \p{Word} = alphanumerics, marks (diacritics), and connectors
2501   # see perldoc perluniprops
2502   $self->getfield($field)
2503     =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
2504       or return gettext('illegal_or_empty_text'). " $field: ".
2505                  $self->getfield($field);
2506   $self->setfield($field,$1);
2507   '';
2508 }
2509
2510 =item ut_textn COLUMN
2511
2512 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2513 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2514 May be null.  If there is an error, returns the error, otherwise returns false.
2515
2516 =cut
2517
2518 sub ut_textn {
2519   my($self,$field)=@_;
2520   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2521   $self->ut_text($field);
2522 }
2523
2524 =item ut_alpha COLUMN
2525
2526 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
2527 an error, returns the error, otherwise returns false.
2528
2529 =cut
2530
2531 sub ut_alpha {
2532   my($self,$field)=@_;
2533   $self->getfield($field) =~ /^(\w+)$/
2534     or return "Illegal or empty (alphanumeric) $field: ".
2535               $self->getfield($field);
2536   $self->setfield($field,$1);
2537   '';
2538 }
2539
2540 =item ut_alphan COLUMN
2541
2542 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
2543 error, returns the error, otherwise returns false.
2544
2545 =cut
2546
2547 sub ut_alphan {
2548   my($self,$field)=@_;
2549   $self->getfield($field) =~ /^(\w*)$/
2550     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2551   $self->setfield($field,$1);
2552   '';
2553 }
2554
2555 =item ut_alphasn COLUMN
2556
2557 Check/untaint alphanumeric strings, spaces allowed.  May be null.  If there is
2558 an error, returns the error, otherwise returns false.
2559
2560 =cut
2561
2562 sub ut_alphasn {
2563   my($self,$field)=@_;
2564   $self->getfield($field) =~ /^([\w ]*)$/
2565     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2566   $self->setfield($field,$1);
2567   '';
2568 }
2569
2570
2571 =item ut_alpha_lower COLUMN
2572
2573 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
2574 there is an error, returns the error, otherwise returns false.
2575
2576 =cut
2577
2578 sub ut_alpha_lower {
2579   my($self,$field)=@_;
2580   $self->getfield($field) =~ /[[:upper:]]/
2581     and return "Uppercase characters are not permitted in $field";
2582   $self->ut_alpha($field);
2583 }
2584
2585 =item ut_phonen COLUMN [ COUNTRY ]
2586
2587 Check/untaint phone numbers.  May be null.  If there is an error, returns
2588 the error, otherwise returns false.
2589
2590 Takes an optional two-letter ISO country code; without it or with unsupported
2591 countries, ut_phonen simply calls ut_alphan.
2592
2593 =cut
2594
2595 sub ut_phonen {
2596   my( $self, $field, $country ) = @_;
2597   return $self->ut_alphan($field) unless defined $country;
2598   my $phonen = $self->getfield($field);
2599   if ( $phonen eq '' ) {
2600     $self->setfield($field,'');
2601   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2602     $phonen =~ s/\D//g;
2603     $phonen = $conf->config('cust_main-default_areacode').$phonen
2604       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2605     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2606       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2607     $phonen = "$1-$2-$3";
2608     $phonen .= " x$4" if $4;
2609     $self->setfield($field,$phonen);
2610   } else {
2611     warn "warning: don't know how to check phone numbers for country $country";
2612     return $self->ut_textn($field);
2613   }
2614   '';
2615 }
2616
2617 =item ut_hex COLUMN
2618
2619 Check/untaint hexadecimal values.
2620
2621 =cut
2622
2623 sub ut_hex {
2624   my($self, $field) = @_;
2625   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2626     or return "Illegal (hex) $field: ". $self->getfield($field);
2627   $self->setfield($field, uc($1));
2628   '';
2629 }
2630
2631 =item ut_hexn COLUMN
2632
2633 Check/untaint hexadecimal values.  May be null.
2634
2635 =cut
2636
2637 sub ut_hexn {
2638   my($self, $field) = @_;
2639   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2640     or return "Illegal (hex) $field: ". $self->getfield($field);
2641   $self->setfield($field, uc($1));
2642   '';
2643 }
2644
2645 =item ut_mac_addr COLUMN
2646
2647 Check/untaint mac addresses.  May be null.
2648
2649 =cut
2650
2651 sub ut_mac_addr {
2652   my($self, $field) = @_;
2653
2654   my $mac = $self->get($field);
2655   $mac =~ s/\s+//g;
2656   $mac =~ s/://g;
2657   $self->set($field, $mac);
2658
2659   my $e = $self->ut_hex($field);
2660   return $e if $e;
2661
2662   return "Illegal (mac address) $field: ". $self->getfield($field)
2663     unless length($self->getfield($field)) == 12;
2664
2665   '';
2666
2667 }
2668
2669 =item ut_mac_addrn COLUMN
2670
2671 Check/untaint mac addresses.  May be null.
2672
2673 =cut
2674
2675 sub ut_mac_addrn {
2676   my($self, $field) = @_;
2677   ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2678 }
2679
2680 =item ut_ip COLUMN
2681
2682 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2683 to 127.0.0.1.
2684
2685 =cut
2686
2687 sub ut_ip {
2688   my( $self, $field ) = @_;
2689   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2690   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2691     or return "Illegal (IP address) $field: ". $self->getfield($field);
2692   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2693   $self->setfield($field, "$1.$2.$3.$4");
2694   '';
2695 }
2696
2697 =item ut_ipn COLUMN
2698
2699 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2700 to 127.0.0.1.  May be null.
2701
2702 =cut
2703
2704 sub ut_ipn {
2705   my( $self, $field ) = @_;
2706   if ( $self->getfield($field) =~ /^()$/ ) {
2707     $self->setfield($field,'');
2708     '';
2709   } else {
2710     $self->ut_ip($field);
2711   }
2712 }
2713
2714 =item ut_ip46 COLUMN
2715
2716 Check/untaint IPv4 or IPv6 address.
2717
2718 =cut
2719
2720 sub ut_ip46 {
2721   my( $self, $field ) = @_;
2722   my $ip = NetAddr::IP->new($self->getfield($field))
2723     or return "Illegal (IP address) $field: ".$self->getfield($field);
2724   $self->setfield($field, lc($ip->addr));
2725   return '';
2726 }
2727
2728 =item ut_ip46n
2729
2730 Check/untaint IPv6 or IPv6 address.  May be null.
2731
2732 =cut
2733
2734 sub ut_ip46n {
2735   my( $self, $field ) = @_;
2736   if ( $self->getfield($field) =~ /^$/ ) {
2737     $self->setfield($field, '');
2738     return '';
2739   }
2740   $self->ut_ip46($field);
2741 }
2742
2743 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2744
2745 Check/untaint coordinates.
2746 Accepts the following forms:
2747 DDD.DDDDD
2748 -DDD.DDDDD
2749 DDD MM.MMM
2750 -DDD MM.MMM
2751 DDD MM SS
2752 -DDD MM SS
2753 DDD MM MMM
2754 -DDD MM MMM
2755
2756 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2757 The latter form (that is, the MMM are thousands of minutes) is
2758 assumed if the "MMM" is exactly three digits or two digits > 59.
2759
2760 To be safe, just use the DDD.DDDDD form.
2761
2762 If LOWER or UPPER are specified, then the coordinate is checked
2763 for lower and upper bounds, respectively.
2764
2765 =cut
2766
2767 sub ut_coord {
2768   my ($self, $field) = (shift, shift);
2769
2770   my($lower, $upper);
2771   if ( $field =~ /latitude/ ) {
2772     $lower = $lat_lower;
2773     $upper = 90;
2774   } elsif ( $field =~ /longitude/ ) {
2775     $lower = -180;
2776     $upper = $lon_upper;
2777   }
2778
2779   my $coord = $self->getfield($field);
2780   my $neg = $coord =~ s/^(-)//;
2781
2782   my ($d, $m, $s) = (0, 0, 0);
2783
2784   if (
2785     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2786     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2787     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2788   ) {
2789     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2790     $m = $m / 60;
2791     if ($m > 59) {
2792       return "Invalid (coordinate with minutes > 59) $field: "
2793              . $self->getfield($field);
2794     }
2795
2796     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2797
2798     if (defined($lower) and ($coord < $lower)) {
2799       return "Invalid (coordinate < $lower) $field: "
2800              . $self->getfield($field);;
2801     }
2802
2803     if (defined($upper) and ($coord > $upper)) {
2804       return "Invalid (coordinate > $upper) $field: "
2805              . $self->getfield($field);;
2806     }
2807
2808     $self->setfield($field, $coord);
2809     return '';
2810   }
2811
2812   return "Invalid (coordinate) $field: " . $self->getfield($field);
2813
2814 }
2815
2816 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2817
2818 Same as ut_coord, except optionally null.
2819
2820 =cut
2821
2822 sub ut_coordn {
2823
2824   my ($self, $field) = (shift, shift);
2825
2826   if ($self->getfield($field) =~ /^\s*$/) {
2827     return '';
2828   } else {
2829     return $self->ut_coord($field, @_);
2830   }
2831
2832 }
2833
2834 =item ut_domain COLUMN
2835
2836 Check/untaint host and domain names.  May not be null.
2837
2838 =cut
2839
2840 sub ut_domain {
2841   my( $self, $field ) = @_;
2842   #$self->getfield($field) =~/^(\w+\.)*\w+$/
2843   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2844     or return "Illegal (hostname) $field: ". $self->getfield($field);
2845   $self->setfield($field,$1);
2846   '';
2847 }
2848
2849 =item ut_domainn COLUMN
2850
2851 Check/untaint host and domain names.  May be null.
2852
2853 =cut
2854
2855 sub ut_domainn {
2856   my( $self, $field ) = @_;
2857   if ( $self->getfield($field) =~ /^()$/ ) {
2858     $self->setfield($field,'');
2859     '';
2860   } else {
2861     $self->ut_domain($field);
2862   }
2863 }
2864
2865 =item ut_name COLUMN
2866
2867 Check/untaint proper names; allows alphanumerics, spaces and the following
2868 punctuation: , . - '
2869
2870 May not be null.
2871
2872 =cut
2873
2874 sub ut_name {
2875   my( $self, $field ) = @_;
2876 #  warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
2877   $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
2878     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2879   my $name = $1;
2880   $name =~ s/^\s+//;
2881   $name =~ s/\s+$//;
2882   $name =~ s/\s+/ /g;
2883   $self->setfield($field, $name);
2884   '';
2885 }
2886
2887 =item ut_namen COLUMN
2888
2889 Check/untaint proper names; allows alphanumerics, spaces and the following
2890 punctuation: , . - '
2891
2892 May not be null.
2893
2894 =cut
2895
2896 sub ut_namen {
2897   my( $self, $field ) = @_;
2898   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2899   $self->ut_name($field);
2900 }
2901
2902 =item ut_zip COLUMN
2903
2904 Check/untaint zip codes.
2905
2906 =cut
2907
2908 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2909
2910 sub ut_zip {
2911   my( $self, $field, $country ) = @_;
2912
2913   if ( $country eq 'US' ) {
2914
2915     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2916       or return gettext('illegal_zip'). " $field for country $country: ".
2917                 $self->getfield($field);
2918     $self->setfield($field, $1);
2919
2920   } elsif ( $country eq 'CA' ) {
2921
2922     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2923       or return gettext('illegal_zip'). " $field for country $country: ".
2924                 $self->getfield($field);
2925     $self->setfield($field, "$1 $2");
2926
2927   } else {
2928
2929     if ( $self->getfield($field) =~ /^\s*$/
2930          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2931        )
2932     {
2933       $self->setfield($field,'');
2934     } else {
2935       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
2936         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2937       $self->setfield($field,$1);
2938     }
2939
2940   }
2941
2942   '';
2943 }
2944
2945 =item ut_country COLUMN
2946
2947 Check/untaint country codes.  Country names are changed to codes, if possible -
2948 see L<Locale::Country>.
2949
2950 =cut
2951
2952 sub ut_country {
2953   my( $self, $field ) = @_;
2954   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2955     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2956          && country2code($1) ) {
2957       $self->setfield($field,uc(country2code($1)));
2958     }
2959   }
2960   $self->getfield($field) =~ /^(\w\w)$/
2961     or return "Illegal (country) $field: ". $self->getfield($field);
2962   $self->setfield($field,uc($1));
2963   '';
2964 }
2965
2966 =item ut_anything COLUMN
2967
2968 Untaints arbitrary data.  Be careful.
2969
2970 =cut
2971
2972 sub ut_anything {
2973   my( $self, $field ) = @_;
2974   $self->getfield($field) =~ /^(.*)$/s
2975     or return "Illegal $field: ". $self->getfield($field);
2976   $self->setfield($field,$1);
2977   '';
2978 }
2979
2980 =item ut_enum COLUMN CHOICES_ARRAYREF
2981
2982 Check/untaint a column, supplying all possible choices, like the "enum" type.
2983
2984 =cut
2985
2986 sub ut_enum {
2987   my( $self, $field, $choices ) = @_;
2988   foreach my $choice ( @$choices ) {
2989     if ( $self->getfield($field) eq $choice ) {
2990       $self->setfield($field, $choice);
2991       return '';
2992     }
2993   }
2994   return "Illegal (enum) field $field: ". $self->getfield($field);
2995 }
2996
2997 =item ut_enumn COLUMN CHOICES_ARRAYREF
2998
2999 Like ut_enum, except the null value is also allowed.
3000
3001 =cut
3002
3003 sub ut_enumn {
3004   my( $self, $field, $choices ) = @_;
3005   $self->getfield($field)
3006     ? $self->ut_enum($field, $choices)
3007     : '';
3008 }
3009
3010 =item ut_flag COLUMN
3011
3012 Check/untaint a column if it contains either an empty string or 'Y'.  This
3013 is the standard form for boolean flags in Freeside.
3014
3015 =cut
3016
3017 sub ut_flag {
3018   my( $self, $field ) = @_;
3019   my $value = uc($self->getfield($field));
3020   if ( $value eq '' or $value eq 'Y' ) {
3021     $self->setfield($field, $value);
3022     return '';
3023   }
3024   return "Illegal (flag) field $field: $value";
3025 }
3026
3027 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3028
3029 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
3030 on the column first.
3031
3032 =cut
3033
3034 sub ut_foreign_key {
3035   my( $self, $field, $table, $foreign ) = @_;
3036   return '' if $no_check_foreign;
3037   qsearchs($table, { $foreign => $self->getfield($field) })
3038     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
3039               " in $table.$foreign";
3040   '';
3041 }
3042
3043 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3044
3045 Like ut_foreign_key, except the null value is also allowed.
3046
3047 =cut
3048
3049 sub ut_foreign_keyn {
3050   my( $self, $field, $table, $foreign ) = @_;
3051   $self->getfield($field)
3052     ? $self->ut_foreign_key($field, $table, $foreign)
3053     : '';
3054 }
3055
3056 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
3057
3058 Checks this column as an agentnum, taking into account the current users's
3059 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
3060 right or rights allowing no agentnum.
3061
3062 =cut
3063
3064 sub ut_agentnum_acl {
3065   my( $self, $field ) = (shift, shift);
3066   my $null_acl = scalar(@_) ? shift : [];
3067   $null_acl = [ $null_acl ] unless ref($null_acl);
3068
3069   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
3070   return "Illegal agentnum: $error" if $error;
3071
3072   my $curuser = $FS::CurrentUser::CurrentUser;
3073
3074   if ( $self->$field() ) {
3075
3076     return "Access denied"
3077       unless $curuser->agentnum($self->$field());
3078
3079   } else {
3080
3081     return "Access denied"
3082       unless grep $curuser->access_right($_), @$null_acl;
3083
3084   }
3085
3086   '';
3087
3088 }
3089
3090 =item fields [ TABLE ]
3091
3092 This is a wrapper for real_fields.  Code that called
3093 fields before should probably continue to call fields.
3094
3095 =cut
3096
3097 sub fields {
3098   my $something = shift;
3099   my $table;
3100   if($something->isa('FS::Record')) {
3101     $table = $something->table;
3102   } else {
3103     $table = $something;
3104     $something = "FS::$table";
3105   }
3106   return (real_fields($table));
3107 }
3108
3109
3110 =item encrypt($value)
3111
3112 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
3113
3114 Returns the encrypted string.
3115
3116 You should generally not have to worry about calling this, as the system handles this for you.
3117
3118 =cut
3119
3120 sub encrypt {
3121   my ($self, $value) = @_;
3122   my $encrypted = $value;
3123
3124   if ($conf->exists('encryption')) {
3125     if ($self->is_encrypted($value)) {
3126       # Return the original value if it isn't plaintext.
3127       $encrypted = $value;
3128     } else {
3129       $self->loadRSA;
3130       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
3131         # RSA doesn't like the empty string so let's pack it up
3132         # The database doesn't like the RSA data so uuencode it
3133         my $length = length($value)+1;
3134         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
3135       } else {
3136         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
3137       }
3138     }
3139   }
3140   return $encrypted;
3141 }
3142
3143 =item is_encrypted($value)
3144
3145 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
3146
3147 =cut
3148
3149
3150 sub is_encrypted {
3151   my ($self, $value) = @_;
3152   # could be more precise about it, but this will do for now
3153   $value =~ /^M/ && length($value) > 80;
3154 }
3155
3156 =item decrypt($value)
3157
3158 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
3159
3160 You should generally not have to worry about calling this, as the system handles this for you.
3161
3162 =cut
3163
3164 sub decrypt {
3165   my ($self,$value) = @_;
3166   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
3167   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
3168     $self->loadRSA;
3169     if (ref($rsa_decrypt) =~ /::RSA/) {
3170       my $encrypted = unpack ("u*", $value);
3171       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
3172       if ($@) {warn "Decryption Failed"};
3173     }
3174   }
3175   return $decrypted;
3176 }
3177
3178 sub loadRSA {
3179     my $self = shift;
3180     #Initialize the Module
3181     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
3182
3183     if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
3184       $rsa_module = $conf->config('encryptionmodule');
3185     }
3186
3187     if (!$rsa_loaded) {
3188         eval ("require $rsa_module"); # No need to import the namespace
3189         $rsa_loaded++;
3190     }
3191     # Initialize Encryption
3192     if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
3193       my $public_key = join("\n",$conf->config('encryptionpublickey'));
3194       $rsa_encrypt = $rsa_module->new_public_key($public_key);
3195     }
3196
3197     # Intitalize Decryption
3198     if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
3199       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
3200       $rsa_decrypt = $rsa_module->new_private_key($private_key);
3201     }
3202 }
3203
3204 =item h_search ACTION
3205
3206 Given an ACTION, either "insert", or "delete", returns the appropriate history
3207 record corresponding to this record, if any.
3208
3209 =cut
3210
3211 sub h_search {
3212   my( $self, $action ) = @_;
3213
3214   my $table = $self->table;
3215   $table =~ s/^h_//;
3216
3217   my $primary_key = dbdef->table($table)->primary_key;
3218
3219   qsearchs({
3220     'table'   => "h_$table",
3221     'hashref' => { $primary_key     => $self->$primary_key(),
3222                    'history_action' => $action,
3223                  },
3224   });
3225
3226 }
3227
3228 =item h_date ACTION
3229
3230 Given an ACTION, either "insert", or "delete", returns the timestamp of the
3231 appropriate history record corresponding to this record, if any.
3232
3233 =cut
3234
3235 sub h_date {
3236   my($self, $action) = @_;
3237   my $h = $self->h_search($action);
3238   $h ? $h->history_date : '';
3239 }
3240
3241 =item scalar_sql SQL [ PLACEHOLDER, ... ]
3242
3243 A class or object method.  Executes the sql statement represented by SQL and
3244 returns a scalar representing the result: the first column of the first row.
3245
3246 Dies on bogus SQL.  Returns an empty string if no row is returned.
3247
3248 Typically used for statments which return a single value such as "SELECT
3249 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
3250
3251 =cut
3252
3253 sub scalar_sql {
3254   my($self, $sql) = (shift, shift);
3255   my $sth = dbh->prepare($sql) or die dbh->errstr;
3256   $sth->execute(@_)
3257     or die "Unexpected error executing statement $sql: ". $sth->errstr;
3258   my $row = $sth->fetchrow_arrayref or return '';
3259   my $scalar = $row->[0];
3260   defined($scalar) ? $scalar : '';
3261 }
3262
3263 =item count [ WHERE ]
3264
3265 Convenience method for the common case of "SELECT COUNT(*) FROM table",
3266 with optional WHERE.  Must be called as method on a class with an
3267 associated table.
3268
3269 =cut
3270
3271 sub count {
3272   my($self, $where) = (shift, shift);
3273   my $table = $self->table or die 'count called on object of class '.ref($self);
3274   my $sql = "SELECT COUNT(*) FROM $table";
3275   $sql .= " WHERE $where" if $where;
3276   $self->scalar_sql($sql);
3277 }
3278
3279 =back
3280
3281 =head1 SUBROUTINES
3282
3283 =over 4
3284
3285 =item real_fields [ TABLE ]
3286
3287 Returns a list of the real columns in the specified table.  Called only by
3288 fields() and other subroutines elsewhere in FS::Record.
3289
3290 =cut
3291
3292 sub real_fields {
3293   my $table = shift;
3294
3295   my($table_obj) = dbdef->table($table);
3296   confess "Unknown table $table" unless $table_obj;
3297   $table_obj->columns;
3298 }
3299
3300 =item pvf FIELD_NAME
3301
3302 Returns the FS::part_virtual_field object corresponding to a field in the
3303 record (specified by FIELD_NAME).
3304
3305 =cut
3306
3307 sub pvf {
3308   my ($self, $name) = (shift, shift);
3309
3310   if(grep /^$name$/, $self->virtual_fields) {
3311     $name =~ s/^cf_//;
3312     my $concat = [ "'cf_'", "name" ];
3313     return qsearchs({   table   =>  'part_virtual_field',
3314                         hashref =>  { dbtable => $self->table,
3315                                       name    => $name
3316                                     },
3317                         select  =>  'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
3318                     });
3319   }
3320   ''
3321 }
3322
3323 =item _quote VALUE, TABLE, COLUMN
3324
3325 This is an internal function used to construct SQL statements.  It returns
3326 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3327 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3328
3329 =cut
3330
3331 sub _quote {
3332   my($value, $table, $column) = @_;
3333   my $column_obj = dbdef->table($table)->column($column);
3334   my $column_type = $column_obj->type;
3335   my $nullable = $column_obj->null;
3336
3337   utf8::upgrade($value);
3338
3339   warn "  $table.$column: $value ($column_type".
3340        ( $nullable ? ' NULL' : ' NOT NULL' ).
3341        ")\n" if $DEBUG > 2;
3342
3343   if ( $value eq '' && $nullable ) {
3344     'NULL';
3345   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3346     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3347           "using 0 instead";
3348     0;
3349   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3350             ! $column_type =~ /(char|binary|text)$/i ) {
3351     $value;
3352   } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3353            && driver_name eq 'Pg'
3354           )
3355   {
3356     no strict 'subs';
3357 #    dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right
3358     # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\,
3359     # single-quote the whole mess, and put an "E" in front.
3360     return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'");
3361   } else {
3362     dbh->quote($value);
3363   }
3364 }
3365
3366 =item hfields TABLE
3367
3368 This is deprecated.  Don't use it.
3369
3370 It returns a hash-type list with the fields of this record's table set true.
3371
3372 =cut
3373
3374 sub hfields {
3375   carp "warning: hfields is deprecated";
3376   my($table)=@_;
3377   my(%hash);
3378   foreach (fields($table)) {
3379     $hash{$_}=1;
3380   }
3381   \%hash;
3382 }
3383
3384 sub _dump {
3385   my($self)=@_;
3386   join("\n", map {
3387     "$_: ". $self->getfield($_). "|"
3388   } (fields($self->table)) );
3389 }
3390
3391 sub DESTROY { return; }
3392
3393 #sub DESTROY {
3394 #  my $self = shift;
3395 #  #use Carp qw(cluck);
3396 #  #cluck "DESTROYING $self";
3397 #  warn "DESTROYING $self";
3398 #}
3399
3400 #sub is_tainted {
3401 #             return ! eval { join('',@_), kill 0; 1; };
3402 #         }
3403
3404 =item str2time_sql [ DRIVER_NAME ]
3405
3406 Returns a function to convert to unix time based on database type, such as
3407 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
3408 the str2time_sql_closing method to return a closing string rather than just
3409 using a closing parenthesis as previously suggested.
3410
3411 You can pass an optional driver name such as "Pg", "mysql" or
3412 $dbh->{Driver}->{Name} to return a function for that database instead of
3413 the current database.
3414
3415 =cut
3416
3417 sub str2time_sql {
3418   my $driver = shift || driver_name;
3419
3420   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
3421   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3422
3423   warn "warning: unknown database type $driver; guessing how to convert ".
3424        "dates to UNIX timestamps";
3425   return 'EXTRACT(EPOCH FROM ';
3426
3427 }
3428
3429 =item str2time_sql_closing [ DRIVER_NAME ]
3430
3431 Returns the closing suffix of a function to convert to unix time based on
3432 database type, such as ")::integer" for Pg or ")" for mysql.
3433
3434 You can pass an optional driver name such as "Pg", "mysql" or
3435 $dbh->{Driver}->{Name} to return a function for that database instead of
3436 the current database.
3437
3438 =cut
3439
3440 sub str2time_sql_closing {
3441   my $driver = shift || driver_name;
3442
3443   return ' )::INTEGER ' if $driver =~ /^Pg/i;
3444   return ' ) ';
3445 }
3446
3447 =item regexp_sql [ DRIVER_NAME ]
3448
3449 Returns the operator to do a regular expression comparison based on database
3450 type, such as '~' for Pg or 'REGEXP' for mysql.
3451
3452 You can pass an optional driver name such as "Pg", "mysql" or
3453 $dbh->{Driver}->{Name} to return a function for that database instead of
3454 the current database.
3455
3456 =cut
3457
3458 sub regexp_sql {
3459   my $driver = shift || driver_name;
3460
3461   return '~'      if $driver =~ /^Pg/i;
3462   return 'REGEXP' if $driver =~ /^mysql/i;
3463
3464   die "don't know how to use regular expressions in ". driver_name." databases";
3465
3466 }
3467
3468 =item not_regexp_sql [ DRIVER_NAME ]
3469
3470 Returns the operator to do a regular expression negation based on database
3471 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3472
3473 You can pass an optional driver name such as "Pg", "mysql" or
3474 $dbh->{Driver}->{Name} to return a function for that database instead of
3475 the current database.
3476
3477 =cut
3478
3479 sub not_regexp_sql {
3480   my $driver = shift || driver_name;
3481
3482   return '!~'         if $driver =~ /^Pg/i;
3483   return 'NOT REGEXP' if $driver =~ /^mysql/i;
3484
3485   die "don't know how to use regular expressions in ". driver_name." databases";
3486
3487 }
3488
3489 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3490
3491 Returns the items concatenated based on database type, using "CONCAT()" for
3492 mysql and " || " for Pg and other databases.
3493
3494 You can pass an optional driver name such as "Pg", "mysql" or
3495 $dbh->{Driver}->{Name} to return a function for that database instead of
3496 the current database.
3497
3498 =cut
3499
3500 sub concat_sql {
3501   my $driver = ref($_[0]) ? driver_name : shift;
3502   my $items = shift;
3503
3504   if ( $driver =~ /^mysql/i ) {
3505     'CONCAT('. join(',', @$items). ')';
3506   } else {
3507     join('||', @$items);
3508   }
3509
3510 }
3511
3512 =item midnight_sql DATE
3513
3514 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3515 on that day in the system timezone, using the default driver name.
3516
3517 =cut
3518
3519 sub midnight_sql {
3520   my $driver = driver_name;
3521   my $expr = shift;
3522   if ( $driver =~ /^mysql/i ) {
3523     "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3524   }
3525   else {
3526     "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3527   }
3528 }
3529
3530 =back
3531
3532 =head1 BUGS
3533
3534 This module should probably be renamed, since much of the functionality is
3535 of general use.  It is not completely unlike Adapter::DBI (see below).
3536
3537 Exported qsearch and qsearchs should be deprecated in favor of method calls
3538 (against an FS::Record object like the old search and searchs that qsearch
3539 and qsearchs were on top of.)
3540
3541 The whole fields / hfields mess should be removed.
3542
3543 The various WHERE clauses should be subroutined.
3544
3545 table string should be deprecated in favor of DBIx::DBSchema::Table.
3546
3547 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
3548 true maps to the database (and WHERE clauses) would also help.
3549
3550 The ut_ methods should ask the dbdef for a default length.
3551
3552 ut_sqltype (like ut_varchar) should all be defined
3553
3554 A fallback check method should be provided which uses the dbdef.
3555
3556 The ut_money method assumes money has two decimal digits.
3557
3558 The Pg money kludge in the new method only strips `$'.
3559
3560 The ut_phonen method only checks US-style phone numbers.
3561
3562 The _quote function should probably use ut_float instead of a regex.
3563
3564 All the subroutines probably should be methods, here or elsewhere.
3565
3566 Probably should borrow/use some dbdef methods where appropriate (like sub
3567 fields)
3568
3569 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3570 or allow it to be set.  Working around it is ugly any way around - DBI should
3571 be fixed.  (only affects RDBMS which return uppercase column names)
3572
3573 ut_zip should take an optional country like ut_phone.
3574
3575 =head1 SEE ALSO
3576
3577 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3578
3579 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
3580
3581 http://poop.sf.net/
3582
3583 =cut
3584
3585 1;
3586