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::Slurp qw( slurp );
  16 use File::CounterFile;
  17 use Text::CSV_XS;
  18 use DBI qw(:sql_types);
  19 use DBIx::DBSchema 0.38;
  20 use Locale::Country;
  21 use Locale::Currency;
  22 use NetAddr::IP; # for validation
  23 use FS::UID qw(dbh datasrc driver_name);
  24 use FS::CurrentUser;
  25 use FS::Schema qw(dbdef);
  26 use FS::SearchCache;
  27 use FS::Msgcat qw(gettext);
  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 '@FS::'. $table . '::encrypted_fields' ) {
 510       foreach my $record (@return) {
 511         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 512           next if $field eq 'payinfo'
 513                     && ($record->isa('FS::payinfo_transaction_Mixin')
 514                         || $record->isa('FS::payinfo_Mixin') )
 515                     && $record->payby
 516                     && !grep { $record->payby eq $_ } @encrypt_payby;
 517           # Set it directly... This may cause a problem in the future...
 518           $record->setfield($field, $record->decrypt($record->getfield($field)));
 519         }
 520       }
 521     }
 522   } else {
 523     cluck "warning: FS::$table not loaded; returning FS::Record objects"
 524       unless $nowarn_classload;
 525     @return = map {
 526       FS::Record->new( $table, { %{$_} } );
 527     } values(%result);
 528   }
 529   return @return;
 530 }
 531
 532 =item _query
 533
 534 Construct the SQL statement and parameter-binding list for qsearch.  Takes
 535 the qsearch parameters.
 536
 537 Returns a hash containing:
 538 'table':      The primary table name (if there is one).
 539 'statement':  The SQL statement itself.
 540 'bind_type':  An arrayref of bind types.
 541 'value':      An arrayref of parameter values.
 542 'cache':      The cache object, if one was passed.
 543
 544 =cut
 545
 546 sub _query {
 547   my( @stable, @record, @cache );
 548   my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
 549   my @debug = ();
 550   my $cursor = '';
 551   my %union_options = ();
 552   if ( ref($_[0]) eq 'ARRAY' ) {
 553     my $optlist = shift;
 554     %union_options = @_;
 555     foreach my $href ( @$optlist ) {
 556       push @stable,      ( $href->{'table'} or die "table name is required" );
 557       push @record,      ( $href->{'hashref'}     || {} );
 558       push @select,      ( $href->{'select'}      || '*' );
 559       push @extra_sql,   ( $href->{'extra_sql'}   || '' );
 560       push @extra_param, ( $href->{'extra_param'} || [] );
 561       push @order_by,    ( $href->{'order_by'}    || '' );
 562       push @cache,       ( $href->{'cache_obj'}   || '' );
 563       push @addl_from,   ( $href->{'addl_from'}   || '' );
 564       push @debug,       ( $href->{'debug'}       || '' );
 565     }
 566     die "at least one hashref is required" unless scalar(@stable);
 567   } elsif ( ref($_[0]) eq 'HASH' ) {
 568     my $opt = shift;
 569     $stable[0]      = $opt->{'table'}       or die "table name is required";
 570     $record[0]      = $opt->{'hashref'}     || {};
 571     $select[0]      = $opt->{'select'}      || '*';
 572     $extra_sql[0]   = $opt->{'extra_sql'}   || '';
 573     $extra_param[0] = $opt->{'extra_param'} || [];
 574     $order_by[0]    = $opt->{'order_by'}    || '';
 575     $cache[0]       = $opt->{'cache_obj'}   || '';
 576     $addl_from[0]   = $opt->{'addl_from'}   || '';
 577     $debug[0]       = $opt->{'debug'}       || '';
 578   } else {
 579     ( $stable[0],
 580       $record[0],
 581       $select[0],
 582       $extra_sql[0],
 583       $cache[0],
 584       $addl_from[0]
 585     ) = @_;
 586     $select[0] ||= '*';
 587   }
 588   my $cache = $cache[0];
 589
 590   my @statement = ();
 591   my @value = ();
 592   my @bind_type = ();
 593
 594   my $result_table = $stable[0];
 595   foreach my $stable ( @stable ) {
 596     #stop altering the caller's hashref
 597     my $record      = { %{ shift(@record) || {} } };#and be liberal in receipt
 598     my $select      = shift @select;
 599     my $extra_sql   = shift @extra_sql;
 600     my $extra_param = shift @extra_param;
 601     my $order_by    = shift @order_by;
 602     my $cache       = shift @cache;
 603     my $addl_from   = shift @addl_from;
 604     my $debug       = shift @debug;
 605
 606     #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
 607     #for jsearch
 608     $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
 609     $stable = $1;
 610
 611     $result_table = '' if $result_table ne $stable;
 612
 613     my $table = $cache ? $cache->table : $stable;
 614     my $dbdef_table = dbdef->table($table)
 615       or die "No schema for table $table found - ".
 616              "do you need to run freeside-upgrade?";
 617     my $pkey = $dbdef_table->primary_key;
 618
 619     my @real_fields = grep exists($record->{$_}), real_fields($table);
 620
 621     my $statement .= "SELECT $select FROM $stable";
 622     $statement .= " $addl_from" if $addl_from;
 623     if ( @real_fields ) {
 624       $statement .= ' WHERE '. join(' AND ',
 625         get_real_fields($table, $record, \@real_fields));
 626     }
 627
 628     $statement .= " $extra_sql" if defined($extra_sql);
 629     $statement .= " $order_by"  if defined($order_by);
 630
 631     push @statement, $statement;
 632
 633     warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
 634
 635
 636     foreach my $field (
 637       grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
 638     ) {
 639
 640       my $value = $record->{$field};
 641       my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
 642       $value = $value->{'value'} if ref($value);
 643       my $type = dbdef->table($table)->column($field)->type;
 644
 645       my $bind_type = _bind_type($type, $value);
 646
 647       #if ( $DEBUG > 2 ) {
 648       #  no strict 'refs';
 649       #  %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
 650       #    unless keys %TYPE;
 651       #  warn "  bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
 652       #}
 653
 654       push @value, $value;
 655       push @bind_type, $bind_type;
 656
 657     }
 658
 659     foreach my $param ( @$extra_param ) {
 660       my $bind_type = { TYPE => SQL_VARCHAR };
 661       my $value = $param;
 662       if ( ref($param) ) {
 663         $value = $param->[0];
 664         my $type = $param->[1];
 665         $bind_type = _bind_type($type, $value);
 666       }
 667       push @value, $value;
 668       push @bind_type, $bind_type;
 669     }
 670   }
 671
 672   my $statement = join( ' ) UNION ( ', @statement );
 673   $statement = "( $statement )" if scalar(@statement) > 1;
 674   $statement .= " $union_options{order_by}" if $union_options{order_by};
 675
 676   return {
 677     statement => $statement,
 678     bind_type => \@bind_type,
 679     value     => \@value,
 680     table     => $result_table,
 681     cache     => $cache,
 682   };
 683 }
 684
 685 # qsearch should eventually use this
 686 sub _from_hashref {
 687   my ($table, $cache, @hashrefs) = @_;
 688   my @return;
 689   # XXX get rid of these string evals at some point
 690   # (when we have time to test it)
 691   # my $class = "FS::$table" if $table;
 692   # if ( $class and $class->isa('FS::Record') )
 693   #   if ( $class->can('new') eq \&new )
 694   #
 695   if ( $table && eval 'scalar(@FS::'. $table. '::ISA);' ) {
 696     if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
 697       #derivied class didn't override new method, so this optimization is safe
 698       if ( $cache ) {
 699         @return = map {
 700           new_or_cached( "FS::$table", { %{$_} }, $cache )
 701         } @hashrefs;
 702       } else {
 703         @return = map {
 704           new( "FS::$table", { %{$_} } )
 705         } @hashrefs;
 706       }
 707     } else {
 708       #okay, its been tested
 709       # warn "untested code (class FS::$table uses custom new method)";
 710       @return = map {
 711         eval 'FS::'. $table. '->new( { %{$_} } )';
 712       } @hashrefs;
 713     }
 714
 715     # Check for encrypted fields and decrypt them.
 716    ## only in the local copy, not the cached object
 717     if ( $conf_encryption
 718          && eval '@FS::'. $table . '::encrypted_fields' ) {
 719       foreach my $record (@return) {
 720         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 721           next if $field eq 'payinfo'
 722                     && ($record->isa('FS::payinfo_transaction_Mixin')
 723                         || $record->isa('FS::payinfo_Mixin') )
 724                     && $record->payby
 725                     && !grep { $record->payby eq $_ } @encrypt_payby;
 726           # Set it directly... This may cause a problem in the future...
 727           $record->setfield($field, $record->decrypt($record->getfield($field)));
 728         }
 729       }
 730     }
 731   } else {
 732     cluck "warning: FS::$table not loaded; returning FS::Record objects"
 733       unless $nowarn_classload;
 734     @return = map {
 735       FS::Record->new( $table, { %{$_} } );
 736     } @hashrefs;
 737   }
 738   return @return;
 739 }
 740
 741 ## makes this easier to read
 742
 743 sub get_real_fields {
 744   my $table = shift;
 745   my $record = shift;
 746   my $real_fields = shift;
 747
 748    ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability
 749       return (
 750       map {
 751
 752       my $op = '=';
 753       my $column = $_;
 754       my $type = dbdef->table($table)->column($column)->type;
 755       my $value = $record->{$column};
 756       $value = $value->{'value'} if ref($value);
 757       if ( ref($record->{$_}) ) {
 758         $op = $record->{$_}{'op'} if $record->{$_}{'op'};
 759         #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
 760         if ( uc($op) eq 'ILIKE' ) {
 761           $op = 'LIKE';
 762           $record->{$_}{'value'} = lc($record->{$_}{'value'});
 763           $column = "LOWER($_)";
 764         }
 765         $record->{$_} = $record->{$_}{'value'}
 766       }
 767
 768       if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
 769         if ( $op eq '=' ) {
 770           if ( driver_name eq 'Pg' ) {
 771             if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
 772               qq-( $column IS NULL )-;
 773             } else {
 774               qq-( $column IS NULL OR $column = '' )-;
 775             }
 776           } else {
 777             qq-( $column IS NULL OR $column = "" )-;
 778           }
 779         } elsif ( $op eq '!=' ) {
 780           if ( driver_name eq 'Pg' ) {
 781             if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
 782               qq-( $column IS NOT NULL )-;
 783             } else {
 784               qq-( $column IS NOT NULL AND $column != '' )-;
 785             }
 786           } else {
 787             qq-( $column IS NOT NULL AND $column != "" )-;
 788           }
 789         } else {
 790           if ( driver_name eq 'Pg' ) {
 791             qq-( $column $op '' )-;
 792           } else {
 793             qq-( $column $op "" )-;
 794           }
 795         }
 796       } elsif ( $op eq '!=' ) {
 797         qq-( $column IS NULL OR $column != ? )-;
 798       #if this needs to be re-enabled, it needs to use a custom op like
 799       #"APPROX=" or something (better name?, not '=', to avoid affecting other
 800       # searches
 801       #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
 802       #  ( "$column <= ?", "$column >= ?" );
 803       } else {
 804         "$column $op ?";
 805       }
 806     } @{ $real_fields } );
 807 }
 808
 809 =item by_key PRIMARY_KEY_VALUE
 810
 811 This is a class method that returns the record with the given primary key
 812 value.  This method is only useful in FS::Record subclasses.  For example:
 813
 814   my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
 815
 816 is equivalent to:
 817
 818   my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
 819
 820 =cut
 821
 822 sub by_key {
 823   my ($class, $pkey_value) = @_;
 824
 825   my $table = $class->table
 826     or croak "No table for $class found";
 827
 828   my $dbdef_table = dbdef->table($table)
 829     or die "No schema for table $table found - ".
 830            "do you need to create it or run dbdef-create?";
 831   my $pkey = $dbdef_table->primary_key
 832     or die "No primary key for table $table";
 833
 834   return qsearchs($table, { $pkey => $pkey_value });
 835 }
 836
 837 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
 838
 839 Experimental JOINed search method.  Using this method, you can execute a
 840 single SELECT spanning multiple tables, and cache the results for subsequent
 841 method calls.  Interface will almost definately change in an incompatible
 842 fashion.
 843
 844 Arguments:
 845
 846 =cut
 847
 848 sub jsearch {
 849   my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
 850   my $cache = FS::SearchCache->new( $ptable, $pkey );
 851   my %saw;
 852   ( $cache,
 853     grep { !$saw{$_->getfield($pkey)}++ }
 854       qsearch($table, $record, $select, $extra_sql, $cache )
 855   );
 856 }
 857
 858 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 859
 860 Same as qsearch, except that if more than one record matches, it B<carp>s but
 861 returns the first.  If this happens, you either made a logic error in asking
 862 for a single item, or your data is corrupted.
 863
 864 =cut
 865
 866 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
 867   my $table = $_[0];
 868   my(@result) = qsearch(@_);
 869   cluck "warning: Multiple records in scalar search ($table)"
 870     if scalar(@result) > 1;
 871   #should warn more vehemently if the search was on a primary key?
 872   scalar(@result) ? ($result[0]) : ();
 873 }
 874
 875 =back
 876
 877 =head1 METHODS
 878
 879 =over 4
 880
 881 =item table
 882
 883 Returns the table name.
 884
 885 =cut
 886
 887 sub table {
 888 #  cluck "warning: FS::Record::table deprecated; supply one in subclass!";
 889   my $self = shift;
 890   $self -> {'Table'};
 891 }
 892
 893 =item dbdef_table
 894
 895 Returns the DBIx::DBSchema::Table object for the table.
 896
 897 =cut
 898
 899 sub dbdef_table {
 900   my($self)=@_;
 901   my($table)=$self->table;
 902   dbdef->table($table);
 903 }
 904
 905 =item primary_key
 906
 907 Returns the primary key for the table.
 908
 909 =cut
 910
 911 sub primary_key {
 912   my $self = shift;
 913   my $pkey = $self->dbdef_table->primary_key;
 914 }
 915
 916 =item get, getfield COLUMN
 917
 918 Returns the value of the column/field/key COLUMN.
 919
 920 =cut
 921
 922 sub get {
 923   my($self,$field) = @_;
 924   # to avoid "Use of unitialized value" errors
 925   if ( defined ( $self->{Hash}->{$field} ) ) {
 926     $self->{Hash}->{$field};
 927   } else {
 928     '';
 929   }
 930 }
 931 sub getfield {
 932   my $self = shift;
 933   $self->get(@_);
 934 }
 935
 936 =item set, setfield COLUMN, VALUE
 937
 938 Sets the value of the column/field/key COLUMN to VALUE.  Returns VALUE.
 939
 940 =cut
 941
 942 sub set {
 943   my($self,$field,$value) = @_;
 944   $self->{'modified'} = 1;
 945   $self->{'Hash'}->{$field} = $value;
 946 }
 947 sub setfield {
 948   my $self = shift;
 949   $self->set(@_);
 950 }
 951
 952 =item exists COLUMN
 953
 954 Returns true if the column/field/key COLUMN exists.
 955
 956 =cut
 957
 958 sub exists {
 959   my($self,$field) = @_;
 960   exists($self->{Hash}->{$field});
 961 }
 962
 963 =item AUTLOADED METHODS
 964
 965 $record->column is a synonym for $record->get('column');
 966
 967 $record->column('value') is a synonym for $record->set('column','value');
 968
 969 =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 use Data::Dumper;
