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