FS/FS/Record.pm

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