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