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