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