FS/FS/Record.pm

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