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