FS/FS/Record.pm

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