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   fk_methods_init() unless exists($fk_method_cache{$table});
1112
1113   if ( exists($fk_method_cache{$table}) and
1114        exists($fk_method_cache{$table}{$field}) ) {
1115     return $fk_method_cache{$table}{$field};
1116   } else {
1117     return undef;
1118   }
1119
1120 }
1121
1122 sub fk_methods_init {
1123   warn "[fk_methods_init]\n" if $DEBUG;
1124   foreach my $table ( dbdef->tables ) {
1125     $fk_method_cache{$table} = fk_methods($table);
1126   }
1127 }
1128
1129 sub fk_methods {
1130   my $table = shift;
1131
1132   my %hash = ();
1133
1134   # foreign keys we reference in other tables
1135   foreach my $fk (dbdef->table($table)->foreign_keys) {
1136
1137     my $method = '';
1138     if ( scalar( @{$fk->columns} ) == 1 ) {
1139       if (    ! defined($fk->references)
1140            || ! @{$fk->references}
1141            || $fk->columns->[0] eq $fk->references->[0]
1142       ) {
1143         $method = $fk->table;
1144       } else {
1145         #some sort of hint in the table.pm or schema for methods not named
1146         # after their foreign table (well, not a whole lot different than
1147         # just providing a small subroutine...)
1148       }
1149
1150       if ( $method ) {
1151         $hash{$method} = { #fk_info
1152                            'method' => 'qsearchs',
1153                            'column' => $fk->columns->[0],
1154                            #'references' => $fk->references->[0],
1155                          };
1156       }
1157
1158     }
1159
1160   }
1161
1162   # foreign keys referenced in other tables to us
1163   #  (alas.  why we're cached.  still, might this loop better be done once at
1164   #   schema load time insetad of every time we AUTOLOAD a method on a new
1165   #   class?)
1166   if (! defined $fk_table_cache) {
1167     foreach my $f_table ( dbdef->tables ) {
1168       foreach my $fk (dbdef->table($f_table)->foreign_keys) {
1169         push @{$fk_table_cache->{$fk->table}},[$f_table,$fk];
1170       }
1171     }
1172   }
1173   foreach my $fks (@{$fk_table_cache->{$table}}) {
1174       my ($f_table,$fk) = @$fks;
1175       my $method = '';
1176       if ( scalar( @{$fk->columns} ) == 1 ) {
1177         if (    ! defined($fk->references)
1178              || ! @{$fk->references}
1179              || $fk->columns->[0] eq $fk->references->[0]
1180         ) {
1181           $method = $f_table;
1182         } else {
1183           #some sort of hint in the table.pm or schema for methods not named
1184           # after their foreign table (well, not a whole lot different than
1185           # just providing a small subroutine...)
1186         }
1187
1188         if ( $method ) {
1189           $hash{$method} = { #fk_info
1190                              'method' => 'qsearch',
1191                              'column' => $fk->columns->[0], #references||column
1192                              #'references' => $fk->column->[0],
1193                            };
1194         }
1195
1196       }
1197   }
1198
1199   \%hash;
1200 }
1201
1202 =item hash
1203
1204 Returns a list of the column/value pairs, usually for assigning to a new hash.
1205
1206 To make a distinct duplicate of an FS::Record object, you can do:
1207
1208     $new = new FS::Record ( $old->table, { $old->hash } );
1209
1210 =cut
1211
1212 sub hash {
1213   my($self) = @_;
1214   confess $self. ' -> hash: Hash attribute is undefined'
1215     unless defined($self->{'Hash'});
1216   %{ $self->{'Hash'} };
1217 }
1218
1219 =item hashref
1220
1221 Returns a reference to the column/value hash.  This may be deprecated in the
1222 future; if there's a reason you can't just use the autoloaded or get/set
1223 methods, speak up.
1224
1225 =cut
1226
1227 sub hashref {
1228   my($self) = @_;
1229   $self->{'Hash'};
1230 }
1231
1232 #fallbacks/generics
1233
1234 sub API_getinfo {
1235   my $self = shift;
1236   +{ ( map { $_=>$self->$_ } $self->fields ),
1237    };
1238 }
1239
1240 sub API_insert {
1241   my( $class, %opt ) = @_;
1242   my $table = $class->table;
1243   my $self = $class->new( { map { $_ => $opt{$_} } fields($table) } );
1244   my $error = $self->insert;
1245   return +{ 'error' => $error } if $error;
1246   my $pkey = $self->pkey;
1247   return +{ 'error'       => '',
1248             'primary_key' => $pkey,
1249             $pkey         => $self->$pkey,
1250           };
1251 }
1252
1253 =item modified
1254
1255 Returns true if any of this object's values have been modified with set (or via
1256 an autoloaded method).  Doesn't yet recognize when you retreive a hashref and
1257 modify that.
1258
1259 =cut
1260
1261 sub modified {
1262   my $self = shift;
1263   $self->{'modified'};
1264 }
1265
1266 =item select_for_update
1267
1268 Selects this record with the SQL "FOR UPDATE" command.  This can be useful as
1269 a mutex.
1270
1271 =cut
1272
1273 sub select_for_update {
1274   my $self = shift;
1275   my $primary_key = $self->primary_key;
1276   qsearchs( {
1277     'select'    => '*',
1278     'table'     => $self->table,
1279     'hashref'   => { $primary_key => $self->$primary_key() },
1280     'extra_sql' => 'FOR UPDATE',
1281   } );
1282 }
1283
1284 =item lock_table
1285
1286 Locks this table with a database-driver specific lock method.  This is used
1287 as a mutex in order to do a duplicate search.
1288
1289 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
1290
1291 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
1292
1293 Errors are fatal; no useful return value.
1294
1295 Note: To use this method for new tables other than svc_acct and svc_phone,
1296 edit freeside-upgrade and add those tables to the duplicate_lock list.
1297
1298 =cut
1299
1300 sub lock_table {
1301   my $self = shift;
1302   my $table = $self->table;
1303
1304   warn "$me locking $table table\n" if $DEBUG;
1305
1306   if ( driver_name =~ /^Pg/i ) {
1307
1308     dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
1309       or die dbh->errstr;
1310
1311   } elsif ( driver_name =~ /^mysql/i ) {
1312
1313     dbh->do("SELECT * FROM duplicate_lock
1314                WHERE lockname = '$table'
1315                FOR UPDATE"
1316            ) or die dbh->errstr;
1317
1318   } else {
1319
1320     die "unknown database ". driver_name. "; don't know how to lock table";
1321
1322   }
1323
1324   warn "$me acquired $table table lock\n" if $DEBUG;
1325
1326 }
1327
1328 =item insert
1329
1330 Inserts this record to the database.  If there is an error, returns the error,
1331 otherwise returns false.
1332
1333 =cut
1334
1335 sub insert {
1336   my $self = shift;
1337   my $saved = {};
1338
1339   warn "$self -> insert" if $DEBUG;
1340
1341   my $error = $self->check;
1342   return $error if $error;
1343
1344   #single-field non-null unique keys are given a value if empty
1345   #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
1346   foreach ( $self->dbdef_table->unique_singles) {
1347     next if $self->getfield($_);
1348     next if $self->dbdef_table->column($_)->null eq 'NULL';
1349     $self->unique($_);
1350   }
1351
1352   #and also the primary key, if the database isn't going to
1353   my $primary_key = $self->dbdef_table->primary_key;
1354   my $db_seq = 0;
1355   if ( $primary_key ) {
1356     my $col = $self->dbdef_table->column($primary_key);
1357
1358     $db_seq =
1359       uc($col->type) =~ /^(BIG)?SERIAL\d?/
1360       || ( driver_name eq 'Pg'
1361              && defined($col->default)
1362              && $col->quoted_default =~ /^nextval\(/i
1363          )
1364       || ( driver_name eq 'mysql'
1365              && defined($col->local)
1366              && $col->local =~ /AUTO_INCREMENT/i
1367          );
1368     $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
1369   }
1370
1371   my $table = $self->table;
1372
1373   # Encrypt before the database
1374   if (    scalar( eval '@FS::'. $table . '::encrypted_fields')
1375        && $conf_encryption
1376   ) {
1377     foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
1378       next if $field eq 'payinfo'
1379                 && ($self->isa('FS::payinfo_transaction_Mixin')
1380                     || $self->isa('FS::payinfo_Mixin') )
1381                 && $self->payby
1382                 && !grep { $self->payby eq $_ } @encrypt_payby;
1383       $saved->{$field} = $self->getfield($field);
1384       $self->setfield($field, $self->encrypt($self->getfield($field)));
1385     }
1386   }
1387
1388   #false laziness w/delete
1389   my @real_fields =
1390     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1391     real_fields($table)
1392   ;
1393
1394   my $statement = "INSERT INTO $table ";
1395   my @bind_values = ();
1396
1397   if ( ! @real_fields ) {
1398
1399     $statement .= 'DEFAULT VALUES';
1400
1401   } else {
1402
1403     if ( $use_placeholders ) {
1404
1405       @bind_values = map $self->getfield($_), @real_fields;
1406
1407       $statement .=
1408         "( ".
1409           join( ', ', @real_fields ).
1410         ") VALUES (".
1411           join( ', ', map '?', @real_fields ). # @bind_values ).
1412          ")"
1413       ;
1414
1415     } else {
1416
1417       my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
1418
1419       $statement .=
1420         "( ".
1421           join( ', ', @real_fields ).
1422         ") VALUES (".
1423           join( ', ', @values ).
1424          ")"
1425       ;
1426
1427    }
1428
1429   }
1430
1431   warn "[debug]$me $statement\n" if $DEBUG > 1;
1432   my $sth = dbh->prepare($statement) or return dbh->errstr;
1433
1434   local $SIG{HUP} = 'IGNORE';
1435   local $SIG{INT} = 'IGNORE';
1436   local $SIG{QUIT} = 'IGNORE';
1437   local $SIG{TERM} = 'IGNORE';
1438   local $SIG{TSTP} = 'IGNORE';
1439   local $SIG{PIPE} = 'IGNORE';
1440
1441   $sth->execute(@bind_values) or return $sth->errstr;
1442
1443   # get inserted id from the database, if applicable & needed
1444   if ( $db_seq && ! $self->getfield($primary_key) ) {
1445     warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
1446
1447     my $insertid = '';
1448
1449     if ( driver_name eq 'Pg' ) {
1450
1451       #my $oid = $sth->{'pg_oid_status'};
1452       #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
1453
1454       my $default = $self->dbdef_table->column($primary_key)->quoted_default;
1455       unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
1456         dbh->rollback if $FS::UID::AutoCommit;
1457         return "can't parse $table.$primary_key default value".
1458                " for sequence name: $default";
1459       }
1460       my $sequence = $1;
1461
1462       my $i_sql = "SELECT currval('$sequence')";
1463       my $i_sth = dbh->prepare($i_sql) or do {
1464         dbh->rollback if $FS::UID::AutoCommit;
1465         return dbh->errstr;
1466       };
1467       $i_sth->execute() or do { #$i_sth->execute($oid)
1468         dbh->rollback if $FS::UID::AutoCommit;
1469         return $i_sth->errstr;
1470       };
1471       $insertid = $i_sth->fetchrow_arrayref->[0];
1472
1473     } elsif ( driver_name eq 'mysql' ) {
1474
1475       $insertid = dbh->{'mysql_insertid'};
1476       # work around mysql_insertid being null some of the time, ala RT :/
1477       unless ( $insertid ) {
1478         warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
1479              "using SELECT LAST_INSERT_ID();";
1480         my $i_sql = "SELECT LAST_INSERT_ID()";
1481         my $i_sth = dbh->prepare($i_sql) or do {
1482           dbh->rollback if $FS::UID::AutoCommit;
1483           return dbh->errstr;
1484         };
1485         $i_sth->execute or do {
1486           dbh->rollback if $FS::UID::AutoCommit;
1487           return $i_sth->errstr;
1488         };
1489         $insertid = $i_sth->fetchrow_arrayref->[0];
1490       }
1491
1492     } else {
1493
1494       dbh->rollback if $FS::UID::AutoCommit;
1495       return "don't know how to retreive inserted ids from ". driver_name.
1496              ", try using counterfiles (maybe run dbdef-create?)";
1497
1498     }
1499
1500     $self->setfield($primary_key, $insertid);
1501
1502   }
1503
1504   my $h_sth;
1505   if ( defined( dbdef->table('h_'. $table) ) && ! $no_history ) {
1506     my $h_statement = $self->_h_statement('insert');
1507     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1508     $h_sth = dbh->prepare($h_statement) or do {
1509       dbh->rollback if $FS::UID::AutoCommit;
1510       return dbh->errstr;
1511     };
1512   } else {
1513     $h_sth = '';
1514   }
1515   $h_sth->execute or return $h_sth->errstr if $h_sth;
1516
1517   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1518
1519   # Now that it has been saved, reset the encrypted fields so that $new
1520   # can still be used.
1521   foreach my $field (keys %{$saved}) {
1522     $self->setfield($field, $saved->{$field});
1523   }
1524
1525   '';
1526 }
1527
1528 =item add
1529
1530 Depriciated (use insert instead).
1531
1532 =cut
1533
1534 sub add {
1535   cluck "warning: FS::Record::add deprecated!";
1536   insert @_; #call method in this scope
1537 }
1538
1539 =item delete
1540
1541 Delete this record from the database.  If there is an error, returns the error,
1542 otherwise returns false.
1543
1544 =cut
1545
1546 sub delete {
1547   my $self = shift;
1548
1549   my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1550     map {
1551       $self->getfield($_) eq ''
1552         #? "( $_ IS NULL OR $_ = \"\" )"
1553         ? ( driver_name eq 'Pg'
1554               ? "$_ IS NULL"
1555               : "( $_ IS NULL OR $_ = \"\" )"
1556           )
1557         : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1558     } ( $self->dbdef_table->primary_key )
1559           ? ( $self->dbdef_table->primary_key)
1560           : real_fields($self->table)
1561   );
1562   warn "[debug]$me $statement\n" if $DEBUG > 1;
1563   my $sth = dbh->prepare($statement) or return dbh->errstr;
1564
1565   my $h_sth;
1566   if ( defined dbdef->table('h_'. $self->table) ) {
1567     my $h_statement = $self->_h_statement('delete');
1568     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1569     $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1570   } else {
1571     $h_sth = '';
1572   }
1573
1574   my $primary_key = $self->dbdef_table->primary_key;
1575
1576   local $SIG{HUP} = 'IGNORE';
1577   local $SIG{INT} = 'IGNORE';
1578   local $SIG{QUIT} = 'IGNORE';
1579   local $SIG{TERM} = 'IGNORE';
1580   local $SIG{TSTP} = 'IGNORE';
1581   local $SIG{PIPE} = 'IGNORE';
1582
1583   my $rc = $sth->execute or return $sth->errstr;
1584   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1585   $h_sth->execute or return $h_sth->errstr if $h_sth;
1586
1587   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1588
1589   #no need to needlessly destoy the data either (causes problems actually)
1590   #undef $self; #no need to keep object!
1591
1592   '';
1593 }
1594
1595 =item del
1596
1597 Depriciated (use delete instead).
1598
1599 =cut
1600
1601 sub del {
1602   cluck "warning: FS::Record::del deprecated!";
1603   &delete(@_); #call method in this scope
1604 }
1605
1606 =item replace OLD_RECORD
1607
1608 Replace the OLD_RECORD with this one in the database.  If there is an error,
1609 returns the error, otherwise returns false.
1610
1611 =cut
1612
1613 sub replace {
1614   my ($new, $old) = (shift, shift);
1615
1616   $old = $new->replace_old unless defined($old);
1617
1618   warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1619
1620   if ( $new->can('replace_check') ) {
1621     my $error = $new->replace_check($old);
1622     return $error if $error;
1623   }
1624
1625   return "Records not in same table!" unless $new->table eq $old->table;
1626
1627   my $primary_key = $old->dbdef_table->primary_key;
1628   return "Can't change primary key $primary_key ".
1629          'from '. $old->getfield($primary_key).
1630          ' to ' . $new->getfield($primary_key)
1631     if $primary_key
1632        && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1633
1634   my $error = $new->check;
1635   return $error if $error;
1636
1637   # Encrypt for replace
1638   my $saved = {};
1639   if (    scalar( eval '@FS::'. $new->table . '::encrypted_fields')
1640        && $conf_encryption
1641   ) {
1642     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1643       next if $field eq 'payinfo'
1644                 && ($new->isa('FS::payinfo_transaction_Mixin')
1645                     || $new->isa('FS::payinfo_Mixin') )
1646                 && $new->payby
1647                 && !grep { $new->payby eq $_ } @encrypt_payby;
1648       $saved->{$field} = $new->getfield($field);
1649       $new->setfield($field, $new->encrypt($new->getfield($field)));
1650     }
1651   }
1652
1653   #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1654   my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1655                    ? ($_, $new->getfield($_)) : () } $old->fields;
1656
1657   unless (keys(%diff) || $no_update_diff ) {
1658     carp "[warning]$me ". ref($new)."->replace ".
1659            ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
1660          ": records identical"
1661       unless $nowarn_identical;
1662     return '';
1663   }
1664
1665   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1666     map {
1667       "$_ = ". _quote($new->getfield($_),$old->table,$_)
1668     } real_fields($old->table)
1669   ). ' WHERE '.
1670     join(' AND ',
1671       map {
1672
1673         if ( $old->getfield($_) eq '' ) {
1674
1675          #false laziness w/qsearch
1676          if ( driver_name eq 'Pg' ) {
1677             my $type = $old->dbdef_table->column($_)->type;
1678             if ( $type =~ /(int|(big)?serial)/i ) {
1679               qq-( $_ IS NULL )-;
1680             } else {
1681               qq-( $_ IS NULL OR $_ = '' )-;
1682             }
1683           } else {
1684             qq-( $_ IS NULL OR $_ = "" )-;
1685           }
1686
1687         } else {
1688           "$_ = ". _quote($old->getfield($_),$old->table,$_);
1689         }
1690
1691       } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1692     )
1693   ;
1694   warn "[debug]$me $statement\n" if $DEBUG > 1;
1695   my $sth = dbh->prepare($statement) or return dbh->errstr;
1696
1697   my $h_old_sth;
1698   if ( defined dbdef->table('h_'. $old->table) ) {
1699     my $h_old_statement = $old->_h_statement('replace_old');
1700     warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1701     $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1702   } else {
1703     $h_old_sth = '';
1704   }
1705
1706   my $h_new_sth;
1707   if ( defined dbdef->table('h_'. $new->table) ) {
1708     my $h_new_statement = $new->_h_statement('replace_new');
1709     warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1710     $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1711   } else {
1712     $h_new_sth = '';
1713   }
1714
1715   local $SIG{HUP} = 'IGNORE';
1716   local $SIG{INT} = 'IGNORE';
1717   local $SIG{QUIT} = 'IGNORE';
1718   local $SIG{TERM} = 'IGNORE';
1719   local $SIG{TSTP} = 'IGNORE';
1720   local $SIG{PIPE} = 'IGNORE';
1721
1722   my $rc = $sth->execute or return $sth->errstr;
1723   #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1724   $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1725   $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1726
1727   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1728
1729   # Now that it has been saved, reset the encrypted fields so that $new
1730   # can still be used.
1731   foreach my $field (keys %{$saved}) {
1732     $new->setfield($field, $saved->{$field});
1733   }
1734
1735   '';
1736
1737 }
1738
1739 sub replace_old {
1740   my( $self ) = shift;
1741   warn "[$me] replace called with no arguments; autoloading old record\n"
1742     if $DEBUG;
1743
1744   my $primary_key = $self->dbdef_table->primary_key;
1745   if ( $primary_key ) {
1746     $self->by_key( $self->$primary_key() ) #this is what's returned
1747       or croak "can't find ". $self->table. ".$primary_key ".
1748         $self->$primary_key();
1749   } else {
1750     croak $self->table. " has no primary key; pass old record as argument";
1751   }
1752
1753 }
1754
1755 =item rep
1756
1757 Depriciated (use replace instead).
1758
1759 =cut
1760
1761 sub rep {
1762   cluck "warning: FS::Record::rep deprecated!";
1763   replace @_; #call method in this scope
1764 }
1765
1766 =item check
1767
1768 Checks custom fields. Subclasses should still provide a check method to validate
1769 non-custom fields, etc., and call this method via $self->SUPER::check.
1770
1771 =cut
1772
1773 sub check {
1774     my $self = shift;
1775     foreach my $field ($self->virtual_fields) {
1776         my $error = $self->ut_textn($field);
1777         return $error if $error;
1778     }
1779     '';
1780 }
1781
1782 =item virtual_fields [ TABLE ]
1783
1784 Returns a list of virtual fields defined for the table.  This should not
1785 be exported, and should only be called as an instance or class method.
1786
1787 =cut
1788
1789 sub virtual_fields {
1790   my $self = shift;
1791   my $table;
1792   $table = $self->table or confess "virtual_fields called on non-table";
1793
1794   confess "Unknown table $table" unless dbdef->table($table);
1795
1796   return () unless dbdef->table('part_virtual_field');
1797
1798   unless ( $virtual_fields_cache{$table} ) {
1799     my $concat = [ "'cf_'", "name" ];
1800     my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' .
1801                 "WHERE dbtable = '$table'";
1802     my $dbh = dbh;
1803     my $result = $dbh->selectcol_arrayref($query);
1804     confess "Error executing virtual fields query: $query: ". $dbh->errstr
1805       if $dbh->err;
1806     $virtual_fields_cache{$table} = $result;
1807   }
1808
1809   @{$virtual_fields_cache{$table}};
1810
1811 }
1812
1813 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1814
1815 Processes a batch import as a queued JSRPC job
1816
1817 JOB is an FS::queue entry.
1818
1819 OPTIONS_HASHREF can have the following keys:
1820
1821 =over 4
1822
1823 =item table
1824
1825 Table name (required).
1826
1827 =item params
1828
1829 Arrayref of field names for static fields.  They will be given values from the
1830 PARAMS hashref and passed as a "params" hashref to batch_import.
1831
1832 =item formats
1833
1834 Formats hashref.  Keys are field names, values are listrefs that define the
1835 format.
1836
1837 Each listref value can be a column name or a code reference.  Coderefs are run
1838 with the row object, data and a FS::Conf object as the three parameters.
1839 For example, this coderef does the same thing as using the "columnname" string:
1840
1841   sub {
1842     my( $record, $data, $conf ) = @_;
1843     $record->columnname( $data );
1844   },
1845
1846 Coderefs are run after all "column name" fields are assigned.
1847
1848 =item format_types
1849
1850 Optional format hashref of types.  Keys are field names, values are "csv",
1851 "xls" or "fixedlength".  Overrides automatic determination of file type
1852 from extension.
1853
1854 =item format_headers
1855
1856 Optional format hashref of header lines.  Keys are field names, values are 0
1857 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1858 number of lines.
1859
1860 =item format_sep_chars
1861
1862 Optional format hashref of CSV sep_chars.  Keys are field names, values are the
1863 CSV separation character.
1864
1865 =item format_fixedlenth_formats
1866
1867 Optional format hashref of fixed length format defintiions.  Keys are field
1868 names, values Parse::FixedLength listrefs of field definitions.
1869
1870 =item default_csv
1871
1872 Set true to default to CSV file type if the filename does not contain a
1873 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1874 format_types).
1875
1876 =back
1877
1878 PARAMS is a hashref (or base64-encoded Storable hashref) containing the
1879 POSTed data.  It must contain the field "uploaded files", generated by
1880 /elements/file-upload.html and containing the list of uploaded files.
1881 Currently only supports a single file named "file".
1882
1883 =cut
1884
1885 use Data::Dumper;
1886 sub process_batch_import {
1887   my($job, $opt, $param) = @_;
1888
1889   my $table = $opt->{table};
1890   my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1891   my %formats = %{ $opt->{formats} };
1892
1893   warn Dumper($param) if $DEBUG;
1894
1895   my $files = $param->{'uploaded_files'}
1896     or die "No files provided.\n";
1897
1898   my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1899
1900   my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1901   my $file = $dir. $files{'file'};
1902
1903   my %iopt = (
1904     #class-static
1905     table                      => $table,
1906     formats                    => \%formats,
1907     format_types               => $opt->{format_types},
1908     format_headers             => $opt->{format_headers},
1909     format_sep_chars           => $opt->{format_sep_chars},
1910     format_fixedlength_formats => $opt->{format_fixedlength_formats},
1911     format_xml_formats         => $opt->{format_xml_formats},
1912     format_asn_formats         => $opt->{format_asn_formats},
1913     format_row_callbacks       => $opt->{format_row_callbacks},
1914     format_hash_callbacks      => $opt->{format_hash_callbacks},
1915     #per-import
1916     job                        => $job,
1917     file                       => $file,
1918     #type                       => $type,
1919     format                     => $param->{format},
1920     params                     => { map { $_ => $param->{$_} } @pass_params },
1921     #?
1922     default_csv                => $opt->{default_csv},
1923     preinsert_callback         => $opt->{preinsert_callback},
1924     postinsert_callback        => $opt->{postinsert_callback},
1925     insert_args_callback       => $opt->{insert_args_callback},
1926   );
1927
1928   if ( $opt->{'batch_namecol'} ) {
1929     $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1930     $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1931   }
1932
1933   my $error = FS::Record::batch_import( \%iopt );
1934
1935   unlink $file;
1936
1937   die "$error\n" if $error;
1938 }
1939
1940 =item batch_import PARAM_HASHREF
1941
1942 Class method for batch imports.  Available params:
1943
1944 =over 4
1945
1946 =item table
1947
1948 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1949
1950 =item formats
1951
1952 =item format_types
1953
1954 =item format_headers
1955
1956 =item format_sep_chars
1957
1958 =item format_fixedlength_formats
1959
1960 =item format_row_callbacks
1961
1962 =item format_hash_callbacks - After parsing, before object creation
1963
1964 =item fields - Alternate way to specify import, specifying import fields directly as a listref
1965
1966 =item preinsert_callback
1967
1968 =item postinsert_callback
1969
1970 =item params
1971
1972 =item job
1973
1974 FS::queue object, will be updated with progress
1975
1976 =item file
1977
1978 =item type
1979
1980 csv, xls, fixedlength, xml
1981
1982 =item empty_ok
1983
1984 =back
1985
1986 =cut
1987
1988 use Data::Dumper;
1989 sub batch_import {
1990   my $param = shift;
1991
1992   warn "$me batch_import call with params: \n". Dumper($param)
1993     if $DEBUG;
1994
1995   my $table   = $param->{table};
1996
1997   my $job     = $param->{job};
1998   my $file    = $param->{file};
1999   my $params  = $param->{params} || {};
2000
2001   my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
2002   my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
2003
2004   my( $type, $header, $sep_char,
2005       $fixedlength_format, $xml_format, $asn_format,
2006       $parser_opt, $row_callback, $hash_callback, @fields );
2007
2008   my $postinsert_callback = '';
2009   $postinsert_callback = $param->{'postinsert_callback'}
2010           if $param->{'postinsert_callback'};
2011   my $preinsert_callback = '';
2012   $preinsert_callback = $param->{'preinsert_callback'}
2013           if $param->{'preinsert_callback'};
2014   my $insert_args_callback = '';
2015   $insert_args_callback = $param->{'insert_args_callback'}
2016           if $param->{'insert_args_callback'};
2017
2018   if ( $param->{'format'} ) {
2019
2020     my $format  = $param->{'format'};
2021     my $formats = $param->{formats};
2022     die "unknown format $format" unless exists $formats->{ $format };
2023
2024     $type = $param->{'format_types'}
2025             ? $param->{'format_types'}{ $format }
2026             : $param->{type} || 'csv';
2027
2028
2029     $header = $param->{'format_headers'}
2030                ? $param->{'format_headers'}{ $param->{'format'} }
2031                : 0;
2032
2033     $sep_char = $param->{'format_sep_chars'}
2034                   ? $param->{'format_sep_chars'}{ $param->{'format'} }
2035                   : ',';
2036
2037     $fixedlength_format =
2038       $param->{'format_fixedlength_formats'}
2039         ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
2040         : '';
2041
2042     $parser_opt =
2043       $param->{'format_parser_opts'}
2044         ? $param->{'format_parser_opts'}{ $param->{'format'} }
2045         : {};
2046
2047     $xml_format =
2048       $param->{'format_xml_formats'}
2049         ? $param->{'format_xml_formats'}{ $param->{'format'} }
2050         : '';
2051
2052     $asn_format =
2053       $param->{'format_asn_formats'}
2054         ? $param->{'format_asn_formats'}{ $param->{'format'} }
2055         : '';
2056
2057     $row_callback =
2058       $param->{'format_row_callbacks'}
2059         ? $param->{'format_row_callbacks'}{ $param->{'format'} }
2060         : '';
2061
2062     $hash_callback =
2063       $param->{'format_hash_callbacks'}
2064         ? $param->{'format_hash_callbacks'}{ $param->{'format'} }
2065         : '';
2066
2067     @fields = @{ $formats->{ $format } };
2068
2069   } elsif ( $param->{'fields'} ) {
2070
2071     $type = ''; #infer from filename
2072     $header = 0;
2073     $sep_char = ',';
2074     $fixedlength_format = '';
2075     $row_callback = '';
2076     $hash_callback = '';
2077     @fields = @{ $param->{'fields'} };
2078
2079   } else {
2080     die "neither format nor fields specified";
2081   }
2082
2083   #my $file    = $param->{file};
2084
2085   unless ( $type ) {
2086     if ( $file =~ /\.(\w+)$/i ) {
2087       $type = lc($1);
2088     } else {
2089       #or error out???
2090       warn "can't parse file type from filename $file; defaulting to CSV";
2091       $type = 'csv';
2092     }
2093     $type = 'csv'
2094       if $param->{'default_csv'} && $type ne 'xls';
2095   }
2096
2097
2098   my $row = 0;
2099   my $count;
2100   my $parser;
2101   my @buffer = ();
2102   my $asn_header_buffer;
2103   if ( $type eq 'csv' || $type eq 'fixedlength' ) {
2104
2105     if ( $type eq 'csv' ) {
2106
2107       $parser_opt->{'binary'} = 1;
2108       $parser_opt->{'sep_char'} = $sep_char if $sep_char;
2109       $parser = Text::CSV_XS->new($parser_opt);
2110
2111     } elsif ( $type eq 'fixedlength' ) {
2112
2113       eval "use Parse::FixedLength;";
2114       die $@ if $@;
2115       $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
2116
2117     } else {
2118       die "Unknown file type $type\n";
2119     }
2120
2121     @buffer = split(/\r?\n/, slurp($file) );
2122     splice(@buffer, 0, ($header || 0) );
2123     $count = scalar(@buffer);
2124
2125   } elsif ( $type eq 'xls' ) {
2126
2127     eval "use Spreadsheet::ParseExcel;";
2128     die $@ if $@;
2129
2130     eval "use DateTime::Format::Excel;";
2131     #for now, just let the error be thrown if it is used, since only CDR
2132     # formats bill_west and troop use it, not other excel-parsing things
2133     #die $@ if $@;
2134
2135     my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
2136
2137     $parser = $excel->{Worksheet}[0]; #first sheet
2138
2139     $count = $parser->{MaxRow} || $parser->{MinRow};
2140     $count++;
2141
2142     $row = $header || 0;
2143
2144   } elsif ( $type eq 'xml' ) {
2145
2146     # FS::pay_batch
2147     eval "use XML::Simple;";
2148     die $@ if $@;
2149     my $xmlrow = $xml_format->{'xmlrow'};
2150     $parser = $xml_format->{'xmlkeys'};
2151     die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
2152     my $data = XML::Simple::XMLin(
2153       $file,
2154       'SuppressEmpty' => '', #sets empty values to ''
2155       'KeepRoot'      => 1,
2156     );
2157     my $rows = $data;
2158     $rows = $rows->{$_} foreach @$xmlrow;
2159     $rows = [ $rows ] if ref($rows) ne 'ARRAY';
2160     $count = @buffer = @$rows;
2161
2162   } elsif ( $type eq 'asn.1' ) {
2163
2164     eval "use Convert::ASN1";
2165     die $@ if $@;
2166
2167     my $asn = Convert::ASN1->new;
2168     $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
2169
2170     $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
2171
2172     my $data = slurp($file);
2173     my $asn_output = $parser->decode( $data )
2174       or return "No ". $asn_format->{'macro'}. " found\n";
2175
2176     $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
2177
2178     my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
2179     $count = @buffer = @$rows;
2180
2181   } else {
2182     die "Unknown file type $type\n";
2183   }
2184
2185   #my $columns;
2186
2187   local $SIG{HUP} = 'IGNORE';
2188   local $SIG{INT} = 'IGNORE';
2189   local $SIG{QUIT} = 'IGNORE';
2190   local $SIG{TERM} = 'IGNORE';
2191   local $SIG{TSTP} = 'IGNORE';
2192   local $SIG{PIPE} = 'IGNORE';
2193
2194   my $oldAutoCommit = $FS::UID::AutoCommit;
2195   local $FS::UID::AutoCommit = 0;
2196   my $dbh = dbh;
2197
2198   #my $params  = $param->{params} || {};
2199   if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
2200     my $batch_col   = $param->{'batch_keycol'};
2201
2202     my $batch_class = 'FS::'. $param->{'batch_table'};
2203     my $batch = $batch_class->new({
2204       $param->{'batch_namecol'} => $param->{'batch_namevalue'}
2205     });
2206     my $error = $batch->insert;
2207     if ( $error ) {
2208       $dbh->rollback if $oldAutoCommit;
2209       return "can't insert batch record: $error";
2210     }
2211     #primary key via dbdef? (so the column names don't have to match)
2212     my $batch_value = $batch->get( $param->{'batch_keycol'} );
2213
2214     $params->{ $batch_col } = $batch_value;
2215   }
2216
2217   #my $job     = $param->{job};
2218   my $line;
2219   my $imported = 0;
2220   my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
2221   while (1) {
2222
2223     my @columns = ();
2224     my %hash = %$params;
2225     if ( $type eq 'csv' ) {
2226
2227       last unless scalar(@buffer);
2228       $line = shift(@buffer);
2229
2230       next if $line =~ /^\s*$/; #skip empty lines
2231
2232       $line = &{$row_callback}($line) if $row_callback;
2233
2234       next if $line =~ /^\s*$/; #skip empty lines
2235
2236       $parser->parse($line) or do {
2237         $dbh->rollback if $oldAutoCommit;
2238         return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
2239       };
2240       @columns = $parser->fields();
2241
2242     } elsif ( $type eq 'fixedlength' ) {
2243
2244       last unless scalar(@buffer);
2245       $line = shift(@buffer);
2246
2247       @columns = $parser->parse($line);
2248
2249     } elsif ( $type eq 'xls' ) {
2250
2251       last if $row > ($parser->{MaxRow} || $parser->{MinRow})
2252            || ! $parser->{Cells}[$row];
2253
2254       my @row = @{ $parser->{Cells}[$row] };
2255       @columns = map $_->{Val}, @row;
2256
2257       #my $z = 'A';
2258       #warn $z++. ": $_\n" for @columns;
2259
2260     } elsif ( $type eq 'xml' ) {
2261
2262       # $parser = [ 'Column0Key', 'Column1Key' ... ]
2263       last unless scalar(@buffer);
2264       my $row = shift @buffer;
2265       @columns = @{ $row }{ @$parser };
2266
2267     } elsif ( $type eq 'asn.1' ) {
2268
2269       last unless scalar(@buffer);
2270       my $row = shift @buffer;
2271       &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2272         if $asn_format->{row_callback};
2273       foreach my $key ( keys %{ $asn_format->{map} } ) {
2274         $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2275       }
2276
2277     } else {
2278       die "Unknown file type $type\n";
2279     }
2280
2281     my @later = ();
2282
2283     foreach my $field ( @fields ) {
2284
2285       my $value = shift @columns;
2286
2287       if ( ref($field) eq 'CODE' ) {
2288         #&{$field}(\%hash, $value);
2289         push @later, $field, $value;
2290       } else {
2291         #??? $hash{$field} = $value if length($value);
2292         $hash{$field} = $value if defined($value) && length($value);
2293       }
2294
2295     }
2296
2297     if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
2298                          && length($1) == $custnum_length ) {
2299       $hash{custnum} = $2;
2300     }
2301
2302     %hash = &{$hash_callback}(%hash) if $hash_callback;
2303
2304     #my $table   = $param->{table};
2305     my $class = "FS::$table";
2306
2307     my $record = $class->new( \%hash );
2308
2309     my $param = {};
2310     while ( scalar(@later) ) {
2311       my $sub = shift @later;
2312       my $data = shift @later;
2313       eval {
2314         &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2315       };
2316       if ( $@ ) {
2317         $dbh->rollback if $oldAutoCommit;
2318         return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2319       }
2320       last if exists( $param->{skiprow} );
2321     }
2322     next if exists( $param->{skiprow} );
2323
2324     if ( $preinsert_callback ) {
2325       my $error = &{$preinsert_callback}($record, $param);
2326       if ( $error ) {
2327         $dbh->rollback if $oldAutoCommit;
2328         return "preinsert_callback error". ( $line ? " for $line" : '' ).
2329                ": $error";
2330       }
2331       next if exists $param->{skiprow} && $param->{skiprow};
2332     }
2333
2334     my @insert_args = ();
2335     if ( $insert_args_callback ) {
2336       @insert_args = &{$insert_args_callback}($record, $param);
2337     }
2338
2339     my $error = $record->insert(@insert_args);
2340
2341     if ( $error ) {
2342       $dbh->rollback if $oldAutoCommit;
2343       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2344     }
2345
2346     $row++;
2347     $imported++;
2348
2349     if ( $postinsert_callback ) {
2350       my $error = &{$postinsert_callback}($record, $param);
2351       if ( $error ) {
2352         $dbh->rollback if $oldAutoCommit;
2353         return "postinsert_callback error". ( $line ? " for $line" : '' ).
2354                ": $error";
2355       }
2356     }
2357
2358     if ( $job && time - $min_sec > $last ) { #progress bar
2359       $job->update_statustext( int(100 * $imported / $count) );
2360       $last = time;
2361     }
2362
2363   }
2364
2365   unless ( $imported || $param->{empty_ok} ) {
2366     $dbh->rollback if $oldAutoCommit;
2367     return "Empty file!";
2368   }
2369
2370   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2371
2372   ''; #no error
2373
2374 }
2375
2376 sub _h_statement {
2377   my( $self, $action, $time ) = @_;
2378
2379   $time ||= time;
2380
2381   my %nohistory = map { $_=>1 } $self->nohistory_fields;
2382
2383   my @fields =
2384     grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2385     real_fields($self->table);
2386   ;
2387
2388   # If we're encrypting then don't store the payinfo in the history
2389   if ( $conf_encryption && $self->table ne 'banned_pay' ) {
2390     @fields = grep { $_ ne 'payinfo' } @fields;
2391   }
2392
2393   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2394
2395   "INSERT INTO h_". $self->table. " ( ".
2396       join(', ', qw(history_date history_usernum history_action), @fields ).
2397     ") VALUES (".
2398       join(', ', $time,
2399                  $FS::CurrentUser::CurrentUser->usernum,
2400                  dbh->quote($action),
2401                  @values
2402       ).
2403     ")"
2404   ;
2405 }
2406
2407 =item unique COLUMN
2408
2409 B<Warning>: External use is B<deprecated>.
2410
2411 Replaces COLUMN in record with a unique number, using counters in the
2412 filesystem.  Used by the B<insert> method on single-field unique columns
2413 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2414 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2415
2416 Returns the new value.
2417
2418 =cut
2419
2420 sub unique {
2421   my($self,$field) = @_;
2422   my($table)=$self->table;
2423
2424   croak "Unique called on field $field, but it is ",
2425         $self->getfield($field),
2426         ", not null!"
2427     if $self->getfield($field);
2428
2429   #warn "table $table is tainted" if is_tainted($table);
2430   #warn "field $field is tainted" if is_tainted($field);
2431
2432   my($counter) = new File::CounterFile "$table.$field",0;
2433
2434   my $index = $counter->inc;
2435   $index = $counter->inc while qsearchs($table, { $field=>$index } );
2436
2437   $index =~ /^(\d*)$/;
2438   $index=$1;
2439
2440   $self->setfield($field,$index);
2441
2442 }
2443
2444 =item ut_float COLUMN
2445
2446 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
2447 null.  If there is an error, returns the error, otherwise returns false.
2448
2449 =cut
2450
2451 sub ut_float {
2452   my($self,$field)=@_ ;
2453   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2454    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2455    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2456    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2457     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2458   $self->setfield($field,$1);
2459   '';
2460 }
2461 =item ut_floatn COLUMN
2462
2463 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2464 null.  If there is an error, returns the error, otherwise returns false.
2465
2466 =cut
2467
2468 #false laziness w/ut_ipn
2469 sub ut_floatn {
2470   my( $self, $field ) = @_;
2471   if ( $self->getfield($field) =~ /^()$/ ) {
2472     $self->setfield($field,'');
2473     '';
2474   } else {
2475     $self->ut_float($field);
2476   }
2477 }
2478
2479 =item ut_sfloat COLUMN
2480
2481 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2482 May not be null.  If there is an error, returns the error, otherwise returns
2483 false.
2484
2485 =cut
2486
2487 sub ut_sfloat {
2488   my($self,$field)=@_ ;
2489   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2490    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2491    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2492    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2493     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2494   $self->setfield($field,$1);
2495   '';
2496 }
2497 =item ut_sfloatn COLUMN
2498
2499 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2500 null.  If there is an error, returns the error, otherwise returns false.
2501
2502 =cut
2503
2504 sub ut_sfloatn {
2505   my( $self, $field ) = @_;
2506   if ( $self->getfield($field) =~ /^()$/ ) {
2507     $self->setfield($field,'');
2508     '';
2509   } else {
2510     $self->ut_sfloat($field);
2511   }
2512 }
2513
2514 =item ut_snumber COLUMN
2515
2516 Check/untaint signed numeric data (whole numbers).  If there is an error,
2517 returns the error, otherwise returns false.
2518
2519 =cut
2520
2521 sub ut_snumber {
2522   my($self, $field) = @_;
2523   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2524     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2525   $self->setfield($field, "$1$2");
2526   '';
2527 }
2528
2529 =item ut_snumbern COLUMN
2530
2531 Check/untaint signed numeric data (whole numbers).  If there is an error,
2532 returns the error, otherwise returns false.
2533
2534 =cut
2535
2536 sub ut_snumbern {
2537   my($self, $field) = @_;
2538   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2539     or return "Illegal (numeric) $field: ". $self->getfield($field);
2540   if ($1) {
2541     return "Illegal (numeric) $field: ". $self->getfield($field)
2542       unless $2;
2543   }
2544   $self->setfield($field, "$1$2");
2545   '';
2546 }
2547
2548 =item ut_number COLUMN
2549
2550 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
2551 is an error, returns the error, otherwise returns false.
2552
2553 =cut
2554
2555 sub ut_number {
2556   my($self,$field)=@_;
2557   $self->getfield($field) =~ /^\s*(\d+)\s*$/
2558     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2559   $self->setfield($field,$1);
2560   '';
2561 }
2562
2563 =item ut_numbern COLUMN
2564
2565 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
2566 an error, returns the error, otherwise returns false.
2567
2568 =cut
2569
2570 sub ut_numbern {
2571   my($self,$field)=@_;
2572   $self->getfield($field) =~ /^\s*(\d*)\s*$/
2573     or return "Illegal (numeric) $field: ". $self->getfield($field);
2574   $self->setfield($field,$1);
2575   '';
2576 }
2577
2578 =item ut_decimal COLUMN[, DIGITS]
2579
2580 Check/untaint decimal numbers (up to DIGITS decimal places.  If there is an
2581 error, returns the error, otherwise returns false.
2582
2583 =item ut_decimaln COLUMN[, DIGITS]
2584
2585 Check/untaint decimal numbers.  May be null.  If there is an error, returns
2586 the error, otherwise returns false.
2587
2588 =cut
2589
2590 sub ut_decimal {
2591   my($self, $field, $digits) = @_;
2592   $digits ||= '';
2593   $self->getfield($field) =~ /^\s*(\d+(\.\d{0,$digits})?)\s*$/
2594     or return "Illegal or empty (decimal) $field: ".$self->getfield($field);
2595   $self->setfield($field, $1);
2596   '';
2597 }
2598
2599 sub ut_decimaln {
2600   my($self, $field, $digits) = @_;
2601   $self->getfield($field) =~ /^\s*(\d*(\.\d{0,$digits})?)\s*$/
2602     or return "Illegal (decimal) $field: ".$self->getfield($field);
2603   $self->setfield($field, $1);
2604   '';
2605 }
2606
2607 =item ut_money COLUMN
2608
2609 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
2610 is an error, returns the error, otherwise returns false.
2611
2612 =cut
2613
2614 sub ut_money {
2615   my($self,$field)=@_;
2616
2617   if ( $self->getfield($field) eq '' ) {
2618     $self->setfield($field, 0);
2619   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2620     #handle one decimal place without barfing out
2621     $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2622   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2623     $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2624   } else {
2625     return "Illegal (money) $field: ". $self->getfield($field);
2626   }
2627
2628   '';
2629 }
2630
2631 =item ut_moneyn COLUMN
2632
2633 Check/untaint monetary numbers.  May be negative.  If there
2634 is an error, returns the error, otherwise returns false.
2635
2636 =cut
2637
2638 sub ut_moneyn {
2639   my($self,$field)=@_;
2640   if ($self->getfield($field) eq '') {
2641     $self->setfield($field, '');
2642     return '';
2643   }
2644   $self->ut_money($field);
2645 }
2646
2647 =item ut_currencyn COLUMN
2648
2649 Check/untaint currency indicators, such as USD or EUR.  May be null.  If there
2650 is an error, returns the error, otherwise returns false.
2651
2652 =cut
2653
2654 sub ut_currencyn {
2655   my($self, $field) = @_;
2656   if ($self->getfield($field) eq '') { #can be null
2657     $self->setfield($field, '');
2658     return '';
2659   }
2660   $self->ut_currency($field);
2661 }
2662
2663 =item ut_currency COLUMN
2664
2665 Check/untaint currency indicators, such as USD or EUR.  May not be null.  If
2666 there is an error, returns the error, otherwise returns false.
2667
2668 =cut
2669
2670 sub ut_currency {
2671   my($self, $field) = @_;
2672   my $value = uc( $self->getfield($field) );
2673   if ( code2currency($value) ) {
2674     $self->setfield($value);
2675   } else {
2676     return "Unknown currency $value";
2677   }
2678
2679   '';
2680 }
2681
2682 =item ut_text COLUMN
2683
2684 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2685 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < > ~
2686 May not be null.  If there is an error, returns the error, otherwise returns
2687 false.
2688
2689 =cut
2690
2691 sub ut_text {
2692   my($self,$field)=@_;
2693   #warn "msgcat ". \&msgcat. "\n";
2694   #warn "notexist ". \&notexist. "\n";
2695   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2696   # \p{Word} = alphanumerics, marks (diacritics), and connectors
2697   # see perldoc perluniprops
2698   $self->getfield($field)
2699     =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>\~$money_char]+)$/
2700       or return gettext('illegal_or_empty_text'). " $field: ".
2701                  $self->getfield($field);
2702   $self->setfield($field,$1);
2703   '';
2704 }
2705
2706 =item ut_textn COLUMN
2707
2708 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2709 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2710 May be null.  If there is an error, returns the error, otherwise returns false.
2711
2712 =cut
2713
2714 sub ut_textn {
2715   my($self,$field)=@_;
2716   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2717   $self->ut_text($field);
2718 }
2719
2720 =item ut_alpha COLUMN
2721
2722 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
2723 an error, returns the error, otherwise returns false.
2724
2725 =cut
2726
2727 sub ut_alpha {
2728   my($self,$field)=@_;
2729   $self->getfield($field) =~ /^(\w+)$/
2730     or return "Illegal or empty (alphanumeric) $field: ".
2731               $self->getfield($field);
2732   $self->setfield($field,$1);
2733   '';
2734 }
2735
2736 =item ut_alphan COLUMN
2737
2738 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
2739 error, returns the error, otherwise returns false.
2740
2741 =cut
2742
2743 sub ut_alphan {
2744   my($self,$field)=@_;
2745   $self->getfield($field) =~ /^(\w*)$/
2746     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2747   $self->setfield($field,$1);
2748   '';
2749 }
2750
2751 =item ut_alphasn COLUMN
2752
2753 Check/untaint alphanumeric strings, spaces allowed.  May be null.  If there is
2754 an error, returns the error, otherwise returns false.
2755
2756 =cut
2757
2758 sub ut_alphasn {
2759   my($self,$field)=@_;
2760   $self->getfield($field) =~ /^([\w ]*)$/
2761     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2762   $self->setfield($field,$1);
2763   '';
2764 }
2765
2766
2767 =item ut_alpha_lower COLUMN
2768
2769 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
2770 there is an error, returns the error, otherwise returns false.
2771
2772 =cut
2773
2774 sub ut_alpha_lower {
2775   my($self,$field)=@_;
2776   $self->getfield($field) =~ /[[:upper:]]/
2777     and return "Uppercase characters are not permitted in $field";
2778   $self->ut_alpha($field);
2779 }
2780
2781 =item ut_phonen COLUMN [ COUNTRY ]
2782
2783 Check/untaint phone numbers.  May be null.  If there is an error, returns
2784 the error, otherwise returns false.
2785
2786 Takes an optional two-letter ISO 3166-1 alpha-2 country code; without
2787 it or with unsupported countries, ut_phonen simply calls ut_alphan.
2788
2789 =cut
2790
2791 sub ut_phonen {
2792   my( $self, $field, $country ) = @_;
2793   return $self->ut_alphan($field) unless defined $country;
2794   my $phonen = $self->getfield($field);
2795   if ( $phonen eq '' ) {
2796     $self->setfield($field,'');
2797   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2798     $phonen =~ s/\D//g;
2799     $phonen = $conf->config('cust_main-default_areacode').$phonen
2800       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2801     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2802       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2803     $phonen = "$1-$2-$3";
2804     $phonen .= " x$4" if $4;
2805     $self->setfield($field,$phonen);
2806   } else {
2807     warn "warning: don't know how to check phone numbers for country $country";
2808     return $self->ut_textn($field);
2809   }
2810   '';
2811 }
2812
2813 =item ut_hex COLUMN
2814
2815 Check/untaint hexadecimal values.
2816
2817 =cut
2818
2819 sub ut_hex {
2820   my($self, $field) = @_;
2821   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2822     or return "Illegal (hex) $field: ". $self->getfield($field);
2823   $self->setfield($field, uc($1));
2824   '';
2825 }
2826
2827 =item ut_hexn COLUMN
2828
2829 Check/untaint hexadecimal values.  May be null.
2830
2831 =cut
2832
2833 sub ut_hexn {
2834   my($self, $field) = @_;
2835   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2836     or return "Illegal (hex) $field: ". $self->getfield($field);
2837   $self->setfield($field, uc($1));
2838   '';
2839 }
2840
2841 =item ut_mac_addr COLUMN
2842
2843 Check/untaint mac addresses.  May be null.
2844
2845 =cut
2846
2847 sub ut_mac_addr {
2848   my($self, $field) = @_;
2849
2850   my $mac = $self->get($field);
2851   $mac =~ s/\s+//g;
2852   $mac =~ s/://g;
2853   $self->set($field, $mac);
2854
2855   my $e = $self->ut_hex($field);
2856   return $e if $e;
2857
2858   return "Illegal (mac address) $field: ". $self->getfield($field)
2859     unless length($self->getfield($field)) == 12;
2860
2861   '';
2862
2863 }
2864
2865 =item ut_mac_addrn COLUMN
2866
2867 Check/untaint mac addresses.  May be null.
2868
2869 =cut
2870
2871 sub ut_mac_addrn {
2872   my($self, $field) = @_;
2873   ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2874 }
2875
2876 =item ut_ip COLUMN
2877
2878 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2879 to 127.0.0.1.
2880
2881 =cut
2882
2883 sub ut_ip {
2884   my( $self, $field ) = @_;
2885   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2886   return "Illegal (IP address) $field: ".$self->getfield($field)
2887     unless $self->getfield($field) =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/;
2888   $self->ut_ip46($field);
2889 }
2890
2891 =item ut_ipn COLUMN
2892
2893 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2894 to 127.0.0.1.  May be null.
2895
2896 =cut
2897
2898 sub ut_ipn {
2899   my( $self, $field ) = @_;
2900   if ( $self->getfield($field) =~ /^()$/ ) {
2901     $self->setfield($field,'');
2902     '';
2903   } else {
2904     $self->ut_ip($field);
2905   }
2906 }
2907
2908 =item ut_ip46 COLUMN
2909
2910 Check/untaint IPv4 or IPv6 address.
2911
2912 =cut
2913
2914 sub ut_ip46 {
2915   my( $self, $field ) = @_;
2916   my $ip = NetAddr::IP->new(
2917     $self->_ut_ip_strip_leading_zeros( $self->getfield( $field ) )
2918   ) or return "Illegal (IP address) $field: ".$self->getfield($field);
2919   $self->setfield($field, lc($ip->addr));
2920   return '';
2921 }
2922
2923 =item ut_ip46n
2924
2925 Check/untaint IPv6 or IPv6 address.  May be null.
2926
2927 =cut
2928
2929 sub ut_ip46n {
2930   my( $self, $field ) = @_;
2931   if ( $self->getfield($field) =~ /^$/ ) {
2932     $self->setfield($field, '');
2933     return '';
2934   }
2935   $self->ut_ip46($field);
2936 }
2937
2938 sub _ut_ip_strip_leading_zeros {
2939   # strip user-entered leading 0's from IP addresses
2940   # so parsers like NetAddr::IP don't mangle the address
2941   # e.g. NetAddr::IP converts 10.0.022.220 into 10.0.18.220
2942
2943   my ( $self, $ip ) = @_;
2944
2945   return join '.', map int, split /\./, $ip
2946     if $ip
2947     && $ip =~ /\./
2948     && $ip =~ /[\.^]0/;
2949   $ip;
2950 }
2951
2952
2953 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2954
2955 Check/untaint coordinates.
2956 Accepts the following forms:
2957 DDD.DDDDD
2958 -DDD.DDDDD
2959 DDD MM.MMM
2960 -DDD MM.MMM
2961 DDD MM SS
2962 -DDD MM SS
2963 DDD MM MMM
2964 -DDD MM MMM
2965
2966 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2967 The latter form (that is, the MMM are thousands of minutes) is
2968 assumed if the "MMM" is exactly three digits or two digits > 59.
2969
2970 To be safe, just use the DDD.DDDDD form.
2971
2972 If LOWER or UPPER are specified, then the coordinate is checked
2973 for lower and upper bounds, respectively.
2974
2975 =cut
2976
2977 sub ut_coord {
2978   my ($self, $field) = (shift, shift);
2979
2980   my($lower, $upper);
2981   if ( $field =~ /latitude/ ) {
2982     $lower = $lat_lower;
2983     $upper = 90;
2984   } elsif ( $field =~ /longitude/ ) {
2985     $lower = -180;
2986     $upper = $lon_upper;
2987   }
2988
2989   my $coord = $self->getfield($field);
2990   my $neg = $coord =~ s/^(-)//;
2991
2992   # ignore degree symbol at the end,
2993   #   but not otherwise supporting degree/minutes/seconds symbols
2994   $coord =~ s/\N{DEGREE SIGN}\s*$//;
2995
2996   my ($d, $m, $s) = (0, 0, 0);
2997
2998   if (
2999     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
3000     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
3001     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
3002   ) {
3003     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
3004     $m = $m / 60;
3005     if ($m > 59) {
3006       return "Invalid (coordinate with minutes > 59) $field: "
3007              . $self->getfield($field);
3008     }
3009
3010     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
3011
3012     if (defined($lower) and ($coord < $lower)) {
3013       return "Invalid (coordinate < $lower) $field: "
3014              . $self->getfield($field);;
3015     }
3016
3017     if (defined($upper) and ($coord > $upper)) {
3018       return "Invalid (coordinate > $upper) $field: "
3019              . $self->getfield($field);;
3020     }
3021
3022     $self->setfield($field, $coord);
3023     return '';
3024   }
3025
3026   return "Invalid (coordinate) $field: " . $self->getfield($field);
3027
3028 }
3029
3030 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
3031
3032 Same as ut_coord, except optionally null.
3033
3034 =cut
3035
3036 sub ut_coordn {
3037
3038   my ($self, $field) = (shift, shift);
3039
3040   if ($self->getfield($field) =~ /^\s*$/) {
3041     return '';
3042   } else {
3043     return $self->ut_coord($field, @_);
3044   }
3045
3046 }
3047
3048 =item ut_domain COLUMN
3049
3050 Check/untaint host and domain names.  May not be null.
3051
3052 =cut
3053
3054 sub ut_domain {
3055   my( $self, $field ) = @_;
3056   #$self->getfield($field) =~/^(\w+\.)*\w+$/
3057   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
3058     or return "Illegal (hostname) $field: ". $self->getfield($field);
3059   $self->setfield($field,$1);
3060   '';
3061 }
3062
3063 =item ut_domainn COLUMN
3064
3065 Check/untaint host and domain names.  May be null.
3066
3067 =cut
3068
3069 sub ut_domainn {
3070   my( $self, $field ) = @_;
3071   if ( $self->getfield($field) =~ /^()$/ ) {
3072     $self->setfield($field,'');
3073     '';
3074   } else {
3075     $self->ut_domain($field);
3076   }
3077 }
3078
3079 =item ut_name COLUMN
3080
3081 Check/untaint proper names; allows alphanumerics, spaces and the following
3082 punctuation: , . - '
3083
3084 May not be null.
3085
3086 =cut
3087
3088 sub ut_name {
3089   my( $self, $field ) = @_;
3090   $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
3091     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
3092   my $name = $1;
3093   $name =~ s/^\s+//;
3094   $name =~ s/\s+$//;
3095   $name =~ s/\s+/ /g;
3096   $self->setfield($field, $name);
3097   '';
3098 }
3099
3100 =item ut_namen COLUMN
3101
3102 Check/untaint proper names; allows alphanumerics, spaces and the following
3103 punctuation: , . - '
3104
3105 May not be null.
3106
3107 =cut
3108
3109 sub ut_namen {
3110   my( $self, $field ) = @_;
3111   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
3112   $self->ut_name($field);
3113 }
3114
3115 =item ut_zip COLUMN
3116
3117 Check/untaint zip codes.
3118
3119 =cut
3120
3121 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
3122
3123 sub ut_zip {
3124   my( $self, $field, $country ) = @_;
3125
3126   if ( $country eq 'US' ) {
3127
3128     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
3129       or return gettext('illegal_zip'). " $field for country $country: ".
3130                 $self->getfield($field);
3131     $self->setfield($field, $1);
3132
3133   } elsif ( $country eq 'CA' ) {
3134
3135     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
3136       or return gettext('illegal_zip'). " $field for country $country: ".
3137                 $self->getfield($field);
3138     $self->setfield($field, "$1 $2");
3139
3140   } elsif ( $country eq 'AU' ) {
3141
3142     $self->getfield($field) =~ /^\s*(\d{4})\s*$/
3143       or return gettext('illegal_zip'). " $field for country $country: ".
3144                 $self->getfield($field);
3145     $self->setfield($field, $1);
3146
3147   } else {
3148
3149     if ( $self->getfield($field) =~ /^\s*$/
3150          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
3151        )
3152     {
3153       $self->setfield($field,'');
3154     } else {
3155       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
3156         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
3157       $self->setfield($field,$1);
3158     }
3159
3160   }
3161
3162   '';
3163 }
3164
3165 =item ut_country COLUMN
3166
3167 Check/untaint country codes.  Country names are changed to codes, if possible -
3168 see L<Locale::Country>.
3169
3170 =cut
3171
3172 sub ut_country {
3173   my( $self, $field ) = @_;
3174   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
3175     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
3176          && country2code($1) ) {
3177       $self->setfield($field,uc(country2code($1)));
3178     }
3179   }
3180   $self->getfield($field) =~ /^(\w\w)$/
3181     or return "Illegal (country) $field: ". $self->getfield($field);
3182   $self->setfield($field,uc($1));
3183   '';
3184 }
3185
3186 =item ut_anything COLUMN
3187
3188 Untaints arbitrary data.  Be careful.
3189
3190 =cut
3191
3192 sub ut_anything {
3193   my( $self, $field ) = @_;
3194   $self->getfield($field) =~ /^(.*)$/s
3195     or return "Illegal $field: ". $self->getfield($field);
3196   $self->setfield($field,$1);
3197   '';
3198 }
3199
3200 =item ut_enum COLUMN CHOICES_ARRAYREF
3201
3202 Check/untaint a column, supplying all possible choices, like the "enum" type.
3203
3204 =cut
3205
3206 sub ut_enum {
3207   my( $self, $field, $choices ) = @_;
3208   foreach my $choice ( @$choices ) {
3209     if ( $self->getfield($field) eq $choice ) {
3210       $self->setfield($field, $choice);
3211       return '';
3212     }
3213   }
3214   return "Illegal (enum) field $field: ". $self->getfield($field);
3215 }
3216
3217 =item ut_enumn COLUMN CHOICES_ARRAYREF
3218
3219 Like ut_enum, except the null value is also allowed.
3220
3221 =cut
3222
3223 sub ut_enumn {
3224   my( $self, $field, $choices ) = @_;
3225   $self->getfield($field)
3226     ? $self->ut_enum($field, $choices)
3227     : '';
3228 }
3229
3230 =item ut_date COLUMN
3231
3232 Check/untaint a column containing a date string.
3233
3234 Date will be normalized to YYYY-MM-DD format
3235
3236 =cut
3237
3238 sub ut_date {
3239   my ( $self, $field ) = @_;
3240   my $value = $self->getfield( $field );
3241
3242   my @date = split /[\-\/]/, $value;
3243   if ( scalar(@date) == 3 ) {
3244     @date = @date[2,0,1] if $date[2] >= 1900;
3245
3246     local $@;
3247     my $ymd;
3248     eval {
3249       # DateTime will die given invalid date
3250       $ymd = DateTime->new(
3251         year  => $date[0],
3252         month => $date[1],
3253         day   => $date[2],
3254       )->ymd('-');
3255     };
3256
3257     unless( $@ ) {
3258       $self->setfield( $field, $ymd ) unless $value eq $ymd;
3259       return '';
3260     }
3261
3262   }
3263   return "Illegal (date) field $field: $value";
3264 }
3265
3266 =item ut_daten COLUMN
3267
3268 Check/untaint a column containing a date string.
3269
3270 Column may be null.
3271
3272 Date will be normalized to YYYY-MM-DD format
3273
3274 =cut
3275
3276 sub ut_daten {
3277   my ( $self, $field ) = @_;
3278
3279   $self->getfield( $field ) =~ /^()$/
3280   ? $self->setfield( $field, '' )
3281   : $self->ut_date( $field );
3282 }
3283
3284 =item ut_flag COLUMN
3285
3286 Check/untaint a column if it contains either an empty string or 'Y'.  This
3287 is the standard form for boolean flags in Freeside.
3288
3289 =cut
3290
3291 sub ut_flag {
3292   my( $self, $field ) = @_;
3293   my $value = uc($self->getfield($field));
3294   if ( $value eq '' or $value eq 'Y' ) {
3295     $self->setfield($field, $value);
3296     return '';
3297   }
3298   return "Illegal (flag) field $field: $value";
3299 }
3300
3301 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3302
3303 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
3304 on the column first.
3305
3306 =cut
3307
3308 sub ut_foreign_key {
3309   my( $self, $field, $table, $foreign ) = @_;
3310   return $self->ut_number($field) if $no_check_foreign;
3311   qsearchs($table, { $foreign => $self->getfield($field) })
3312     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
3313               " in $table.$foreign";
3314   '';
3315 }
3316
3317 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3318
3319 Like ut_foreign_key, except the null value is also allowed.
3320
3321 =cut
3322
3323 sub ut_foreign_keyn {
3324   my( $self, $field, $table, $foreign ) = @_;
3325   $self->getfield($field)
3326     ? $self->ut_foreign_key($field, $table, $foreign)
3327     : '';
3328 }
3329
3330 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
3331
3332 Checks this column as an agentnum, taking into account the current users's
3333 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
3334 right or rights allowing no agentnum.
3335
3336 =cut
3337
3338 sub ut_agentnum_acl {
3339   my( $self, $field ) = (shift, shift);
3340   my $null_acl = scalar(@_) ? shift : [];
3341   $null_acl = [ $null_acl ] unless ref($null_acl);
3342
3343   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
3344   return "Illegal agentnum: $error" if $error;
3345
3346   my $curuser = $FS::CurrentUser::CurrentUser;
3347
3348   if ( $self->$field() ) {
3349
3350     return 'Access denied to agent '. $self->$field()
3351       unless $curuser->agentnum($self->$field());
3352
3353   } else {
3354
3355     return 'Access denied to global'
3356       unless grep $curuser->access_right($_), @$null_acl;
3357
3358   }
3359
3360   '';
3361
3362 }
3363
3364
3365 =item ut_email COLUMN
3366
3367 Check column contains a valid E-Mail address
3368
3369 =cut
3370
3371 sub ut_email {
3372   my ( $self, $field ) = @_;
3373   Email::Valid->address( $self->getfield( $field ) )
3374     ? ''
3375     : "Illegal (email) field $field: ". $self->getfield( $field );
3376 }
3377
3378 =item ut_emailn COLUMN
3379
3380 Check column contains a valid E-Mail address
3381
3382 May be null
3383
3384 =cut
3385
3386 sub ut_emailn {
3387   my ( $self, $field ) = @_;
3388
3389   $self->getfield( $field ) =~ /^$/
3390     ? $self->getfield( $field, '' )
3391     : $self->ut_email( $field );
3392 }
3393
3394 =item trim_whitespace FIELD[, FIELD ... ]
3395
3396 Strip leading and trailing spaces from the value in the named FIELD(s).
3397
3398 =cut
3399
3400 sub trim_whitespace {
3401   my $self = shift;
3402   foreach my $field (@_) {
3403     my $value = $self->get($field);
3404     $value =~ s/^\s+//;
3405     $value =~ s/\s+$//;
3406     $self->set($field, $value);
3407   }
3408 }
3409
3410 =item fields [ TABLE ]
3411
3412 This is a wrapper for real_fields.  Code that called
3413 fields before should probably continue to call fields.
3414
3415 =cut
3416
3417 sub fields {
3418   my $something = shift;
3419   my $table;
3420   if($something->isa('FS::Record')) {
3421     $table = $something->table;
3422   } else {
3423     $table = $something;
3424     #$something = "FS::$table";
3425   }
3426   return (real_fields($table));
3427 }
3428
3429
3430 =item encrypt($value)
3431
3432 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
3433
3434 Returns the encrypted string.
3435
3436 You should generally not have to worry about calling this, as the system handles this for you.
3437
3438 =cut
3439
3440 sub encrypt {
3441   my ($self, $value) = @_;
3442   my $encrypted = $value;
3443
3444   if ($conf_encryption) {
3445     if ($self->is_encrypted($value)) {
3446       # Return the original value if it isn't plaintext.
3447       $encrypted = $value;
3448     } else {
3449       $self->loadRSA;
3450       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
3451         # RSA doesn't like the empty string so let's pack it up
3452         # The database doesn't like the RSA data so uuencode it
3453         my $length = length($value)+1;
3454         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
3455       } else {
3456         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
3457       }
3458     }
3459   }
3460   return $encrypted;
3461 }
3462
3463 =item is_encrypted($value)
3464
3465 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
3466
3467 =cut
3468
3469
3470 sub is_encrypted {
3471   my ($self, $value) = @_;
3472   # could be more precise about it, but this will do for now
3473   $value =~ /^M/ && length($value) > 80;
3474 }
3475
3476 =item decrypt($value)
3477
3478 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
3479
3480 You should generally not have to worry about calling this, as the system handles this for you.
3481
3482 =cut
3483
3484 sub decrypt {
3485   my ($self,$value) = @_;
3486   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
3487   if ($conf_encryption && $self->is_encrypted($value)) {
3488     $self->loadRSA;
3489     if (ref($rsa_decrypt) =~ /::RSA/) {
3490       my $encrypted = unpack ("u*", $value);
3491       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
3492       if ($@) {warn "Decryption Failed"};
3493     }
3494   }
3495   return $decrypted;
3496 }
3497
3498 sub loadRSA {
3499   my $self = shift;
3500
3501   my $rsa_module = $conf_encryptionmodule || 'Crypt::OpenSSL::RSA';
3502
3503   # Initialize Encryption
3504   if ($conf_encryptionpublickey && $conf_encryptionpublickey ne '') {
3505     $rsa_encrypt = $rsa_module->new_public_key($conf_encryptionpublickey);
3506   }
3507
3508   # Intitalize Decryption
3509   if ($conf_encryptionprivatekey && $conf_encryptionprivatekey ne '') {
3510     $rsa_decrypt = $rsa_module->new_private_key($conf_encryptionprivatekey);
3511   }
3512 }
3513
3514 =item h_search ACTION
3515
3516 Given an ACTION, either "insert", or "delete", returns the appropriate history
3517 record corresponding to this record, if any.
3518
3519 =cut
3520
3521 sub h_search {
3522   my( $self, $action ) = @_;
3523
3524   my $table = $self->table;
3525   $table =~ s/^h_//;
3526
3527   my $primary_key = dbdef->table($table)->primary_key;
3528
3529   qsearchs({
3530     'table'   => "h_$table",
3531     'hashref' => { $primary_key     => $self->$primary_key(),
3532                    'history_action' => $action,
3533                  },
3534   });
3535
3536 }
3537
3538 =item h_date ACTION
3539
3540 Given an ACTION, either "insert", or "delete", returns the timestamp of the
3541 appropriate history record corresponding to this record, if any.
3542
3543 =cut
3544
3545 sub h_date {
3546   my($self, $action) = @_;
3547   my $h = $self->h_search($action);
3548   $h ? $h->history_date : '';
3549 }
3550
3551 =item scalar_sql SQL [ PLACEHOLDER, ... ]
3552
3553 A class or object method.  Executes the sql statement represented by SQL and
3554 returns a scalar representing the result: the first column of the first row.
3555
3556 Dies on bogus SQL.  Returns an empty string if no row is returned.
3557
3558 Typically used for statments which return a single value such as "SELECT
3559 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
3560
3561 =cut
3562
3563 sub scalar_sql {
3564   my($self, $sql) = (shift, shift);
3565   my $sth = dbh->prepare($sql) or die dbh->errstr;
3566   $sth->execute(@_)
3567     or die "Unexpected error executing statement $sql: ". $sth->errstr;
3568   my $row = $sth->fetchrow_arrayref or return '';
3569   my $scalar = $row->[0];
3570   defined($scalar) ? $scalar : '';
3571 }
3572
3573 =item count [ WHERE [, PLACEHOLDER ...] ]
3574
3575 Convenience method for the common case of "SELECT COUNT(*) FROM table",
3576 with optional WHERE.  Must be called as method on a class with an
3577 associated table.
3578
3579 =cut
3580
3581 sub count {
3582   my($self, $where) = (shift, shift);
3583   my $table = $self->table or die 'count called on object of class '.ref($self);
3584   my $sql = "SELECT COUNT(*) FROM $table";
3585   $sql .= " WHERE $where" if $where;
3586   $self->scalar_sql($sql, @_);
3587 }
3588
3589 =item row_exists [ WHERE [, PLACEHOLDER ...] ]
3590
3591 Convenience method for the common case of "SELECT 1 FROM table ... LIMIT 1"
3592 with optional (but almost always needed) WHERE.
3593
3594 =cut
3595
3596 sub row_exists {
3597   my($self, $where) = (shift, shift);
3598   my $table = $self->table or die 'row_exists called on object of class '.ref($self);
3599   my $sql = "SELECT 1 FROM $table";
3600   $sql .= " WHERE $where" if $where;
3601   $sql .= " LIMIT 1";
3602   $self->scalar_sql($sql, @_);
3603 }
3604
3605 =back
3606
3607 =head1 SUBROUTINES
3608
3609 =over 4
3610
3611 =item real_fields [ TABLE ]
3612
3613 Returns a list of the real columns in the specified table.  Called only by
3614 fields() and other subroutines elsewhere in FS::Record.
3615
3616 =cut
3617
3618 sub real_fields {
3619   my $table = shift;
3620
3621   my($table_obj) = dbdef->table($table);
3622   confess "Unknown table $table" unless $table_obj;
3623   $table_obj->columns;
3624 }
3625
3626 =item pvf FIELD_NAME
3627
3628 Returns the FS::part_virtual_field object corresponding to a field in the
3629 record (specified by FIELD_NAME).
3630
3631 =cut
3632
3633 sub pvf {
3634   my ($self, $name) = (shift, shift);
3635
3636   if(grep /^$name$/, $self->virtual_fields) {
3637     $name =~ s/^cf_//;
3638     my $concat = [ "'cf_'", "name" ];
3639     return qsearchs({   table   =>  'part_virtual_field',
3640                         hashref =>  { dbtable => $self->table,
3641                                       name    => $name
3642                                     },
3643                         select  =>  'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
3644                     });
3645   }
3646   ''
3647 }
3648
3649 =item _quote VALUE, TABLE, COLUMN
3650
3651 This is an internal function used to construct SQL statements.  It returns
3652 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3653 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3654
3655 =cut
3656
3657 sub _quote {
3658   my($value, $table, $column) = @_;
3659   my $column_obj = dbdef->table($table)->column($column);
3660   my $column_type = $column_obj->type;
3661   my $nullable = $column_obj->null;
3662
3663   utf8::upgrade($value);
3664
3665   warn "  $table.$column: $value ($column_type".
3666        ( $nullable ? ' NULL' : ' NOT NULL' ).
3667        ")\n" if $DEBUG > 2;
3668
3669   if ( $value eq '' && $nullable ) {
3670     'NULL';
3671   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3672     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3673           "using 0 instead";
3674     0;
3675   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3676             ! $column_type =~ /(char|binary|text)$/i ) {
3677     $value;
3678   } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3679            && driver_name eq 'Pg'
3680           )
3681   {
3682     local $@;
3683
3684     eval { $value = dbh->quote($value, { pg_type => PG_BYTEA() }); };
3685
3686     if ( $@ && $@ =~ /Wide character/i ) {
3687       warn 'Correcting malformed UTF-8 string for binary quote()'
3688         if $DEBUG;
3689       utf8::decode($value);
3690       utf8::encode($value);
3691       $value = dbh->quote($value, { pg_type => PG_BYTEA() });
3692     }
3693
3694     $value;
3695   } else {
3696     dbh->quote($value);
3697   }
3698 }
3699
3700 =item hfields TABLE
3701
3702 This is deprecated.  Don't use it.
3703
3704 It returns a hash-type list with the fields of this record's table set true.
3705
3706 =cut
3707
3708 sub hfields {
3709   carp "warning: hfields is deprecated";
3710   my($table)=@_;
3711   my(%hash);
3712   foreach (fields($table)) {
3713     $hash{$_}=1;
3714   }
3715   \%hash;
3716 }
3717
3718 sub _dump {
3719   my($self)=@_;
3720   join("\n", map {
3721     "$_: ". $self->getfield($_). "|"
3722   } (fields($self->table)) );
3723 }
3724
3725 sub DESTROY { return; }
3726
3727 #sub DESTROY {
3728 #  my $self = shift;
3729 #  #use Carp qw(cluck);
3730 #  #cluck "DESTROYING $self";
3731 #  warn "DESTROYING $self";
3732 #}
3733
3734 #sub is_tainted {
3735 #             return ! eval { join('',@_), kill 0; 1; };
3736 #         }
3737
3738 =item str2time_sql [ DRIVER_NAME ]
3739
3740 Returns a function to convert to unix time based on database type, such as
3741 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
3742 the str2time_sql_closing method to return a closing string rather than just
3743 using a closing parenthesis as previously suggested.
3744
3745 You can pass an optional driver name such as "Pg", "mysql" or
3746 $dbh->{Driver}->{Name} to return a function for that database instead of
3747 the current database.
3748
3749 =cut
3750
3751 sub str2time_sql {
3752   my $driver = shift || driver_name;
3753
3754   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
3755   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3756
3757   warn "warning: unknown database type $driver; guessing how to convert ".
3758        "dates to UNIX timestamps";
3759   return 'EXTRACT(EPOCH FROM ';
3760
3761 }
3762
3763 =item str2time_sql_closing [ DRIVER_NAME ]
3764
3765 Returns the closing suffix of a function to convert to unix time based on
3766 database type, such as ")::integer" for Pg or ")" for mysql.
3767
3768 You can pass an optional driver name such as "Pg", "mysql" or
3769 $dbh->{Driver}->{Name} to return a function for that database instead of
3770 the current database.
3771
3772 =cut
3773
3774 sub str2time_sql_closing {
3775   my $driver = shift || driver_name;
3776
3777   return ' )::INTEGER ' if $driver =~ /^Pg/i;
3778   return ' ) ';
3779 }
3780
3781 =item regexp_sql [ DRIVER_NAME ]
3782
3783 Returns the operator to do a regular expression comparison based on database
3784 type, such as '~' for Pg or 'REGEXP' for mysql.
3785
3786 You can pass an optional driver name such as "Pg", "mysql" or
3787 $dbh->{Driver}->{Name} to return a function for that database instead of
3788 the current database.
3789
3790 =cut
3791
3792 sub regexp_sql {
3793   my $driver = shift || driver_name;
3794
3795   return '~'      if $driver =~ /^Pg/i;
3796   return 'REGEXP' if $driver =~ /^mysql/i;
3797
3798   die "don't know how to use regular expressions in ". driver_name." databases";
3799
3800 }
3801
3802 =item not_regexp_sql [ DRIVER_NAME ]
3803
3804 Returns the operator to do a regular expression negation based on database
3805 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3806
3807 You can pass an optional driver name such as "Pg", "mysql" or
3808 $dbh->{Driver}->{Name} to return a function for that database instead of
3809 the current database.
3810
3811 =cut
3812
3813 sub not_regexp_sql {
3814   my $driver = shift || driver_name;
3815
3816   return '!~'         if $driver =~ /^Pg/i;
3817   return 'NOT REGEXP' if $driver =~ /^mysql/i;
3818
3819   die "don't know how to use regular expressions in ". driver_name." databases";
3820
3821 }
3822
3823 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3824
3825 Returns the items concatenated based on database type, using "CONCAT()" for
3826 mysql and " || " for Pg and other databases.
3827
3828 You can pass an optional driver name such as "Pg", "mysql" or
3829 $dbh->{Driver}->{Name} to return a function for that database instead of
3830 the current database.
3831
3832 =cut
3833
3834 sub concat_sql {
3835   my $driver = ref($_[0]) ? driver_name : shift;
3836   my $items = shift;
3837
3838   if ( $driver =~ /^mysql/i ) {
3839     'CONCAT('. join(',', @$items). ')';
3840   } else {
3841     join('||', @$items);
3842   }
3843
3844 }
3845
3846 =item group_concat_sql COLUMN, DELIMITER
3847
3848 Returns an SQL expression to concatenate an aggregate column, using
3849 GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg.
3850
3851 =cut
3852
3853 sub group_concat_sql {
3854   my ($col, $delim) = @_;
3855   $delim = dbh->quote($delim);
3856   if ( driver_name() =~ /^mysql/i ) {
3857     # DISTINCT(foo) is valid as $col
3858     return "GROUP_CONCAT($col SEPARATOR $delim)";
3859   } else {
3860     return "array_to_string(array_agg($col), $delim)";
3861   }
3862 }
3863
3864 =item midnight_sql DATE
3865
3866 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3867 on that day in the system timezone, using the default driver name.
3868
3869 =cut
3870
3871 sub midnight_sql {
3872   my $driver = driver_name;
3873   my $expr = shift;
3874   if ( $driver =~ /^mysql/i ) {
3875     "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3876   }
3877   else {
3878     "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3879   }
3880 }
3881
3882 =back
3883
3884 =head1 BUGS
3885
3886 This module should probably be renamed, since much of the functionality is
3887 of general use.  It is not completely unlike Adapter::DBI (see below).
3888
3889 Exported qsearch and qsearchs should be deprecated in favor of method calls
3890 (against an FS::Record object like the old search and searchs that qsearch
3891 and qsearchs were on top of.)
3892
3893 The whole fields / hfields mess should be removed.
3894
3895 The various WHERE clauses should be subroutined.
3896
3897 table string should be deprecated in favor of DBIx::DBSchema::Table.
3898
3899 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
3900 true maps to the database (and WHERE clauses) would also help.
3901
3902 The ut_ methods should ask the dbdef for a default length.
3903
3904 ut_sqltype (like ut_varchar) should all be defined
3905
3906 A fallback check method should be provided which uses the dbdef.
3907
3908 The ut_money method assumes money has two decimal digits.
3909
3910 The Pg money kludge in the new method only strips `$'.
3911
3912 The ut_phonen method only checks US-style phone numbers.
3913
3914 The _quote function should probably use ut_float instead of a regex.
3915
3916 All the subroutines probably should be methods, here or elsewhere.
3917
3918 Probably should borrow/use some dbdef methods where appropriate (like sub
3919 fields)
3920
3921 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3922 or allow it to be set.  Working around it is ugly any way around - DBI should
3923 be fixed.  (only affects RDBMS which return uppercase column names)
3924
3925 ut_zip should take an optional country like ut_phone.
3926
3927 =head1 SEE ALSO
3928
3929 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3930
3931 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
3932
3933 http://poop.sf.net/
3934
3935 =cut
3936
3937 1;