FS/FS/Record.pm

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