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   # maybe should only load one table at a time?
1068   fk_methods_init() unless exists($fk_method_cache{$table});
1069
1070   if ( exists($fk_method_cache{$table}) and
1071        exists($fk_method_cache{$table}{$field}) ) {
1072     return $fk_method_cache{$table}{$field};
1073   } else {
1074     return undef;
1075   }
1076
1077 }
1078
1079 sub fk_methods_init {
1080   warn "[fk_methods_init]\n" if $DEBUG;
1081   foreach my $table ( dbdef->tables ) {
1082     $fk_method_cache{$table} = fk_methods($table);
1083   }
1084 }
1085
1086 sub fk_methods {
1087   my $table = shift;
1088
1089   my %hash = ();
1090
1091   # foreign keys we reference in other tables
1092   foreach my $fk (dbdef->table($table)->foreign_keys) {
1093
1094     my $method = '';
1095     if ( scalar( @{$fk->columns} ) == 1 ) {
1096       if (    ! defined($fk->references)
1097            || ! @{$fk->references}
1098            || $fk->columns->[0] eq $fk->references->[0]
1099       ) {
1100         $method = $fk->table;
1101       } else {
1102         #some sort of hint in the table.pm or schema for methods not named
1103         # after their foreign table (well, not a whole lot different than
1104         # just providing a small subroutine...)
1105       }
1106
1107       if ( $method ) {
1108         $hash{$method} = { #fk_info
1109                            'method' => 'qsearchs',
1110                            'column' => $fk->columns->[0],
1111                            #'references' => $fk->references->[0],
1112                          };
1113       }
1114
1115     }
1116
1117   }
1118
1119   # foreign keys referenced in other tables to us
1120   #  (alas.  why we're cached.  still, might this loop better be done once at
1121   #   schema load time insetad of every time we AUTOLOAD a method on a new
1122   #   class?)
1123   if (! defined $fk_table_cache) {
1124     foreach my $f_table ( dbdef->tables ) {
1125       foreach my $fk (dbdef->table($f_table)->foreign_keys) {
1126         push @{$fk_table_cache->{$fk->table}},[$f_table,$fk];
1127       }
1128     }
1129   }
1130   foreach my $fks (@{$fk_table_cache->{$table}}) {
1131       my ($f_table,$fk) = @$fks;
1132       my $method = '';
1133       if ( scalar( @{$fk->columns} ) == 1 ) {
1134         if (    ! defined($fk->references)
1135              || ! @{$fk->references}
1136              || $fk->columns->[0] eq $fk->references->[0]
1137         ) {
1138           $method = $f_table;
1139         } else {
1140           #some sort of hint in the table.pm or schema for methods not named
1141           # after their foreign table (well, not a whole lot different than
1142           # just providing a small subroutine...)
1143         }
1144
1145         if ( $method ) {
1146           $hash{$method} = { #fk_info
1147                              'method' => 'qsearch',
1148                              'column' => $fk->columns->[0], #references||column
1149                              #'references' => $fk->column->[0],
1150                            };
1151         }
1152
1153       }
1154   }
1155
1156   \%hash;
1157 }
1158
1159 =item hash
1160
1161 Returns a list of the column/value pairs, usually for assigning to a new hash.
1162
1163 To make a distinct duplicate of an FS::Record object, you can do:
1164
1165     $new = new FS::Record ( $old->table, { $old->hash } );
1166
1167 =cut
1168
1169 sub hash {
1170   my($self) = @_;
1171   confess $self. ' -> hash: Hash attribute is undefined'
1172     unless defined($self->{'Hash'});
1173   %{ $self->{'Hash'} };
1174 }
1175
1176 =item hashref
1177
1178 Returns a reference to the column/value hash.  This may be deprecated in the
1179 future; if there's a reason you can't just use the autoloaded or get/set
1180 methods, speak up.
1181
1182 =cut
1183
1184 sub hashref {
1185   my($self) = @_;
1186   $self->{'Hash'};
1187 }
1188
1189 #fallbacks/generics
1190
1191 sub API_getinfo {
1192   my $self = shift;
1193   +{ ( map { $_=>$self->$_ } $self->fields ),
1194    };
1195 }
1196
1197 sub API_insert {
1198   my( $class, %opt ) = @_;
1199   my $table = $class->table;
1200   my $self = $class->new( { map { $_ => $opt{$_} } fields($table) } );
1201   my $error = $self->insert;
1202   return +{ 'error' => $error } if $error;
1203   my $pkey = $self->pkey;
1204   return +{ 'error'       => '',
1205             'primary_key' => $pkey,
1206             $pkey         => $self->$pkey,
1207           };
1208 }
1209
1210 =item modified
1211
1212 Returns true if any of this object's values have been modified with set (or via
1213 an autoloaded method).  Doesn't yet recognize when you retreive a hashref and
1214 modify that.
1215
1216 =cut
1217
1218 sub modified {
1219   my $self = shift;
1220   $self->{'modified'};
1221 }
1222
1223 =item select_for_update
1224
1225 Selects this record with the SQL "FOR UPDATE" command.  This can be useful as
1226 a mutex.
1227
1228 =cut
1229
1230 sub select_for_update {
1231   my $self = shift;
1232   my $primary_key = $self->primary_key;
1233   qsearchs( {
1234     'select'    => '*',
1235     'table'     => $self->table,
1236     'hashref'   => { $primary_key => $self->$primary_key() },
1237     'extra_sql' => 'FOR UPDATE',
1238   } );
1239 }
1240
1241 =item lock_table
1242
1243 Locks this table with a database-driver specific lock method.  This is used
1244 as a mutex in order to do a duplicate search.
1245
1246 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
1247
1248 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
1249
1250 Errors are fatal; no useful return value.
1251
1252 Note: To use this method for new tables other than svc_acct and svc_phone,
1253 edit freeside-upgrade and add those tables to the duplicate_lock list.
1254
1255 =cut
1256
1257 sub lock_table {
1258   my $self = shift;
1259   my $table = $self->table;
1260
1261   warn "$me locking $table table\n" if $DEBUG;
1262
1263   if ( driver_name =~ /^Pg/i ) {
1264
1265     dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
1266       or die dbh->errstr;
1267
1268   } elsif ( driver_name =~ /^mysql/i ) {
1269
1270     dbh->do("SELECT * FROM duplicate_lock
1271                WHERE lockname = '$table'
1272                FOR UPDATE"
1273            ) or die dbh->errstr;
1274
1275   } else {
1276
1277     die "unknown database ". driver_name. "; don't know how to lock table";
1278
1279   }
1280
1281   warn "$me acquired $table table lock\n" if $DEBUG;
1282
1283 }
1284
1285 =item insert
1286
1287 Inserts this record to the database.  If there is an error, returns the error,
1288 otherwise returns false.
1289
1290 =cut
1291
1292 sub insert {
1293   my $self = shift;
1294   my $saved = {};
1295
1296   warn "$self -> insert" if $DEBUG;
1297
1298   my $error = $self->check;
1299   return $error if $error;
1300
1301   #single-field non-null unique keys are given a value if empty
1302   #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
1303   foreach ( $self->dbdef_table->unique_singles) {
1304     next if $self->getfield($_);
1305     next if $self->dbdef_table->column($_)->null eq 'NULL';
1306     $self->unique($_);
1307   }
1308
1309   #and also the primary key, if the database isn't going to
1310   my $primary_key = $self->dbdef_table->primary_key;
1311   my $db_seq = 0;
1312   if ( $primary_key ) {
1313     my $col = $self->dbdef_table->column($primary_key);
1314
1315     $db_seq =
1316       uc($col->type) =~ /^(BIG)?SERIAL\d?/
1317       || ( driver_name eq 'Pg'
1318              && defined($col->default)
1319              && $col->quoted_default =~ /^nextval\(/i
1320          )
1321       || ( driver_name eq 'mysql'
1322              && defined($col->local)
1323              && $col->local =~ /AUTO_INCREMENT/i
1324          );
1325     $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
1326   }
1327
1328   my $table = $self->table;
1329
1330   # Encrypt before the database
1331   if (    scalar( eval '@FS::'. $table . '::encrypted_fields')
1332        && $conf_encryption
1333   ) {
1334     foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
1335       next if $field eq 'payinfo'
1336                 && ($self->isa('FS::payinfo_transaction_Mixin')
1337                     || $self->isa('FS::payinfo_Mixin') )
1338                 && $self->payby
1339                 && !grep { $self->payby eq $_ } @encrypt_payby;
1340       $saved->{$field} = $self->getfield($field);
1341       $self->setfield($field, $self->encrypt($self->getfield($field)));
1342     }
1343   }
1344
1345   #false laziness w/delete
1346   my @real_fields =
1347     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1348     real_fields($table)
1349   ;
1350   my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
1351   #eslaf
1352
1353   my $statement = "INSERT INTO $table ";
1354   if ( @real_fields ) {
1355     $statement .=
1356       "( ".
1357         join( ', ', @real_fields ).
1358       ") VALUES (".
1359         join( ', ', @values ).
1360        ")"
1361     ;
1362   } else {
1363     $statement .= 'DEFAULT VALUES';
1364   }
1365   warn "[debug]$me $statement\n" if $DEBUG > 1;
1366   my $sth = dbh->prepare($statement) or return dbh->errstr;
1367
1368   local $SIG{HUP} = 'IGNORE';
1369   local $SIG{INT} = 'IGNORE';
1370   local $SIG{QUIT} = 'IGNORE';
1371   local $SIG{TERM} = 'IGNORE';
1372   local $SIG{TSTP} = 'IGNORE';
1373   local $SIG{PIPE} = 'IGNORE';
1374
1375   $sth->execute or return $sth->errstr;
1376
1377   # get inserted id from the database, if applicable & needed
1378   if ( $db_seq && ! $self->getfield($primary_key) ) {
1379     warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
1380
1381     my $insertid = '';
1382
1383     if ( driver_name eq 'Pg' ) {
1384
1385       #my $oid = $sth->{'pg_oid_status'};
1386       #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
1387
1388       my $default = $self->dbdef_table->column($primary_key)->quoted_default;
1389       unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
1390         dbh->rollback if $FS::UID::AutoCommit;
1391         return "can't parse $table.$primary_key default value".
1392                " for sequence name: $default";
1393       }
1394       my $sequence = $1;
1395
1396       my $i_sql = "SELECT currval('$sequence')";
1397       my $i_sth = dbh->prepare($i_sql) or do {
1398         dbh->rollback if $FS::UID::AutoCommit;
1399         return dbh->errstr;
1400       };
1401       $i_sth->execute() or do { #$i_sth->execute($oid)
1402         dbh->rollback if $FS::UID::AutoCommit;
1403         return $i_sth->errstr;
1404       };
1405       $insertid = $i_sth->fetchrow_arrayref->[0];
1406
1407     } elsif ( driver_name eq 'mysql' ) {
1408
1409       $insertid = dbh->{'mysql_insertid'};
1410       # work around mysql_insertid being null some of the time, ala RT :/
1411       unless ( $insertid ) {
1412         warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
1413              "using SELECT LAST_INSERT_ID();";
1414         my $i_sql = "SELECT LAST_INSERT_ID()";
1415         my $i_sth = dbh->prepare($i_sql) or do {
1416           dbh->rollback if $FS::UID::AutoCommit;
1417           return dbh->errstr;
1418         };
1419         $i_sth->execute or do {
1420           dbh->rollback if $FS::UID::AutoCommit;
1421           return $i_sth->errstr;
1422         };
1423         $insertid = $i_sth->fetchrow_arrayref->[0];
1424       }
1425
1426     } else {
1427
1428       dbh->rollback if $FS::UID::AutoCommit;
1429       return "don't know how to retreive inserted ids from ". driver_name.
1430              ", try using counterfiles (maybe run dbdef-create?)";
1431
1432     }
1433
1434     $self->setfield($primary_key, $insertid);
1435
1436   }
1437
1438   my $h_sth;
1439   if ( defined( dbdef->table('h_'. $table) ) && ! $no_history ) {
1440     my $h_statement = $self->_h_statement('insert');
1441     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1442     $h_sth = dbh->prepare($h_statement) or do {
1443       dbh->rollback if $FS::UID::AutoCommit;
1444       return dbh->errstr;
1445     };
1446   } else {
1447     $h_sth = '';
1448   }
1449   $h_sth->execute or return $h_sth->errstr if $h_sth;
1450
1451   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1452
1453   # Now that it has been saved, reset the encrypted fields so that $new
1454   # can still be used.
1455   foreach my $field (keys %{$saved}) {
1456     $self->setfield($field, $saved->{$field});
1457   }
1458
1459   '';
1460 }
1461
1462 =item add
1463
1464 Depriciated (use insert instead).
1465
1466 =cut
1467
1468 sub add {
1469   cluck "warning: FS::Record::add deprecated!";
1470   insert @_; #call method in this scope
1471 }
1472
1473 =item delete
1474
1475 Delete this record from the database.  If there is an error, returns the error,
1476 otherwise returns false.
1477
1478 =cut
1479
1480 sub delete {
1481   my $self = shift;
1482
1483   my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1484     map {
1485       $self->getfield($_) eq ''
1486         #? "( $_ IS NULL OR $_ = \"\" )"
1487         ? ( driver_name eq 'Pg'
1488               ? "$_ IS NULL"
1489               : "( $_ IS NULL OR $_ = \"\" )"
1490           )
1491         : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1492     } ( $self->dbdef_table->primary_key )
1493           ? ( $self->dbdef_table->primary_key)
1494           : real_fields($self->table)
1495   );
1496   warn "[debug]$me $statement\n" if $DEBUG > 1;
1497   my $sth = dbh->prepare($statement) or return dbh->errstr;
1498
1499   my $h_sth;
1500   if ( defined dbdef->table('h_'. $self->table) ) {
1501     my $h_statement = $self->_h_statement('delete');
1502     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1503     $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1504   } else {
1505     $h_sth = '';
1506   }
1507
1508   my $primary_key = $self->dbdef_table->primary_key;
1509
1510   local $SIG{HUP} = 'IGNORE';
1511   local $SIG{INT} = 'IGNORE';
1512   local $SIG{QUIT} = 'IGNORE';
1513   local $SIG{TERM} = 'IGNORE';
1514   local $SIG{TSTP} = 'IGNORE';
1515   local $SIG{PIPE} = 'IGNORE';
1516
1517   my $rc = $sth->execute or return $sth->errstr;
1518   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1519   $h_sth->execute or return $h_sth->errstr if $h_sth;
1520
1521   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1522
1523   #no need to needlessly destoy the data either (causes problems actually)
1524   #undef $self; #no need to keep object!
1525
1526   '';
1527 }
1528
1529 =item del
1530
1531 Depriciated (use delete instead).
1532
1533 =cut
1534
1535 sub del {
1536   cluck "warning: FS::Record::del deprecated!";
1537   &delete(@_); #call method in this scope
1538 }
1539
1540 =item replace OLD_RECORD
1541
1542 Replace the OLD_RECORD with this one in the database.  If there is an error,
1543 returns the error, otherwise returns false.
1544
1545 =cut
1546
1547 sub replace {
1548   my ($new, $old) = (shift, shift);
1549
1550   $old = $new->replace_old unless defined($old);
1551
1552   warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1553
1554   if ( $new->can('replace_check') ) {
1555     my $error = $new->replace_check($old);
1556     return $error if $error;
1557   }
1558
1559   return "Records not in same table!" unless $new->table eq $old->table;
1560
1561   my $primary_key = $old->dbdef_table->primary_key;
1562   return "Can't change primary key $primary_key ".
1563          'from '. $old->getfield($primary_key).
1564          ' to ' . $new->getfield($primary_key)
1565     if $primary_key
1566        && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1567
1568   my $error = $new->check;
1569   return $error if $error;
1570
1571   # Encrypt for replace
1572   my $saved = {};
1573   if (    scalar( eval '@FS::'. $new->table . '::encrypted_fields')
1574        && $conf_encryption
1575   ) {
1576     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1577       next if $field eq 'payinfo'
1578                 && ($new->isa('FS::payinfo_transaction_Mixin')
1579                     || $new->isa('FS::payinfo_Mixin') )
1580                 && $new->payby
1581                 && !grep { $new->payby eq $_ } @encrypt_payby;
1582       $saved->{$field} = $new->getfield($field);
1583       $new->setfield($field, $new->encrypt($new->getfield($field)));
1584     }
1585   }
1586
1587   #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1588   my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1589                    ? ($_, $new->getfield($_)) : () } $old->fields;
1590
1591   unless (keys(%diff) || $no_update_diff ) {
1592     carp "[warning]$me ". ref($new)."->replace ".
1593            ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
1594          ": records identical"
1595       unless $nowarn_identical;
1596     return '';
1597   }
1598
1599   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1600     map {
1601       "$_ = ". _quote($new->getfield($_),$old->table,$_)
1602     } real_fields($old->table)
1603   ). ' WHERE '.
1604     join(' AND ',
1605       map {
1606
1607         if ( $old->getfield($_) eq '' ) {
1608
1609          #false laziness w/qsearch
1610          if ( driver_name eq 'Pg' ) {
1611             my $type = $old->dbdef_table->column($_)->type;
1612             if ( $type =~ /(int|(big)?serial)/i ) {
1613               qq-( $_ IS NULL )-;
1614             } else {
1615               qq-( $_ IS NULL OR $_ = '' )-;
1616             }
1617           } else {
1618             qq-( $_ IS NULL OR $_ = "" )-;
1619           }
1620
1621         } else {
1622           "$_ = ". _quote($old->getfield($_),$old->table,$_);
1623         }
1624
1625       } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1626     )
1627   ;
1628   warn "[debug]$me $statement\n" if $DEBUG > 1;
1629   my $sth = dbh->prepare($statement) or return dbh->errstr;
1630
1631   my $h_old_sth;
1632   if ( defined dbdef->table('h_'. $old->table) ) {
1633     my $h_old_statement = $old->_h_statement('replace_old');
1634     warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1635     $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1636   } else {
1637     $h_old_sth = '';
1638   }
1639
1640   my $h_new_sth;
1641   if ( defined dbdef->table('h_'. $new->table) ) {
1642     my $h_new_statement = $new->_h_statement('replace_new');
1643     warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1644     $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1645   } else {
1646     $h_new_sth = '';
1647   }
1648
1649   local $SIG{HUP} = 'IGNORE';
1650   local $SIG{INT} = 'IGNORE';
1651   local $SIG{QUIT} = 'IGNORE';
1652   local $SIG{TERM} = 'IGNORE';
1653   local $SIG{TSTP} = 'IGNORE';
1654   local $SIG{PIPE} = 'IGNORE';
1655
1656   my $rc = $sth->execute or return $sth->errstr;
1657   #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1658   $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1659   $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1660
1661   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1662
1663   # Now that it has been saved, reset the encrypted fields so that $new
1664   # can still be used.
1665   foreach my $field (keys %{$saved}) {
1666     $new->setfield($field, $saved->{$field});
1667   }
1668
1669   '';
1670
1671 }
1672
1673 sub replace_old {
1674   my( $self ) = shift;
1675   warn "[$me] replace called with no arguments; autoloading old record\n"
1676     if $DEBUG;
1677
1678   my $primary_key = $self->dbdef_table->primary_key;
1679   if ( $primary_key ) {
1680     $self->by_key( $self->$primary_key() ) #this is what's returned
1681       or croak "can't find ". $self->table. ".$primary_key ".
1682         $self->$primary_key();
1683   } else {
1684     croak $self->table. " has no primary key; pass old record as argument";
1685   }
1686
1687 }
1688
1689 =item rep
1690
1691 Depriciated (use replace instead).
1692
1693 =cut
1694
1695 sub rep {
1696   cluck "warning: FS::Record::rep deprecated!";
1697   replace @_; #call method in this scope
1698 }
1699
1700 =item check
1701
1702 Checks custom fields. Subclasses should still provide a check method to validate
1703 non-custom fields, etc., and call this method via $self->SUPER::check.
1704
1705 =cut
1706
1707 sub check {
1708     my $self = shift;
1709     foreach my $field ($self->virtual_fields) {
1710         my $error = $self->ut_textn($field);
1711         return $error if $error;
1712     }
1713     '';
1714 }
1715
1716 =item virtual_fields [ TABLE ]
1717
1718 Returns a list of virtual fields defined for the table.  This should not
1719 be exported, and should only be called as an instance or class method.
1720
1721 =cut
1722
1723 sub virtual_fields {
1724   my $self = shift;
1725   my $table;
1726   $table = $self->table or confess "virtual_fields called on non-table";
1727
1728   confess "Unknown table $table" unless dbdef->table($table);
1729
1730   return () unless dbdef->table('part_virtual_field');
1731
1732   unless ( $virtual_fields_cache{$table} ) {
1733     my $concat = [ "'cf_'", "name" ];
1734     my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' .
1735                 "WHERE dbtable = '$table'";
1736     my $dbh = dbh;
1737     my $result = $dbh->selectcol_arrayref($query);
1738     confess "Error executing virtual fields query: $query: ". $dbh->errstr
1739       if $dbh->err;
1740     $virtual_fields_cache{$table} = $result;
1741   }
1742
1743   @{$virtual_fields_cache{$table}};
1744
1745 }
1746
1747 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1748
1749 Processes a batch import as a queued JSRPC job
1750
1751 JOB is an FS::queue entry.
1752
1753 OPTIONS_HASHREF can have the following keys:
1754
1755 =over 4
1756
1757 =item table
1758
1759 Table name (required).
1760
1761 =item params
1762
1763 Arrayref of field names for static fields.  They will be given values from the
1764 PARAMS hashref and passed as a "params" hashref to batch_import.
1765
1766 =item formats
1767
1768 Formats hashref.  Keys are field names, values are listrefs that define the
1769 format.
1770
1771 Each listref value can be a column name or a code reference.  Coderefs are run
1772 with the row object, data and a FS::Conf object as the three parameters.
1773 For example, this coderef does the same thing as using the "columnname" string:
1774
1775   sub {
1776     my( $record, $data, $conf ) = @_;
1777     $record->columnname( $data );
1778   },
1779
1780 Coderefs are run after all "column name" fields are assigned.
1781
1782 =item format_types
1783
1784 Optional format hashref of types.  Keys are field names, values are "csv",
1785 "xls" or "fixedlength".  Overrides automatic determination of file type
1786 from extension.
1787
1788 =item format_headers
1789
1790 Optional format hashref of header lines.  Keys are field names, values are 0
1791 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1792 number of lines.
1793
1794 =item format_sep_chars
1795
1796 Optional format hashref of CSV sep_chars.  Keys are field names, values are the
1797 CSV separation character.
1798
1799 =item format_fixedlenth_formats
1800
1801 Optional format hashref of fixed length format defintiions.  Keys are field
1802 names, values Parse::FixedLength listrefs of field definitions.
1803
1804 =item default_csv
1805
1806 Set true to default to CSV file type if the filename does not contain a
1807 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1808 format_types).
1809
1810 =back
1811
1812 PARAMS is a hashref (or base64-encoded Storable hashref) containing the
1813 POSTed data.  It must contain the field "uploaded files", generated by
1814 /elements/file-upload.html and containing the list of uploaded files.
1815 Currently only supports a single file named "file".
1816
1817 =cut
1818
1819 use Data::Dumper;
1820 sub process_batch_import {
1821   my($job, $opt, $param) = @_;
1822
1823   my $table = $opt->{table};
1824   my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1825   my %formats = %{ $opt->{formats} };
1826
1827   warn Dumper($param) if $DEBUG;
1828
1829   my $files = $param->{'uploaded_files'}
1830     or die "No files provided.\n";
1831
1832   my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1833
1834   my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1835   my $file = $dir. $files{'file'};
1836
1837   my %iopt = (
1838     #class-static
1839     table                      => $table,
1840     formats                    => \%formats,
1841     format_types               => $opt->{format_types},
1842     format_headers             => $opt->{format_headers},
1843     format_sep_chars           => $opt->{format_sep_chars},
1844     format_fixedlength_formats => $opt->{format_fixedlength_formats},
1845     format_xml_formats         => $opt->{format_xml_formats},
1846     format_asn_formats         => $opt->{format_asn_formats},
1847     format_row_callbacks       => $opt->{format_row_callbacks},
1848     format_hash_callbacks      => $opt->{format_hash_callbacks},
1849     #per-import
1850     job                        => $job,
1851     file                       => $file,
1852     #type                       => $type,
1853     format                     => $param->{format},
1854     params                     => { map { $_ => $param->{$_} } @pass_params },
1855     #?
1856     default_csv                => $opt->{default_csv},
1857     preinsert_callback         => $opt->{preinsert_callback},
1858     postinsert_callback        => $opt->{postinsert_callback},
1859     insert_args_callback       => $opt->{insert_args_callback},
1860   );
1861
1862   if ( $opt->{'batch_namecol'} ) {
1863     $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1864     $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1865   }
1866
1867   my $error = FS::Record::batch_import( \%iopt );
1868
1869   unlink $file;
1870
1871   die "$error\n" if $error;
1872 }
1873
1874 =item batch_import PARAM_HASHREF
1875
1876 Class method for batch imports.  Available params:
1877
1878 =over 4
1879
1880 =item table
1881
1882 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1883
1884 =item formats
1885
1886 =item format_types
1887
1888 =item format_headers
1889
1890 =item format_sep_chars
1891
1892 =item format_fixedlength_formats
1893
1894 =item format_row_callbacks
1895
1896 =item format_hash_callbacks - After parsing, before object creation
1897
1898 =item fields - Alternate way to specify import, specifying import fields directly as a listref
1899
1900 =item preinsert_callback
1901
1902 =item postinsert_callback
1903
1904 =item params
1905
1906 =item job
1907
1908 FS::queue object, will be updated with progress
1909
1910 =item file
1911
1912 =item type
1913
1914 csv, xls, fixedlength, xml
1915
1916 =item empty_ok
1917
1918 =back
1919
1920 =cut
1921
1922 use Data::Dumper;
1923 sub batch_import {
1924   my $param = shift;
1925
1926   warn "$me batch_import call with params: \n". Dumper($param)
1927     if $DEBUG;
1928
1929   my $table   = $param->{table};
1930
1931   my $job     = $param->{job};
1932   my $file    = $param->{file};
1933   my $params  = $param->{params} || {};
1934
1935   my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
1936   my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
1937
1938   my( $type, $header, $sep_char,
1939       $fixedlength_format, $xml_format, $asn_format,
1940       $parser_opt, $row_callback, $hash_callback, @fields );
1941
1942   my $postinsert_callback = '';
1943   $postinsert_callback = $param->{'postinsert_callback'}
1944           if $param->{'postinsert_callback'};
1945   my $preinsert_callback = '';
1946   $preinsert_callback = $param->{'preinsert_callback'}
1947           if $param->{'preinsert_callback'};
1948   my $insert_args_callback = '';
1949   $insert_args_callback = $param->{'insert_args_callback'}
1950           if $param->{'insert_args_callback'};
1951
1952   if ( $param->{'format'} ) {
1953
1954     my $format  = $param->{'format'};
1955     my $formats = $param->{formats};
1956     die "unknown format $format" unless exists $formats->{ $format };
1957
1958     $type = $param->{'format_types'}
1959             ? $param->{'format_types'}{ $format }
1960             : $param->{type} || 'csv';
1961
1962
1963     $header = $param->{'format_headers'}
1964                ? $param->{'format_headers'}{ $param->{'format'} }
1965                : 0;
1966
1967     $sep_char = $param->{'format_sep_chars'}
1968                   ? $param->{'format_sep_chars'}{ $param->{'format'} }
1969                   : ',';
1970
1971     $fixedlength_format =
1972       $param->{'format_fixedlength_formats'}
1973         ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1974         : '';
1975
1976     $parser_opt =
1977       $param->{'format_parser_opts'}
1978         ? $param->{'format_parser_opts'}{ $param->{'format'} }
1979         : {};
1980
1981     $xml_format =
1982       $param->{'format_xml_formats'}
1983         ? $param->{'format_xml_formats'}{ $param->{'format'} }
1984         : '';
1985
1986     $asn_format =
1987       $param->{'format_asn_formats'}
1988         ? $param->{'format_asn_formats'}{ $param->{'format'} }
1989         : '';
1990
1991     $row_callback =
1992       $param->{'format_row_callbacks'}
1993         ? $param->{'format_row_callbacks'}{ $param->{'format'} }
1994         : '';
1995
1996     $hash_callback =
1997       $param->{'format_hash_callbacks'}
1998         ? $param->{'format_hash_callbacks'}{ $param->{'format'} }
1999         : '';
2000
2001     @fields = @{ $formats->{ $format } };
2002
2003   } elsif ( $param->{'fields'} ) {
2004
2005     $type = ''; #infer from filename
2006     $header = 0;
2007     $sep_char = ',';
2008     $fixedlength_format = '';
2009     $row_callback = '';
2010     $hash_callback = '';
2011     @fields = @{ $param->{'fields'} };
2012
2013   } else {
2014     die "neither format nor fields specified";
2015   }
2016
2017   #my $file    = $param->{file};
2018
2019   unless ( $type ) {
2020     if ( $file =~ /\.(\w+)$/i ) {
2021       $type = lc($1);
2022     } else {
2023       #or error out???
2024       warn "can't parse file type from filename $file; defaulting to CSV";
2025       $type = 'csv';
2026     }
2027     $type = 'csv'
2028       if $param->{'default_csv'} && $type ne 'xls';
2029   }
2030
2031
2032   my $row = 0;
2033   my $count;
2034   my $parser;
2035   my @buffer = ();
2036   my $asn_header_buffer;
2037   if ( $type eq 'csv' || $type eq 'fixedlength' ) {
2038
2039     if ( $type eq 'csv' ) {
2040
2041       $parser_opt->{'binary'} = 1;
2042       $parser_opt->{'sep_char'} = $sep_char if $sep_char;
2043       $parser = Text::CSV_XS->new($parser_opt);
2044
2045     } elsif ( $type eq 'fixedlength' ) {
2046
2047       eval "use Parse::FixedLength;";
2048       die $@ if $@;
2049       $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
2050
2051     } else {
2052       die "Unknown file type $type\n";
2053     }
2054
2055     @buffer = split(/\r?\n/, slurp($file) );
2056     splice(@buffer, 0, ($header || 0) );
2057     $count = scalar(@buffer);
2058
2059   } elsif ( $type eq 'xls' ) {
2060
2061     eval "use Spreadsheet::ParseExcel;";
2062     die $@ if $@;
2063
2064     eval "use DateTime::Format::Excel;";
2065     #for now, just let the error be thrown if it is used, since only CDR
2066     # formats bill_west and troop use it, not other excel-parsing things
2067     #die $@ if $@;
2068
2069     my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
2070
2071     $parser = $excel->{Worksheet}[0]; #first sheet
2072
2073     $count = $parser->{MaxRow} || $parser->{MinRow};
2074     $count++;
2075
2076     $row = $header || 0;
2077
2078   } elsif ( $type eq 'xml' ) {
2079
2080     # FS::pay_batch
2081     eval "use XML::Simple;";
2082     die $@ if $@;
2083     my $xmlrow = $xml_format->{'xmlrow'};
2084     $parser = $xml_format->{'xmlkeys'};
2085     die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
2086     my $data = XML::Simple::XMLin(
2087       $file,
2088       'SuppressEmpty' => '', #sets empty values to ''
2089       'KeepRoot'      => 1,
2090     );
2091     my $rows = $data;
2092     $rows = $rows->{$_} foreach @$xmlrow;
2093     $rows = [ $rows ] if ref($rows) ne 'ARRAY';
2094     $count = @buffer = @$rows;
2095
2096   } elsif ( $type eq 'asn.1' ) {
2097
2098     eval "use Convert::ASN1";
2099     die $@ if $@;
2100
2101     my $asn = Convert::ASN1->new;
2102     $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
2103
2104     $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
2105
2106     my $data = slurp($file);
2107     my $asn_output = $parser->decode( $data )
2108       or return "No ". $asn_format->{'macro'}. " found\n";
2109
2110     $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
2111
2112     my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
2113     $count = @buffer = @$rows;
2114
2115   } else {
2116     die "Unknown file type $type\n";
2117   }
2118
2119   #my $columns;
2120
2121   local $SIG{HUP} = 'IGNORE';
2122   local $SIG{INT} = 'IGNORE';
2123   local $SIG{QUIT} = 'IGNORE';
2124   local $SIG{TERM} = 'IGNORE';
2125   local $SIG{TSTP} = 'IGNORE';
2126   local $SIG{PIPE} = 'IGNORE';
2127
2128   my $oldAutoCommit = $FS::UID::AutoCommit;
2129   local $FS::UID::AutoCommit = 0;
2130   my $dbh = dbh;
2131
2132   #my $params  = $param->{params} || {};
2133   if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
2134     my $batch_col   = $param->{'batch_keycol'};
2135
2136     my $batch_class = 'FS::'. $param->{'batch_table'};
2137     my $batch = $batch_class->new({
2138       $param->{'batch_namecol'} => $param->{'batch_namevalue'}
2139     });
2140     my $error = $batch->insert;
2141     if ( $error ) {
2142       $dbh->rollback if $oldAutoCommit;
2143       return "can't insert batch record: $error";
2144     }
2145     #primary key via dbdef? (so the column names don't have to match)
2146     my $batch_value = $batch->get( $param->{'batch_keycol'} );
2147
2148     $params->{ $batch_col } = $batch_value;
2149   }
2150
2151   #my $job     = $param->{job};
2152   my $line;
2153   my $imported = 0;
2154   my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
2155   while (1) {
2156
2157     my @columns = ();
2158     my %hash = %$params;
2159     if ( $type eq 'csv' ) {
2160
2161       last unless scalar(@buffer);
2162       $line = shift(@buffer);
2163
2164       next if $line =~ /^\s*$/; #skip empty lines
2165
2166       $line = &{$row_callback}($line) if $row_callback;
2167
2168       next if $line =~ /^\s*$/; #skip empty lines
2169
2170       $parser->parse($line) or do {
2171         $dbh->rollback if $oldAutoCommit;
2172         return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
2173       };
2174       @columns = $parser->fields();
2175
2176     } elsif ( $type eq 'fixedlength' ) {
2177
2178       last unless scalar(@buffer);
2179       $line = shift(@buffer);
2180
2181       @columns = $parser->parse($line);
2182
2183     } elsif ( $type eq 'xls' ) {
2184
2185       last if $row > ($parser->{MaxRow} || $parser->{MinRow})
2186            || ! $parser->{Cells}[$row];
2187
2188       my @row = @{ $parser->{Cells}[$row] };
2189       @columns = map $_->{Val}, @row;
2190
2191       #my $z = 'A';
2192       #warn $z++. ": $_\n" for @columns;
2193
2194     } elsif ( $type eq 'xml' ) {
2195
2196       # $parser = [ 'Column0Key', 'Column1Key' ... ]
2197       last unless scalar(@buffer);
2198       my $row = shift @buffer;
2199       @columns = @{ $row }{ @$parser };
2200
2201     } elsif ( $type eq 'asn.1' ) {
2202
2203       last unless scalar(@buffer);
2204       my $row = shift @buffer;
2205       &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2206         if $asn_format->{row_callback};
2207       foreach my $key ( keys %{ $asn_format->{map} } ) {
2208         $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2209       }
2210
2211     } else {
2212       die "Unknown file type $type\n";
2213     }
2214
2215     my @later = ();
2216
2217     foreach my $field ( @fields ) {
2218
2219       my $value = shift @columns;
2220
2221       if ( ref($field) eq 'CODE' ) {
2222         #&{$field}(\%hash, $value);
2223         push @later, $field, $value;
2224       } else {
2225         #??? $hash{$field} = $value if length($value);
2226         $hash{$field} = $value if defined($value) && length($value);
2227       }
2228
2229     }
2230
2231     if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
2232                          && length($1) == $custnum_length ) {
2233       $hash{custnum} = $2;
2234     }
2235
2236     %hash = &{$hash_callback}(%hash) if $hash_callback;
2237
2238     #my $table   = $param->{table};
2239     my $class = "FS::$table";
2240
2241     my $record = $class->new( \%hash );
2242
2243     my $param = {};
2244     while ( scalar(@later) ) {
2245       my $sub = shift @later;
2246       my $data = shift @later;
2247       eval {
2248         &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2249       };
2250       if ( $@ ) {
2251         $dbh->rollback if $oldAutoCommit;
2252         return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2253       }
2254       last if exists( $param->{skiprow} );
2255     }
2256     next if exists( $param->{skiprow} );
2257
2258     if ( $preinsert_callback ) {
2259       my $error = &{$preinsert_callback}($record, $param);
2260       if ( $error ) {
2261         $dbh->rollback if $oldAutoCommit;
2262         return "preinsert_callback error". ( $line ? " for $line" : '' ).
2263                ": $error";
2264       }
2265       next if exists $param->{skiprow} && $param->{skiprow};
2266     }
2267
2268     my @insert_args = ();
2269     if ( $insert_args_callback ) {
2270       @insert_args = &{$insert_args_callback}($record, $param);
2271     }
2272
2273     my $error = $record->insert(@insert_args);
2274
2275     if ( $error ) {
2276       $dbh->rollback if $oldAutoCommit;
2277       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2278     }
2279
2280     $row++;
2281     $imported++;
2282
2283     if ( $postinsert_callback ) {
2284       my $error = &{$postinsert_callback}($record, $param);
2285       if ( $error ) {
2286         $dbh->rollback if $oldAutoCommit;
2287         return "postinsert_callback error". ( $line ? " for $line" : '' ).
2288                ": $error";
2289       }
2290     }
2291
2292     if ( $job && time - $min_sec > $last ) { #progress bar
2293       $job->update_statustext( int(100 * $imported / $count) );
2294       $last = time;
2295     }
2296
2297   }
2298
2299   unless ( $imported || $param->{empty_ok} ) {
2300     $dbh->rollback if $oldAutoCommit;
2301     return "Empty file!";
2302   }
2303
2304   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2305
2306   ''; #no error
2307
2308 }
2309
2310 sub _h_statement {
2311   my( $self, $action, $time ) = @_;
2312
2313   $time ||= time;
2314
2315   my %nohistory = map { $_=>1 } $self->nohistory_fields;
2316
2317   my @fields =
2318     grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2319     real_fields($self->table);
2320   ;
2321
2322   # If we're encrypting then don't store the payinfo in the history
2323   if ( $conf_encryption && $self->table ne 'banned_pay' ) {
2324     @fields = grep { $_ ne 'payinfo' } @fields;
2325   }
2326
2327   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2328
2329   "INSERT INTO h_". $self->table. " ( ".
2330       join(', ', qw(history_date history_usernum history_action), @fields ).
2331     ") VALUES (".
2332       join(', ', $time,
2333                  $FS::CurrentUser::CurrentUser->usernum,
2334                  dbh->quote($action),
2335                  @values
2336       ).
2337     ")"
2338   ;
2339 }
2340
2341 =item unique COLUMN
2342
2343 B<Warning>: External use is B<deprecated>.
2344
2345 Replaces COLUMN in record with a unique number, using counters in the
2346 filesystem.  Used by the B<insert> method on single-field unique columns
2347 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2348 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2349
2350 Returns the new value.
2351
2352 =cut
2353
2354 sub unique {
2355   my($self,$field) = @_;
2356   my($table)=$self->table;
2357
2358   croak "Unique called on field $field, but it is ",
2359         $self->getfield($field),
2360         ", not null!"
2361     if $self->getfield($field);
2362
2363   #warn "table $table is tainted" if is_tainted($table);
2364   #warn "field $field is tainted" if is_tainted($field);
2365
2366   my($counter) = new File::CounterFile "$table.$field",0;
2367
2368   my $index = $counter->inc;
2369   $index = $counter->inc while qsearchs($table, { $field=>$index } );
2370
2371   $index =~ /^(\d*)$/;
2372   $index=$1;
2373
2374   $self->setfield($field,$index);
2375
2376 }
2377
2378 =item ut_float COLUMN
2379
2380 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
2381 null.  If there is an error, returns the error, otherwise returns false.
2382
2383 =cut
2384
2385 sub ut_float {
2386   my($self,$field)=@_ ;
2387   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2388    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2389    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2390    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2391     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2392   $self->setfield($field,$1);
2393   '';
2394 }
2395 =item ut_floatn COLUMN
2396
2397 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2398 null.  If there is an error, returns the error, otherwise returns false.
2399
2400 =cut
2401
2402 #false laziness w/ut_ipn
2403 sub ut_floatn {
2404   my( $self, $field ) = @_;
2405   if ( $self->getfield($field) =~ /^()$/ ) {
2406     $self->setfield($field,'');
2407     '';
2408   } else {
2409     $self->ut_float($field);
2410   }
2411 }
2412
2413 =item ut_sfloat COLUMN
2414
2415 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2416 May not be null.  If there is an error, returns the error, otherwise returns
2417 false.
2418
2419 =cut
2420
2421 sub ut_sfloat {
2422   my($self,$field)=@_ ;
2423   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2424    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2425    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2426    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2427     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2428   $self->setfield($field,$1);
2429   '';
2430 }
2431 =item ut_sfloatn COLUMN
2432
2433 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2434 null.  If there is an error, returns the error, otherwise returns false.
2435
2436 =cut
2437
2438 sub ut_sfloatn {
2439   my( $self, $field ) = @_;
2440   if ( $self->getfield($field) =~ /^()$/ ) {
2441     $self->setfield($field,'');
2442     '';
2443   } else {
2444     $self->ut_sfloat($field);
2445   }
2446 }
2447
2448 =item ut_snumber COLUMN
2449
2450 Check/untaint signed numeric data (whole numbers).  If there is an error,
2451 returns the error, otherwise returns false.
2452
2453 =cut
2454
2455 sub ut_snumber {
2456   my($self, $field) = @_;
2457   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2458     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2459   $self->setfield($field, "$1$2");
2460   '';
2461 }
2462
2463 =item ut_snumbern COLUMN
2464
2465 Check/untaint signed numeric data (whole numbers).  If there is an error,
2466 returns the error, otherwise returns false.
2467
2468 =cut
2469
2470 sub ut_snumbern {
2471   my($self, $field) = @_;
2472   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2473     or return "Illegal (numeric) $field: ". $self->getfield($field);
2474   if ($1) {
2475     return "Illegal (numeric) $field: ". $self->getfield($field)
2476       unless $2;
2477   }
2478   $self->setfield($field, "$1$2");
2479   '';
2480 }
2481
2482 =item ut_number COLUMN
2483
2484 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
2485 is an error, returns the error, otherwise returns false.
2486
2487 =cut
2488
2489 sub ut_number {
2490   my($self,$field)=@_;
2491   $self->getfield($field) =~ /^\s*(\d+)\s*$/
2492     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2493   $self->setfield($field,$1);
2494   '';
2495 }
2496
2497 =item ut_numbern COLUMN
2498
2499 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
2500 an error, returns the error, otherwise returns false.
2501
2502 =cut
2503
2504 sub ut_numbern {
2505   my($self,$field)=@_;
2506   $self->getfield($field) =~ /^\s*(\d*)\s*$/
2507     or return "Illegal (numeric) $field: ". $self->getfield($field);
2508   $self->setfield($field,$1);
2509   '';
2510 }
2511
2512 =item ut_decimal COLUMN[, DIGITS]
2513
2514 Check/untaint decimal numbers (up to DIGITS decimal places.  If there is an
2515 error, returns the error, otherwise returns false.
2516
2517 =item ut_decimaln COLUMN[, DIGITS]
2518
2519 Check/untaint decimal numbers.  May be null.  If there is an error, returns
2520 the error, otherwise returns false.
2521
2522 =cut
2523
2524 sub ut_decimal {
2525   my($self, $field, $digits) = @_;
2526   $digits ||= '';
2527   $self->getfield($field) =~ /^\s*(\d+(\.\d{0,$digits})?)\s*$/
2528     or return "Illegal or empty (decimal) $field: ".$self->getfield($field);
2529   $self->setfield($field, $1);
2530   '';
2531 }
2532
2533 sub ut_decimaln {
2534   my($self, $field, $digits) = @_;
2535   $self->getfield($field) =~ /^\s*(\d*(\.\d{0,$digits})?)\s*$/
2536     or return "Illegal (decimal) $field: ".$self->getfield($field);
2537   $self->setfield($field, $1);
2538   '';
2539 }
2540
2541 =item ut_money COLUMN
2542
2543 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
2544 is an error, returns the error, otherwise returns false.
2545
2546 =cut
2547
2548 sub ut_money {
2549   my($self,$field)=@_;
2550
2551   if ( $self->getfield($field) eq '' ) {
2552     $self->setfield($field, 0);
2553   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2554     #handle one decimal place without barfing out
2555     $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2556   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2557     $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2558   } else {
2559     return "Illegal (money) $field: ". $self->getfield($field);
2560   }
2561
2562   '';
2563 }
2564
2565 =item ut_moneyn COLUMN
2566
2567 Check/untaint monetary numbers.  May be negative.  If there
2568 is an error, returns the error, otherwise returns false.
2569
2570 =cut
2571
2572 sub ut_moneyn {
2573   my($self,$field)=@_;
2574   if ($self->getfield($field) eq '') {
2575     $self->setfield($field, '');
2576     return '';
2577   }
2578   $self->ut_money($field);
2579 }
2580
2581 =item ut_currencyn COLUMN
2582
2583 Check/untaint currency indicators, such as USD or EUR.  May be null.  If there
2584 is an error, returns the error, otherwise returns false.
2585
2586 =cut
2587
2588 sub ut_currencyn {
2589   my($self, $field) = @_;
2590   if ($self->getfield($field) eq '') { #can be null
2591     $self->setfield($field, '');
2592     return '';
2593   }
2594   $self->ut_currency($field);
2595 }
2596
2597 =item ut_currency COLUMN
2598
2599 Check/untaint currency indicators, such as USD or EUR.  May not be null.  If
2600 there is an error, returns the error, otherwise returns false.
2601
2602 =cut
2603
2604 sub ut_currency {
2605   my($self, $field) = @_;
2606   my $value = uc( $self->getfield($field) );
2607   if ( code2currency($value) ) {
2608     $self->setfield($value);
2609   } else {
2610     return "Unknown currency $value";
2611   }
2612
2613   '';
2614 }
2615
2616 =item ut_text COLUMN
2617
2618 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2619 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2620 May not be null.  If there is an error, returns the error, otherwise returns
2621 false.
2622
2623 =cut
2624
2625 sub ut_text {
2626   my($self,$field)=@_;
2627   #warn "msgcat ". \&msgcat. "\n";
2628   #warn "notexist ". \&notexist. "\n";
2629   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2630   # \p{Word} = alphanumerics, marks (diacritics), and connectors
2631   # see perldoc perluniprops
2632   $self->getfield($field)
2633     =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
2634       or return gettext('illegal_or_empty_text'). " $field: ".
2635                  $self->getfield($field);
2636   $self->setfield($field,$1);
2637   '';
2638 }
2639
2640 =item ut_textn COLUMN
2641
2642 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2643 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2644 May be null.  If there is an error, returns the error, otherwise returns false.
2645
2646 =cut
2647
2648 sub ut_textn {
2649   my($self,$field)=@_;
2650   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2651   $self->ut_text($field);
2652 }
2653
2654 =item ut_alpha COLUMN
2655
2656 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
2657 an error, returns the error, otherwise returns false.
2658
2659 =cut
2660
2661 sub ut_alpha {
2662   my($self,$field)=@_;
2663   $self->getfield($field) =~ /^(\w+)$/
2664     or return "Illegal or empty (alphanumeric) $field: ".
2665               $self->getfield($field);
2666   $self->setfield($field,$1);
2667   '';
2668 }
2669
2670 =item ut_alphan COLUMN
2671
2672 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
2673 error, returns the error, otherwise returns false.
2674
2675 =cut
2676
2677 sub ut_alphan {
2678   my($self,$field)=@_;
2679   $self->getfield($field) =~ /^(\w*)$/
2680     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2681   $self->setfield($field,$1);
2682   '';
2683 }
2684
2685 =item ut_alphasn COLUMN
2686
2687 Check/untaint alphanumeric strings, spaces allowed.  May be null.  If there is
2688 an error, returns the error, otherwise returns false.
2689
2690 =cut
2691
2692 sub ut_alphasn {
2693   my($self,$field)=@_;
2694   $self->getfield($field) =~ /^([\w ]*)$/
2695     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2696   $self->setfield($field,$1);
2697   '';
2698 }
2699
2700
2701 =item ut_alpha_lower COLUMN
2702
2703 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
2704 there is an error, returns the error, otherwise returns false.
2705
2706 =cut
2707
2708 sub ut_alpha_lower {
2709   my($self,$field)=@_;
2710   $self->getfield($field) =~ /[[:upper:]]/
2711     and return "Uppercase characters are not permitted in $field";
2712   $self->ut_alpha($field);
2713 }
2714
2715 =item ut_phonen COLUMN [ COUNTRY ]
2716
2717 Check/untaint phone numbers.  May be null.  If there is an error, returns
2718 the error, otherwise returns false.
2719
2720 Takes an optional two-letter ISO 3166-1 alpha-2 country code; without
2721 it or with unsupported countries, ut_phonen simply calls ut_alphan.
2722
2723 =cut
2724
2725 sub ut_phonen {
2726   my( $self, $field, $country ) = @_;
2727   return $self->ut_alphan($field) unless defined $country;
2728   my $phonen = $self->getfield($field);
2729   if ( $phonen eq '' ) {
2730     $self->setfield($field,'');
2731   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2732     $phonen =~ s/\D//g;
2733     $phonen = $conf->config('cust_main-default_areacode').$phonen
2734       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2735     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2736       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2737     $phonen = "$1-$2-$3";
2738     $phonen .= " x$4" if $4;
2739     $self->setfield($field,$phonen);
2740   } else {
2741     warn "warning: don't know how to check phone numbers for country $country";
2742     return $self->ut_textn($field);
2743   }
2744   '';
2745 }
2746
2747 =item ut_hex COLUMN
2748
2749 Check/untaint hexadecimal values.
2750
2751 =cut
2752
2753 sub ut_hex {
2754   my($self, $field) = @_;
2755   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2756     or return "Illegal (hex) $field: ". $self->getfield($field);
2757   $self->setfield($field, uc($1));
2758   '';
2759 }
2760
2761 =item ut_hexn COLUMN
2762
2763 Check/untaint hexadecimal values.  May be null.
2764
2765 =cut
2766
2767 sub ut_hexn {
2768   my($self, $field) = @_;
2769   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2770     or return "Illegal (hex) $field: ". $self->getfield($field);
2771   $self->setfield($field, uc($1));
2772   '';
2773 }
2774
2775 =item ut_mac_addr COLUMN
2776
2777 Check/untaint mac addresses.  May be null.
2778
2779 =cut
2780
2781 sub ut_mac_addr {
2782   my($self, $field) = @_;
2783
2784   my $mac = $self->get($field);
2785   $mac =~ s/\s+//g;
2786   $mac =~ s/://g;
2787   $self->set($field, $mac);
2788
2789   my $e = $self->ut_hex($field);
2790   return $e if $e;
2791
2792   return "Illegal (mac address) $field: ". $self->getfield($field)
2793     unless length($self->getfield($field)) == 12;
2794
2795   '';
2796
2797 }
2798
2799 =item ut_mac_addrn COLUMN
2800
2801 Check/untaint mac addresses.  May be null.
2802
2803 =cut
2804
2805 sub ut_mac_addrn {
2806   my($self, $field) = @_;
2807   ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2808 }
2809
2810 =item ut_ip COLUMN
2811
2812 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2813 to 127.0.0.1.
2814
2815 =cut
2816
2817 sub ut_ip {
2818   my( $self, $field ) = @_;
2819   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2820   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2821     or return "Illegal (IP address) $field: ". $self->getfield($field);
2822   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2823   $self->setfield($field, "$1.$2.$3.$4");
2824   '';
2825 }
2826
2827 =item ut_ipn COLUMN
2828
2829 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2830 to 127.0.0.1.  May be null.
2831
2832 =cut
2833
2834 sub ut_ipn {
2835   my( $self, $field ) = @_;
2836   if ( $self->getfield($field) =~ /^()$/ ) {
2837     $self->setfield($field,'');
2838     '';
2839   } else {
2840     $self->ut_ip($field);
2841   }
2842 }
2843
2844 =item ut_ip46 COLUMN
2845
2846 Check/untaint IPv4 or IPv6 address.
2847
2848 =cut
2849
2850 sub ut_ip46 {
2851   my( $self, $field ) = @_;
2852   my $ip = NetAddr::IP->new($self->getfield($field))
2853     or return "Illegal (IP address) $field: ".$self->getfield($field);
2854   $self->setfield($field, lc($ip->addr));
2855   return '';
2856 }
2857
2858 =item ut_ip46n
2859
2860 Check/untaint IPv6 or IPv6 address.  May be null.
2861
2862 =cut
2863
2864 sub ut_ip46n {
2865   my( $self, $field ) = @_;
2866   if ( $self->getfield($field) =~ /^$/ ) {
2867     $self->setfield($field, '');
2868     return '';
2869   }
2870   $self->ut_ip46($field);
2871 }
2872
2873 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2874
2875 Check/untaint coordinates.
2876 Accepts the following forms:
2877 DDD.DDDDD
2878 -DDD.DDDDD
2879 DDD MM.MMM
2880 -DDD MM.MMM
2881 DDD MM SS
2882 -DDD MM SS
2883 DDD MM MMM
2884 -DDD MM MMM
2885
2886 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2887 The latter form (that is, the MMM are thousands of minutes) is
2888 assumed if the "MMM" is exactly three digits or two digits > 59.
2889
2890 To be safe, just use the DDD.DDDDD form.
2891
2892 If LOWER or UPPER are specified, then the coordinate is checked
2893 for lower and upper bounds, respectively.
2894
2895 =cut
2896
2897 sub ut_coord {
2898   my ($self, $field) = (shift, shift);
2899
2900   my($lower, $upper);
2901   if ( $field =~ /latitude/ ) {
2902     $lower = $lat_lower;
2903     $upper = 90;
2904   } elsif ( $field =~ /longitude/ ) {
2905     $lower = -180;
2906     $upper = $lon_upper;
2907   }
2908
2909   my $coord = $self->getfield($field);
2910   my $neg = $coord =~ s/^(-)//;
2911
2912   my ($d, $m, $s) = (0, 0, 0);
2913
2914   if (
2915     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2916     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2917     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2918   ) {
2919     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2920     $m = $m / 60;
2921     if ($m > 59) {
2922       return "Invalid (coordinate with minutes > 59) $field: "
2923              . $self->getfield($field);
2924     }
2925
2926     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2927
2928     if (defined($lower) and ($coord < $lower)) {
2929       return "Invalid (coordinate < $lower) $field: "
2930              . $self->getfield($field);;
2931     }
2932
2933     if (defined($upper) and ($coord > $upper)) {
2934       return "Invalid (coordinate > $upper) $field: "
2935              . $self->getfield($field);;
2936     }
2937
2938     $self->setfield($field, $coord);
2939     return '';
2940   }
2941
2942   return "Invalid (coordinate) $field: " . $self->getfield($field);
2943
2944 }
2945
2946 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2947
2948 Same as ut_coord, except optionally null.
2949
2950 =cut
2951
2952 sub ut_coordn {
2953
2954   my ($self, $field) = (shift, shift);
2955
2956   if ($self->getfield($field) =~ /^\s*$/) {
2957     return '';
2958   } else {
2959     return $self->ut_coord($field, @_);
2960   }
2961
2962 }
2963
2964 =item ut_domain COLUMN
2965
2966 Check/untaint host and domain names.  May not be null.
2967
2968 =cut
2969
2970 sub ut_domain {
2971   my( $self, $field ) = @_;
2972   #$self->getfield($field) =~/^(\w+\.)*\w+$/
2973   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2974     or return "Illegal (hostname) $field: ". $self->getfield($field);
2975   $self->setfield($field,$1);
2976   '';
2977 }
2978
2979 =item ut_domainn COLUMN
2980
2981 Check/untaint host and domain names.  May be null.
2982
2983 =cut
2984
2985 sub ut_domainn {
2986   my( $self, $field ) = @_;
2987   if ( $self->getfield($field) =~ /^()$/ ) {
2988     $self->setfield($field,'');
2989     '';
2990   } else {
2991     $self->ut_domain($field);
2992   }
2993 }
2994
2995 =item ut_name COLUMN
2996
2997 Check/untaint proper names; allows alphanumerics, spaces and the following
2998 punctuation: , . - '
2999
3000 May not be null.
3001
3002 =cut
3003
3004 sub ut_name {
3005   my( $self, $field ) = @_;
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