1741 sub batch_import {
1742   my $param = shift;
1743
1744   warn "$me batch_import call with params: \n". Dumper($param)
1745     if $DEBUG;
1746
1747   my $table   = $param->{table};
1748
1749   my $job     = $param->{job};
1750   my $file    = $param->{file};
1751   my $params  = $param->{params} || {};
1752
1753   my( $type, $header, $sep_char,
1754       $fixedlength_format, $xml_format, $asn_format,
1755       $row_callback, @fields );
1756
1757   my $postinsert_callback = '';
1758   $postinsert_callback = $param->{'postinsert_callback'}
1759           if $param->{'postinsert_callback'};
1760   my $preinsert_callback = '';
1761   $preinsert_callback = $param->{'preinsert_callback'}
1762           if $param->{'preinsert_callback'};
1763
1764   if ( $param->{'format'} ) {
1765
1766     my $format  = $param->{'format'};
1767     my $formats = $param->{formats};
1768     die "unknown format $format" unless exists $formats->{ $format };
1769
1770     $type = $param->{'format_types'}
1771             ? $param->{'format_types'}{ $format }
1772             : $param->{type} || 'csv';
1773
1774
1775     $header = $param->{'format_headers'}
1776                ? $param->{'format_headers'}{ $param->{'format'} }
1777                : 0;
1778
1779     $sep_char = $param->{'format_sep_chars'}
1780                   ? $param->{'format_sep_chars'}{ $param->{'format'} }
1781                   : ',';
1782
1783     $fixedlength_format =
1784       $param->{'format_fixedlength_formats'}
1785         ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1786         : '';
1787
1788     $xml_format =
1789       $param->{'format_xml_formats'}
1790         ? $param->{'format_xml_formats'}{ $param->{'format'} }
1791         : '';
1792
1793     $asn_format =
1794       $param->{'format_asn_formats'}
1795         ? $param->{'format_asn_formats'}{ $param->{'format'} }
1796         : '';
1797
1798     $row_callback =
1799       $param->{'format_row_callbacks'}
1800         ? $param->{'format_row_callbacks'}{ $param->{'format'} }
1801         : '';
1802
1803     @fields = @{ $formats->{ $format } };
1804
1805   } elsif ( $param->{'fields'} ) {
1806
1807     $type = ''; #infer from filename
1808     $header = 0;
1809     $sep_char = ',';
1810     $fixedlength_format = '';
1811     $row_callback = '';
1812     @fields = @{ $param->{'fields'} };
1813
1814   } else {
1815     die "neither format nor fields specified";
1816   }
1817
1818   #my $file    = $param->{file};
1819
1820   unless ( $type ) {
1821     if ( $file =~ /\.(\w+)$/i ) {
1822       $type = lc($1);
1823     } else {
1824       #or error out???
1825       warn "can't parse file type from filename $file; defaulting to CSV";
1826       $type = 'csv';
1827     }
1828     $type = 'csv'
1829       if $param->{'default_csv'} && $type ne 'xls';
1830   }
1831
1832
1833   my $row = 0;
1834   my $count;
1835   my $parser;
1836   my @buffer = ();
1837   my $asn_header_buffer;
1838   if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1839
1840     if ( $type eq 'csv' ) {
1841
1842       my %attr = ( 'binary' => 1, );
1843       $attr{sep_char} = $sep_char if $sep_char;
1844       $parser = new Text::CSV_XS \%attr;
1845
1846     } elsif ( $type eq 'fixedlength' ) {
1847
1848       eval "use Parse::FixedLength;";
1849       die $@ if $@;
1850       $parser = Parse::FixedLength->new($fixedlength_format);
1851
1852     }
1853     else {
1854       die "Unknown file type $type\n";
1855     }
1856
1857     @buffer = split(/\r?\n/, slurp($file) );
1858     splice(@buffer, 0, ($header || 0) );
1859     $count = scalar(@buffer);
1860
1861   } elsif ( $type eq 'xls' ) {
1862
1863     eval "use Spreadsheet::ParseExcel;";
1864     die $@ if $@;
1865
1866     eval "use DateTime::Format::Excel;";
1867     #for now, just let the error be thrown if it is used, since only CDR
1868     # formats bill_west and troop use it, not other excel-parsing things
1869     #die $@ if $@;
1870
1871     my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
1872
1873     $parser = $excel->{Worksheet}[0]; #first sheet
1874
1875     $count = $parser->{MaxRow} || $parser->{MinRow};
1876     $count++;
1877
1878     $row = $header || 0;
1879
1880   } elsif ( $type eq 'xml' ) {
1881
1882     # FS::pay_batch
1883     eval "use XML::Simple;";
1884     die $@ if $@;
1885     my $xmlrow = $xml_format->{'xmlrow'};
1886     $parser = $xml_format->{'xmlkeys'};
1887     die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
1888     my $data = XML::Simple::XMLin(
1889       $file,
1890       'SuppressEmpty' => '', #sets empty values to ''
1891       'KeepRoot'      => 1,
1892     );
1893     my $rows = $data;
1894     $rows = $rows->{$_} foreach @$xmlrow;
1895     $rows = [ $rows ] if ref($rows) ne 'ARRAY';
1896     $count = @buffer = @$rows;
1897
1898   } elsif ( $type eq 'asn.1' ) {
1899
1900     eval "use Convert::ASN1";
1901     die $@ if $@;
1902
1903     my $asn = Convert::ASN1->new;
1904     $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
1905
1906     $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
1907
1908     my $data = slurp($file);
1909     my $asn_output = $parser->decode( $data )
1910       or return "No ". $asn_format->{'macro'}. " found\n";
1911
1912     $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
1913
1914     my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
1915     $count = @buffer = @$rows;
1916
1917   } else {
1918     die "Unknown file type $type\n";
1919   }
1920
1921   #my $columns;
1922
1923   local $SIG{HUP} = 'IGNORE';
1924   local $SIG{INT} = 'IGNORE';
1925   local $SIG{QUIT} = 'IGNORE';
1926   local $SIG{TERM} = 'IGNORE';
1927   local $SIG{TSTP} = 'IGNORE';
1928   local $SIG{PIPE} = 'IGNORE';
1929
1930   my $oldAutoCommit = $FS::UID::AutoCommit;
1931   local $FS::UID::AutoCommit = 0;
1932   my $dbh = dbh;
1933
1934   #my $params  = $param->{params} || {};
1935   if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
1936     my $batch_col   = $param->{'batch_keycol'};
1937
1938     my $batch_class = 'FS::'. $param->{'batch_table'};
1939     my $batch = $batch_class->new({
1940       $param->{'batch_namecol'} => $param->{'batch_namevalue'}
1941     });
1942     my $error = $batch->insert;
1943     if ( $error ) {
1944       $dbh->rollback if $oldAutoCommit;
1945       return "can't insert batch record: $error";
1946     }
1947     #primary key via dbdef? (so the column names don't have to match)
1948     my $batch_value = $batch->get( $param->{'batch_keycol'} );
1949
1950     $params->{ $batch_col } = $batch_value;
1951   }
1952
1953   #my $job     = $param->{job};
1954   my $line;
1955   my $imported = 0;
1956   my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
1957   while (1) {
1958
1959     my @columns = ();
1960     my %hash = %$params;
1961     if ( $type eq 'csv' ) {
1962
1963       last unless scalar(@buffer);
1964       $line = shift(@buffer);
1965
1966       next if $line =~ /^\s*$/; #skip empty lines
1967
1968       $line = &{$row_callback}($line) if $row_callback;
1969
1970       next if $line =~ /^\s*$/; #skip empty lines
1971
1972       $parser->parse($line) or do {
1973         $dbh->rollback if $oldAutoCommit;
1974         return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
1975       };
1976       @columns = $parser->fields();
1977
1978     } elsif ( $type eq 'fixedlength' ) {
1979
1980       last unless scalar(@buffer);
1981       $line = shift(@buffer);
1982
1983       @columns = $parser->parse($line);
1984
1985     } elsif ( $type eq 'xls' ) {
1986
1987       last if $row > ($parser->{MaxRow} || $parser->{MinRow})
1988            || ! $parser->{Cells}[$row];
1989
1990       my @row = @{ $parser->{Cells}[$row] };
1991       @columns = map $_->{Val}, @row;
1992
1993       #my $z = 'A';
1994       #warn $z++. ": $_\n" for @columns;
1995
1996     } elsif ( $type eq 'xml' ) {
1997
1998       # $parser = [ 'Column0Key', 'Column1Key' ... ]
1999       last unless scalar(@buffer);
2000       my $row = shift @buffer;
2001       @columns = @{ $row }{ @$parser };
2002
2003     } elsif ( $type eq 'asn.1' ) {
2004
2005       last unless scalar(@buffer);
2006       my $row = shift @buffer;
2007       &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2008         if $asn_format->{row_callback};
2009       foreach my $key ( keys %{ $asn_format->{map} } ) {
2010         $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2011       }
2012
2013     } else {
2014       die "Unknown file type $type\n";
2015     }
2016
2017     my @later = ();
2018
2019     foreach my $field ( @fields ) {
2020
2021       my $value = shift @columns;
2022
2023       if ( ref($field) eq 'CODE' ) {
2024         #&{$field}(\%hash, $value);
2025         push @later, $field, $value;
2026       } else {
2027         #??? $hash{$field} = $value if length($value);
2028         $hash{$field} = $value if defined($value) && length($value);
2029       }
2030
2031     }
2032
2033     #my $table   = $param->{table};
2034     my $class = "FS::$table";
2035
2036     my $record = $class->new( \%hash );
2037
2038     my $param = {};
2039     while ( scalar(@later) ) {
2040       my $sub = shift @later;
2041       my $data = shift @later;
2042       eval {
2043         &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2044       };
2045       if ( $@ ) {
2046         $dbh->rollback if $oldAutoCommit;
2047         return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2048       }
2049       last if exists( $param->{skiprow} );
2050     }
2051     next if exists( $param->{skiprow} );
2052
2053     if ( $preinsert_callback ) {
2054       my $error = &{$preinsert_callback}($record, $param);
2055       if ( $error ) {
2056         $dbh->rollback if $oldAutoCommit;
2057         return "preinsert_callback error". ( $line ? " for $line" : '' ).
2058                ": $error";
2059       }
2060       next if exists $param->{skiprow} && $param->{skiprow};
2061     }
2062
2063     my $error = $record->insert;
2064
2065     if ( $error ) {
2066       $dbh->rollback if $oldAutoCommit;
2067       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2068     }
2069
2070     $row++;
2071     $imported++;
2072
2073     if ( $postinsert_callback ) {
2074       my $error = &{$postinsert_callback}($record, $param);
2075       if ( $error ) {
2076         $dbh->rollback if $oldAutoCommit;
2077         return "postinsert_callback error". ( $line ? " for $line" : '' ).
2078                ": $error";
2079       }
2080     }
2081
2082     if ( $job && time - $min_sec > $last ) { #progress bar
2083       $job->update_statustext( int(100 * $imported / $count) );
2084       $last = time;
2085     }
2086
2087   }
2088
2089   unless ( $imported || $param->{empty_ok} ) {
2090     $dbh->rollback if $oldAutoCommit;
2091     return "Empty file!";
2092   }
2093
2094   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2095
2096   ''; #no error
2097
2098 }
2099
2100 sub _h_statement {
2101   my( $self, $action, $time ) = @_;
2102
2103   $time ||= time;
2104
2105   my %nohistory = map { $_=>1 } $self->nohistory_fields;
2106
2107   my @fields =
2108     grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2109     real_fields($self->table);
2110   ;
2111
2112   # If we're encrypting then don't store the payinfo in the history
2113   if ( $conf && $conf->exists('encryption') && $self->table ne 'banned_pay' ) {
2114     @fields = grep { $_ ne 'payinfo' } @fields;
2115   }
2116
2117   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2118
2119   "INSERT INTO h_". $self->table. " ( ".
2120       join(', ', qw(history_date history_usernum history_action), @fields ).
2121     ") VALUES (".
2122       join(', ', $time,
2123                  $FS::CurrentUser::CurrentUser->usernum,
2124                  dbh->quote($action),
2125                  @values
2126       ).
2127     ")"
2128   ;
2129 }
2130
2131 =item unique COLUMN
2132
2133 B<Warning>: External use is B<deprecated>.
2134
2135 Replaces COLUMN in record with a unique number, using counters in the
2136 filesystem.  Used by the B<insert> method on single-field unique columns
2137 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2138 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2139
2140 Returns the new value.
2141
2142 =cut
2143
2144 sub unique {
2145   my($self,$field) = @_;
2146   my($table)=$self->table;
2147
2148   croak "Unique called on field $field, but it is ",
2149         $self->getfield($field),
2150         ", not null!"
2151     if $self->getfield($field);
2152
2153   #warn "table $table is tainted" if is_tainted($table);
2154   #warn "field $field is tainted" if is_tainted($field);
2155
2156   my($counter) = new File::CounterFile "$table.$field",0;
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_currencyn COLUMN
2343
2344 Check/untaint currency indicators, such as USD or EUR.  May be null.  If there
2345 is an error, returns the error, otherwise returns false.
2346
2347 =cut
2348
2349 sub ut_currencyn {
2350   my($self, $field) = @_;
2351   if ($self->getfield($field) eq '') { #can be null
2352     $self->setfield($field, '');
2353     return '';
2354   }
2355   $self->ut_currency($field);
2356 }
2357
2358 =item ut_currency COLUMN
2359
2360 Check/untaint currency indicators, such as USD or EUR.  May not be null.  If
2361 there is an error, returns the error, otherwise returns false.
2362
2363 =cut
2364
2365 sub ut_currency {
2366   my($self, $field) = @_;
2367   my $value = uc( $self->getfield($field) );
2368   if ( code2currency($value) ) {
2369     $self->setfield($value);
2370   } else {
2371     return "Unknown currency $value";
2372   }
2373
2374   '';
2375 }
2376
2377 =item ut_text COLUMN
2378
2379 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2380 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2381 May not be null.  If there is an error, returns the error, otherwise returns
2382 false.
2383
2384 =cut
2385
2386 sub ut_text {
2387   my($self,$field)=@_;
2388   #warn "msgcat ". \&msgcat. "\n";
2389   #warn "notexist ". \&notexist. "\n";
2390   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2391   $self->getfield($field)
2392     =~ /^([\wô \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
2393       or return gettext('illegal_or_empty_text'). " $field: ".
2394                  $self->getfield($field);
2395   $self->setfield($field,$1);
2396   '';
2397 }
2398
2399 =item ut_textn COLUMN
2400
2401 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2402 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2403 May be null.  If there is an error, returns the error, otherwise returns false.
2404
2405 =cut
2406
2407 sub ut_textn {
2408   my($self,$field)=@_;
2409   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2410   $self->ut_text($field);
2411 }
2412
2413 =item ut_alpha COLUMN
2414
2415 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
2416 an error, returns the error, otherwise returns false.
2417
2418 =cut
2419
2420 sub ut_alpha {
2421   my($self,$field)=@_;
2422   $self->getfield($field) =~ /^(\w+)$/
2423     or return "Illegal or empty (alphanumeric) $field: ".
2424               $self->getfield($field);
2425   $self->setfield($field,$1);
2426   '';
2427 }
2428
2429 =item ut_alphan COLUMN
2430
2431 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
2432 error, returns the error, otherwise returns false.
2433
2434 =cut
2435
2436 sub ut_alphan {
2437   my($self,$field)=@_;
2438   $self->getfield($field) =~ /^(\w*)$/
2439     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2440   $self->setfield($field,$1);
2441   '';
2442 }
2443
2444 =item ut_alphasn COLUMN
2445
2446 Check/untaint alphanumeric strings, spaces allowed.  May be null.  If there is
2447 an error, returns the error, otherwise returns false.
2448
2449 =cut
2450
2451 sub ut_alphasn {
2452   my($self,$field)=@_;
2453   $self->getfield($field) =~ /^([\w ]*)$/
2454     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2455   $self->setfield($field,$1);
2456   '';
2457 }
2458
2459
2460 =item ut_alpha_lower COLUMN
2461
2462 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
2463 there is an error, returns the error, otherwise returns false.
2464
2465 =cut
2466
2467 sub ut_alpha_lower {
2468   my($self,$field)=@_;
2469   $self->getfield($field) =~ /[[:upper:]]/
2470     and return "Uppercase characters are not permitted in $field";
2471   $self->ut_alpha($field);
2472 }
2473
2474 =item ut_phonen COLUMN [ COUNTRY ]
2475
2476 Check/untaint phone numbers.  May be null.  If there is an error, returns
2477 the error, otherwise returns false.
2478
2479 Takes an optional two-letter ISO country code; without it or with unsupported
2480 countries, ut_phonen simply calls ut_alphan.
2481
2482 =cut
2483
2484 sub ut_phonen {
2485   my( $self, $field, $country ) = @_;
2486   return $self->ut_alphan($field) unless defined $country;
2487   my $phonen = $self->getfield($field);
2488   if ( $phonen eq '' ) {
2489     $self->setfield($field,'');
2490   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2491     $phonen =~ s/\D//g;
2492     $phonen = $conf->config('cust_main-default_areacode').$phonen
2493       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2494     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2495       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2496     $phonen = "$1-$2-$3";
2497     $phonen .= " x$4" if $4;
2498     $self->setfield($field,$phonen);
2499   } else {
2500     warn "warning: don't know how to check phone numbers for country $country";
2501     return $self->ut_textn($field);
2502   }
2503   '';
2504 }
2505
2506 =item ut_hex COLUMN
2507
2508 Check/untaint hexadecimal values.
2509
2510 =cut
2511
2512 sub ut_hex {
2513   my($self, $field) = @_;
2514   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2515     or return "Illegal (hex) $field: ". $self->getfield($field);
2516   $self->setfield($field, uc($1));
2517   '';
2518 }
2519
2520 =item ut_hexn COLUMN
2521
2522 Check/untaint hexadecimal values.  May be null.
2523
2524 =cut
2525
2526 sub ut_hexn {
2527   my($self, $field) = @_;
2528   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2529     or return "Illegal (hex) $field: ". $self->getfield($field);
2530   $self->setfield($field, uc($1));
2531   '';
2532 }
2533
2534 =item ut_mac_addr COLUMN
2535
2536 Check/untaint mac addresses.  May be null.
2537
2538 =cut
2539
2540 sub ut_mac_addr {
2541   my($self, $field) = @_;
2542
2543   my $mac = $self->get($field);
2544   $mac =~ s/\s+//g;
2545   $mac =~ s/://g;
2546   $self->set($field, $mac);
2547
2548   my $e = $self->ut_hex($field);
2549   return $e if $e;
2550
2551   return "Illegal (mac address) $field: ". $self->getfield($field)
2552     unless length($self->getfield($field)) == 12;
2553
2554   '';
2555
2556 }
2557
2558 =item ut_mac_addrn COLUMN
2559
2560 Check/untaint mac addresses.  May be null.
2561
2562 =cut
2563
2564 sub ut_mac_addrn {
2565   my($self, $field) = @_;
2566   ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2567 }
2568
2569 =item ut_ip COLUMN
2570
2571 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2572 to 127.0.0.1.
2573
2574 =cut
2575
2576 sub ut_ip {
2577   my( $self, $field ) = @_;
2578   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2579   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2580     or return "Illegal (IP address) $field: ". $self->getfield($field);
2581   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2582   $self->setfield($field, "$1.$2.$3.$4");
2583   '';
2584 }
2585
2586 =item ut_ipn COLUMN
2587
2588 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2589 to 127.0.0.1.  May be null.
2590
2591 =cut
2592
2593 sub ut_ipn {
2594   my( $self, $field ) = @_;
2595   if ( $self->getfield($field) =~ /^()$/ ) {
2596     $self->setfield($field,'');
2597     '';
2598   } else {
2599     $self->ut_ip($field);
2600   }
2601 }
2602
2603 =item ut_ip46 COLUMN
2604
2605 Check/untaint IPv4 or IPv6 address.
2606
2607 =cut
2608
2609 sub ut_ip46 {
2610   my( $self, $field ) = @_;
2611   my $ip = NetAddr::IP->new($self->getfield($field))
2612     or return "Illegal (IP address) $field: ".$self->getfield($field);
2613   $self->setfield($field, lc($ip->addr));
2614   return '';
2615 }
2616
2617 =item ut_ip46n
2618
2619 Check/untaint IPv6 or IPv6 address.  May be null.
2620
2621 =cut
2622
2623 sub ut_ip46n {
2624   my( $self, $field ) = @_;
2625   if ( $self->getfield($field) =~ /^$/ ) {
2626     $self->setfield($field, '');
2627     return '';
2628   }
2629   $self->ut_ip46($field);
2630 }
2631
2632 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2633
2634 Check/untaint coordinates.
2635 Accepts the following forms:
2636 DDD.DDDDD
2637 -DDD.DDDDD
2638 DDD MM.MMM
2639 -DDD MM.MMM
2640 DDD MM SS
2641 -DDD MM SS
2642 DDD MM MMM
2643 -DDD MM MMM
2644
2645 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2646 The latter form (that is, the MMM are thousands of minutes) is
2647 assumed if the "MMM" is exactly three digits or two digits > 59.
2648
2649 To be safe, just use the DDD.DDDDD form.
2650
2651 If LOWER or UPPER are specified, then the coordinate is checked
2652 for lower and upper bounds, respectively.
2653
2654 =cut
2655
2656 sub ut_coord {
2657   my ($self, $field) = (shift, shift);
2658
2659   my($lower, $upper);
2660   if ( $field =~ /latitude/ ) {
2661     $lower = $lat_lower;
2662     $upper = 90;
2663   } elsif ( $field =~ /longitude/ ) {
2664     $lower = -180;
2665     $upper = $lon_upper;
2666   }
2667
2668   my $coord = $self->getfield($field);
2669   my $neg = $coord =~ s/^(-)//;
2670
2671   my ($d, $m, $s) = (0, 0, 0);
2672
2673   if (
2674     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2675     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2676     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2677   ) {
2678     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2679     $m = $m / 60;
2680     if ($m > 59) {
2681       return "Invalid (coordinate with minutes > 59) $field: "
2682              . $self->getfield($field);
2683     }
2684
2685     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2686
2687     if (defined($lower) and ($coord < $lower)) {
2688       return "Invalid (coordinate < $lower) $field: "
2689              . $self->getfield($field);;
2690     }
2691
2692     if (defined($upper) and ($coord > $upper)) {
2693       return "Invalid (coordinate > $upper) $field: "
2694              . $self->getfield($field);;
2695     }
2696
2697     $self->setfield($field, $coord);
2698     return '';
2699   }
2700
2701   return "Invalid (coordinate) $field: " . $self->getfield($field);
2702
2703 }
2704
2705 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2706
2707 Same as ut_coord, except optionally null.
2708
2709 =cut
2710
2711 sub ut_coordn {
2712
2713   my ($self, $field) = (shift, shift);
2714
2715   if ($self->getfield($field) =~ /^\s*$/) {
2716     return '';
2717   } else {
2718     return $self->ut_coord($field, @_);
2719   }
2720
2721 }
2722
2723 =item ut_domain COLUMN
2724
2725 Check/untaint host and domain names.  May not be null.
2726
2727 =cut
2728
2729 sub ut_domain {
2730   my( $self, $field ) = @_;
2731   #$self->getfield($field) =~/^(\w+\.)*\w+$/
2732   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2733     or return "Illegal (hostname) $field: ". $self->getfield($field);
2734   $self->setfield($field,$1);
2735   '';
2736 }
2737
2738 =item ut_domainn COLUMN
2739
2740 Check/untaint host and domain names.  May be null.
2741
2742 =cut
2743
2744 sub ut_domainn {
2745   my( $self, $field ) = @_;
2746   if ( $self->getfield($field) =~ /^()$/ ) {
2747     $self->setfield($field,'');
2748     '';
2749   } else {
2750     $self->ut_domain($field);
2751   }
2752 }
2753
2754 =item ut_name COLUMN
2755
2756 Check/untaint proper names; allows alphanumerics, spaces and the following
2757 punctuation: , . - '
2758
2759 May not be null.
2760
2761 =cut
2762
2763 sub ut_name {
2764   my( $self, $field ) = @_;
2765 #  warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
2766   $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
2767     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2768   my $name = $1;
2769   $name =~ s/^\s+//;
2770   $name =~ s/\s+$//;
2771   $name =~ s/\s+/ /g;
2772   $self->setfield($field, $name);
2773   '';
2774 }
2775
2776 =item ut_namen COLUMN
2777
2778 Check/untaint proper names; allows alphanumerics, spaces and the following
2779 punctuation: , . - '
2780
2781 May not be null.
2782
2783 =cut
2784
2785 sub ut_namen {
2786   my( $self, $field ) = @_;
2787   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2788   $self->ut_name($field);
2789 }
2790
2791 =item ut_zip COLUMN
2792
2793 Check/untaint zip codes.
2794
2795 =cut
2796
2797 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2798
2799 sub ut_zip {
2800   my( $self, $field, $country ) = @_;
2801
2802   if ( $country eq 'US' ) {
2803
2804     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2805       or return gettext('illegal_zip'). " $field for country $country: ".
2806                 $self->getfield($field);
2807     $self->setfield($field, $1);
2808
2809   } elsif ( $country eq 'CA' ) {
2810
2811     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2812       or return gettext('illegal_zip'). " $field for country $country: ".
2813                 $self->getfield($field);
2814     $self->setfield($field, "$1 $2");
2815
2816   } else {
2817
2818     if ( $self->getfield($field) =~ /^\s*$/
2819          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2820        )
2821     {
2822       $self->setfield($field,'');
2823     } else {
2824       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
2825         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2826       $self->setfield($field,$1);
2827     }
2828
2829   }
2830
2831   '';
2832 }
2833
2834 =item ut_country COLUMN
2835
2836 Check/untaint country codes.  Country names are changed to codes, if possible -
2837 see L<Locale::Country>.
2838
2839 =cut
2840
2841 sub ut_country {
2842   my( $self, $field ) = @_;
2843   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2844     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2845          && country2code($1) ) {
2846       $self->setfield($field,uc(country2code($1)));
2847     }
2848   }
2849   $self->getfield($field) =~ /^(\w\w)$/
2850     or return "Illegal (country) $field: ". $self->getfield($field);
2851   $self->setfield($field,uc($1));
2852   '';
2853 }
2854
2855 =item ut_anything COLUMN
2856
2857 Untaints arbitrary data.  Be careful.
2858
2859 =cut
2860
2861 sub ut_anything {
2862   my( $self, $field ) = @_;
2863   $self->getfield($field) =~ /^(.*)$/s
2864     or return "Illegal $field: ". $self->getfield($field);
2865   $self->setfield($field,$1);
2866   '';
2867 }
2868
2869 =item ut_enum COLUMN CHOICES_ARRAYREF
2870
2871 Check/untaint a column, supplying all possible choices, like the "enum" type.
2872
2873 =cut
2874
2875 sub ut_enum {
2876   my( $self, $field, $choices ) = @_;
2877   foreach my $choice ( @$choices ) {
2878     if ( $self->getfield($field) eq $choice ) {
2879       $self->setfield($field, $choice);
2880       return '';
2881     }
2882   }
2883   return "Illegal (enum) field $field: ". $self->getfield($field);
2884 }
2885
2886 =item ut_enumn COLUMN CHOICES_ARRAYREF
2887
2888 Like ut_enum, except the null value is also allowed.
2889
2890 =cut
2891
2892 sub ut_enumn {
2893   my( $self, $field, $choices ) = @_;
2894   $self->getfield($field)
2895     ? $self->ut_enum($field, $choices)
2896     : '';
2897 }
2898
2899 =item ut_flag COLUMN
2900
2901 Check/untaint a column if it contains either an empty string or 'Y'.  This
2902 is the standard form for boolean flags in Freeside.
2903
2904 =cut
2905
2906 sub ut_flag {
2907   my( $self, $field ) = @_;
2908   my $value = uc($self->getfield($field));
2909   if ( $value eq '' or $value eq 'Y' ) {
2910     $self->setfield($field, $value);
2911     return '';
2912   }
2913   return "Illegal (flag) field $field: $value";
2914 }
2915
2916 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2917
2918 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
2919 on the column first.
2920
2921 =cut
2922
2923 sub ut_foreign_key {
2924   my( $self, $field, $table, $foreign ) = @_;
2925   return '' if $no_check_foreign;
2926   qsearchs($table, { $foreign => $self->getfield($field) })
2927     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
2928               " in $table.$foreign";
2929   '';
2930 }
2931
2932 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2933
2934 Like ut_foreign_key, except the null value is also allowed.
2935
2936 =cut
2937
2938 sub ut_foreign_keyn {
2939   my( $self, $field, $table, $foreign ) = @_;
2940   $self->getfield($field)
2941     ? $self->ut_foreign_key($field, $table, $foreign)
2942     : '';
2943 }
2944
2945 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
2946
2947 Checks this column as an agentnum, taking into account the current users's
2948 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
2949 right or rights allowing no agentnum.
2950
2951 =cut
2952
2953 sub ut_agentnum_acl {
2954   my( $self, $field ) = (shift, shift);
2955   my $null_acl = scalar(@_) ? shift : [];
2956   $null_acl = [ $null_acl ] unless ref($null_acl);
2957
2958   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
2959   return "Illegal agentnum: $error" if $error;
2960
2961   my $curuser = $FS::CurrentUser::CurrentUser;
2962
2963   if ( $self->$field() ) {
2964
2965     return "Access denied"
2966       unless $curuser->agentnum($self->$field());
2967
2968   } else {
2969
2970     return "Access denied"
2971       unless grep $curuser->access_right($_), @$null_acl;
2972
2973   }
2974
2975   '';
2976
2977 }
2978
2979 =item fields [ TABLE ]
2980
2981 This is a wrapper for real_fields.  Code that called
2982 fields before should probably continue to call fields.
2983
2984 =cut
2985
2986 sub fields {
2987   my $something = shift;
2988   my $table;
2989   if($something->isa('FS::Record')) {
2990     $table = $something->table;
2991   } else {
2992     $table = $something;
2993     $something = "FS::$table";
2994   }
2995   return (real_fields($table));
2996 }
2997
2998
2999 =item encrypt($value)
3000
3001 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
3002
3003 Returns the encrypted string.
3004
3005 You should generally not have to worry about calling this, as the system handles this for you.
3006
3007 =cut
3008
3009 sub encrypt {
3010   my ($self, $value) = @_;
3011   my $encrypted;
3012
3013   if ($conf->exists('encryption')) {
3014     if ($self->is_encrypted($value)) {
3015       # Return the original value if it isn't plaintext.
3016       $encrypted = $value;
3017     } else {
3018       $self->loadRSA;
3019       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
3020         # RSA doesn't like the empty string so let's pack it up
3021         # The database doesn't like the RSA data so uuencode it
3022         my $length = length($value)+1;
3023         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
3024       } else {
3025         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
3026       }
3027     }
3028   }
3029   return $encrypted;
3030 }
3031
3032 =item is_encrypted($value)
3033
3034 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
3035
3036 =cut
3037
3038
3039 sub is_encrypted {
3040   my ($self, $value) = @_;
3041   # Possible Bug - Some work may be required here....
3042
3043   if ($value =~ /^M/ && length($value) > 80) {
3044     return 1;
3045   } else {
3046     return 0;
3047   }
3048 }
3049
3050 =item decrypt($value)
3051
3052 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
3053
3054 You should generally not have to worry about calling this, as the system handles this for you.
3055
3056 =cut
3057
3058 sub decrypt {
3059   my ($self,$value) = @_;
3060   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
3061   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
3062     $self->loadRSA;
3063     if (ref($rsa_decrypt) =~ /::RSA/) {
3064       my $encrypted = unpack ("u*", $value);
3065       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
3066       if ($@) {warn "Decryption Failed"};
3067     }
3068   }
3069   return $decrypted;
3070 }
3071
3072 sub loadRSA {
3073     my $self = shift;
3074     #Initialize the Module
3075     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
3076
3077     if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
3078       $rsa_module = $conf->config('encryptionmodule');
3079     }
3080
3081     if (!$rsa_loaded) {
3082         eval ("require $rsa_module"); # No need to import the namespace
3083         $rsa_loaded++;
3084     }
3085     # Initialize Encryption
3086     if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
3087       my $public_key = join("\n",$conf->config('encryptionpublickey'));
3088       $rsa_encrypt = $rsa_module->new_public_key($public_key);
3089     }
3090
3091     # Intitalize Decryption
3092     if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
3093       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
3094       $rsa_decrypt = $rsa_module->new_private_key($private_key);
3095     }
3096 }
3097
3098 =item h_search ACTION
3099
3100 Given an ACTION, either "insert", or "delete", returns the appropriate history
3101 record corresponding to this record, if any.
3102
3103 =cut
3104
3105 sub h_search {
3106   my( $self, $action ) = @_;
3107
3108   my $table = $self->table;
3109   $table =~ s/^h_//;
3110
3111   my $primary_key = dbdef->table($table)->primary_key;
3112
3113   qsearchs({
3114     'table'   => "h_$table",
3115     'hashref' => { $primary_key     => $self->$primary_key(),
3116                    'history_action' => $action,
3117                  },
3118   });
3119
3120 }
3121
3122 =item h_date ACTION
3123
3124 Given an ACTION, either "insert", or "delete", returns the timestamp of the
3125 appropriate history record corresponding to this record, if any.
3126
3127 =cut
3128
3129 sub h_date {
3130   my($self, $action) = @_;
3131   my $h = $self->h_search($action);
3132   $h ? $h->history_date : '';
3133 }
3134
3135 =item scalar_sql SQL [ PLACEHOLDER, ... ]
3136
3137 A class or object method.  Executes the sql statement represented by SQL and
3138 returns a scalar representing the result: the first column of the first row.
3139
3140 Dies on bogus SQL.  Returns an empty string if no row is returned.
3141
3142 Typically used for statments which return a single value such as "SELECT
3143 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
3144
3145 =cut
3146
3147 sub scalar_sql {
3148   my($self, $sql) = (shift, shift);
3149   my $sth = dbh->prepare($sql) or die dbh->errstr;
3150   $sth->execute(@_)
3151     or die "Unexpected error executing statement $sql: ". $sth->errstr;
3152   my $row = $sth->fetchrow_arrayref or return '';
3153   my $scalar = $row->[0];
3154   defined($scalar) ? $scalar : '';
3155 }
3156
3157 =item count [ WHERE ]
3158
3159 Convenience method for the common case of "SELECT COUNT(*) FROM table",
3160 with optional WHERE.  Must be called as method on a class with an
3161 associated table.
3162
3163 =cut
3164
3165 sub count {
3166   my($self, $where) = (shift, shift);
3167   my $table = $self->table or die 'count called on object of class '.ref($self);
3168   my $sql = "SELECT COUNT(*) FROM $table";
3169   $sql .= " WHERE $where" if $where;
3170   $self->scalar_sql($sql);
3171 }
3172
3173 =back
3174
3175 =head1 SUBROUTINES
3176
3177 =over 4
3178
3179 =item real_fields [ TABLE ]
3180
3181 Returns a list of the real columns in the specified table.  Called only by
3182 fields() and other subroutines elsewhere in FS::Record.
3183
3184 =cut
3185
3186 sub real_fields {
3187   my $table = shift;
3188
3189   my($table_obj) = dbdef->table($table);
3190   confess "Unknown table $table" unless $table_obj;
3191   $table_obj->columns;
3192 }
3193
3194 =item pvf FIELD_NAME
3195
3196 Returns the FS::part_virtual_field object corresponding to a field in the
3197 record (specified by FIELD_NAME).
3198
3199 =cut
3200
3201 sub pvf {
3202   my ($self, $name) = (shift, shift);
3203
3204   if(grep /^$name$/, $self->virtual_fields) {
3205     $name =~ s/^cf_//;
3206     my $concat = [ "'cf_'", "name" ];
3207     return qsearchs({   table   =>  'part_virtual_field',
3208                         hashref =>  { dbtable => $self->table,
3209                                       name    => $name
3210                                     },
3211                         select  =>  'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
3212                     });
3213   }
3214   ''
3215 }
3216
3217 =item _quote VALUE, TABLE, COLUMN
3218
3219 This is an internal function used to construct SQL statements.  It returns
3220 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3221 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3222
3223 =cut
3224
3225 sub _quote {
3226   my($value, $table, $column) = @_;
3227   my $column_obj = dbdef->table($table)->column($column);
3228   my $column_type = $column_obj->type;
3229   my $nullable = $column_obj->null;
3230
3231   warn "  $table.$column: $value ($column_type".
3232        ( $nullable ? ' NULL' : ' NOT NULL' ).
3233        ")\n" if $DEBUG > 2;
3234
3235   if ( $value eq '' && $nullable ) {
3236     'NULL';
3237   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3238     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3239           "using 0 instead";
3240     0;
3241   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3242             ! $column_type =~ /(char|binary|text)$/i ) {
3243     $value;
3244   } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3245            && driver_name eq 'Pg'
3246           )
3247   {
3248     no strict 'subs';
3249 #    dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right
3250     # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\,
3251     # single-quote the whole mess, and put an "E" in front.
3252     return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'");
3253   } else {
3254     dbh->quote($value);
3255   }
3256 }
3257
3258 =item hfields TABLE
3259
3260 This is deprecated.  Don't use it.
3261
3262 It returns a hash-type list with the fields of this record's table set true.
3263
3264 =cut
3265
3266 sub hfields {
3267   carp "warning: hfields is deprecated";
3268   my($table)=@_;
3269   my(%hash);
3270   foreach (fields($table)) {
3271     $hash{$_}=1;
3272   }
3273   \%hash;
3274 }
3275
3276 sub _dump {
3277   my($self)=@_;
3278   join("\n", map {
3279     "$_: ". $self->getfield($_). "|"
3280   } (fields($self->table)) );
3281 }
3282
3283 sub DESTROY { return; }
3284
3285 #sub DESTROY {
3286 #  my $self = shift;
3287 #  #use Carp qw(cluck);
3288 #  #cluck "DESTROYING $self";
3289 #  warn "DESTROYING $self";
3290 #}
3291
3292 #sub is_tainted {
3293 #             return ! eval { join('',@_), kill 0; 1; };
3294 #         }
3295
3296 =item str2time_sql [ DRIVER_NAME ]
3297
3298 Returns a function to convert to unix time based on database type, such as
3299 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
3300 the str2time_sql_closing method to return a closing string rather than just
3301 using a closing parenthesis as previously suggested.
3302
3303 You can pass an optional driver name such as "Pg", "mysql" or
3304 $dbh->{Driver}->{Name} to return a function for that database instead of
3305 the current database.
3306
3307 =cut
3308
3309 sub str2time_sql {
3310   my $driver = shift || driver_name;
3311
3312   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
3313   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3314
3315   warn "warning: unknown database type $driver; guessing how to convert ".
3316        "dates to UNIX timestamps";
3317   return 'EXTRACT(EPOCH FROM ';
3318
3319 }
3320
3321 =item str2time_sql_closing [ DRIVER_NAME ]
3322
3323 Returns the closing suffix of a function to convert to unix time based on
3324 database type, such as ")::integer" for Pg or ")" for mysql.
3325
3326 You can pass an optional driver name such as "Pg", "mysql" or
3327 $dbh->{Driver}->{Name} to return a function for that database instead of
3328 the current database.
3329
3330 =cut
3331
3332 sub str2time_sql_closing {
3333   my $driver = shift || driver_name;
3334
3335   return ' )::INTEGER ' if $driver =~ /^Pg/i;
3336   return ' ) ';
3337 }
3338
3339 =item regexp_sql [ DRIVER_NAME ]
3340
3341 Returns the operator to do a regular expression comparison based on database
3342 type, such as '~' for Pg or 'REGEXP' for mysql.
3343
3344 You can pass an optional driver name such as "Pg", "mysql" or
3345 $dbh->{Driver}->{Name} to return a function for that database instead of
3346 the current database.
3347
3348 =cut
3349
3350 sub regexp_sql {
3351   my $driver = shift || driver_name;
3352
3353   return '~'      if $driver =~ /^Pg/i;
3354   return 'REGEXP' if $driver =~ /^mysql/i;
3355
3356   die "don't know how to use regular expressions in ". driver_name." databases";
3357
3358 }
3359
3360 =item not_regexp_sql [ DRIVER_NAME ]
3361
3362 Returns the operator to do a regular expression negation based on database
3363 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3364
3365 You can pass an optional driver name such as "Pg", "mysql" or
3366 $dbh->{Driver}->{Name} to return a function for that database instead of
3367 the current database.
3368
3369 =cut
3370
3371 sub not_regexp_sql {
3372   my $driver = shift || driver_name;
3373
3374   return '!~'         if $driver =~ /^Pg/i;
3375   return 'NOT REGEXP' if $driver =~ /^mysql/i;
3376
3377   die "don't know how to use regular expressions in ". driver_name." databases";
3378
3379 }
3380
3381 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3382
3383 Returns the items concatenated based on database type, using "CONCAT()" for
3384 mysql and " || " for Pg and other databases.
3385
3386 You can pass an optional driver name such as "Pg", "mysql" or
3387 $dbh->{Driver}->{Name} to return a function for that database instead of
3388 the current database.
3389
3390 =cut
3391
3392 sub concat_sql {
3393   my $driver = ref($_[0]) ? driver_name : shift;
3394   my $items = shift;
3395
3396   if ( $driver =~ /^mysql/i ) {
3397     'CONCAT('. join(',', @$items). ')';
3398   } else {
3399     join('||', @$items);
3400   }
3401
3402 }
3403
3404 =item midnight_sql DATE
3405
3406 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3407 on that day in the system timezone, using the default driver name.
3408
3409 =cut
3410
3411 sub midnight_sql {
3412   my $driver = driver_name;
3413   my $expr = shift;
3414   if ( $driver =~ /^mysql/i ) {
3415     "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3416   }
3417   else {
3418     "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3419   }
3420 }
3421
3422 =back
3423
3424 =head1 BUGS
3425
3426 This module should probably be renamed, since much of the functionality is
3427 of general use.  It is not completely unlike Adapter::DBI (see below).
3428
3429 Exported qsearch and qsearchs should be deprecated in favor of method calls
3430 (against an FS::Record object like the old search and searchs that qsearch
3431 and qsearchs were on top of.)
3432
3433 The whole fields / hfields mess should be removed.
3434
3435 The various WHERE clauses should be subroutined.
3436
3437 table string should be deprecated in favor of DBIx::DBSchema::Table.
3438
3439 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
3440 true maps to the database (and WHERE clauses) would also help.
3441
3442 The ut_ methods should ask the dbdef for a default length.
3443
3444 ut_sqltype (like ut_varchar) should all be defined
3445
3446 A fallback check method should be provided which uses the dbdef.
3447
3448 The ut_money method assumes money has two decimal digits.
3449
3450 The Pg money kludge in the new method only strips `$'.
3451
3452 The ut_phonen method only checks US-style phone numbers.
3453
3454 The _quote function should probably use ut_float instead of a regex.
3455
3456 All the subroutines probably should be methods, here or elsewhere.
3457
3458 Probably should borrow/use some dbdef methods where appropriate (like sub
3459 fields)
3460
3461 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3462 or allow it to be set.  Working around it is ugly any way around - DBI should
3463 be fixed.  (only affects RDBMS which return uppercase column names)
3464
3465 ut_zip should take an optional country like ut_phone.
3466
3467 =head1 SEE ALSO
3468
3469 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3470
3471 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
3472
3473 http://poop.sf.net/
3474
3475 =cut
3476
3477 1;
3478