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              %virtual_fields_hash_cache $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 virtual_fields_hash [ TABLE ]
1814
1815 Returns a list of virtual field records as a hash defined for the table.  This should not
1816 be exported, and should only be called as an instance or class method.
1817
1818 =cut
1819
1820 sub virtual_fields_hash {
1821   my $self = shift;
1822   my $table;
1823   $table = $self->table or confess "virtual_fields called on non-table";
1824
1825   confess "Unknown table $table" unless dbdef->table($table);
1826
1827   return () unless dbdef->table('part_virtual_field');
1828
1829   unless ( $virtual_fields_hash_cache{$table} ) {
1830     $virtual_fields_hash_cache{$table} = [];
1831     my $concat = [ "'cf_'", "name" ];
1832     my $select = concat_sql($concat).' as name, label, length';
1833     my @vfields = qsearch({
1834       select => $select,
1835       table => 'part_virtual_field',
1836       hashref => { 'dbtable' => $table, },
1837     });
1838
1839     foreach (@vfields) {
1840       push @{ $virtual_fields_hash_cache{$table} }, $_->{Hash};
1841     }
1842   }
1843
1844   @{$virtual_fields_hash_cache{$table}};
1845
1846 }
1847
1848 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1849
1850 Processes a batch import as a queued JSRPC job
1851
1852 JOB is an FS::queue entry.
1853
1854 OPTIONS_HASHREF can have the following keys:
1855
1856 =over 4
1857
1858 =item table
1859
1860 Table name (required).
1861
1862 =item params
1863
1864 Arrayref of field names for static fields.  They will be given values from the
1865 PARAMS hashref and passed as a "params" hashref to batch_import.
1866
1867 =item formats
1868
1869 Formats hashref.  Keys are field names, values are listrefs that define the
1870 format.
1871
1872 Each listref value can be a column name or a code reference.  Coderefs are run
1873 with the row object, data and a FS::Conf object as the three parameters.
1874 For example, this coderef does the same thing as using the "columnname" string:
1875
1876   sub {
1877     my( $record, $data, $conf ) = @_;
1878     $record->columnname( $data );
1879   },
1880
1881 Coderefs are run after all "column name" fields are assigned.
1882
1883 =item format_types
1884
1885 Optional format hashref of types.  Keys are field names, values are "csv",
1886 "xls" or "fixedlength".  Overrides automatic determination of file type
1887 from extension.
1888
1889 =item format_headers
1890
1891 Optional format hashref of header lines.  Keys are field names, values are 0
1892 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1893 number of lines.
1894
1895 =item format_sep_chars
1896
1897 Optional format hashref of CSV sep_chars.  Keys are field names, values are the
1898 CSV separation character.
1899
1900 =item format_fixedlenth_formats
1901
1902 Optional format hashref of fixed length format defintiions.  Keys are field
1903 names, values Parse::FixedLength listrefs of field definitions.
1904
1905 =item default_csv
1906
1907 Set true to default to CSV file type if the filename does not contain a
1908 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1909 format_types).
1910
1911 =back
1912
1913 PARAMS is a hashref (or base64-encoded Storable hashref) containing the
1914 POSTed data.  It must contain the field "uploaded files", generated by
1915 /elements/file-upload.html and containing the list of uploaded files.
1916 Currently only supports a single file named "file".
1917
1918 =cut
1919
1920 use Data::Dumper;
1921 sub process_batch_import {
1922   my($job, $opt, $param) = @_;
1923
1924   my $table = $opt->{table};
1925   my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1926   my %formats = %{ $opt->{formats} };
1927
1928   warn Dumper($param) if $DEBUG;
1929
1930   my $files = $param->{'uploaded_files'}
1931     or die "No files provided.\n";
1932
1933   my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1934
1935   my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1936   my $file = $dir. $files{'file'};
1937
1938   my %iopt = (
1939     #class-static
1940     table                      => $table,
1941     formats                    => \%formats,
1942     format_types               => $opt->{format_types},
1943     format_headers             => $opt->{format_headers},
1944     format_sep_chars           => $opt->{format_sep_chars},
1945     format_fixedlength_formats => $opt->{format_fixedlength_formats},
1946     format_xml_formats         => $opt->{format_xml_formats},
1947     format_asn_formats         => $opt->{format_asn_formats},
1948     format_row_callbacks       => $opt->{format_row_callbacks},
1949     format_hash_callbacks      => $opt->{format_hash_callbacks},
1950     #per-import
1951     job                        => $job,
1952     file                       => $file,
1953     #type                       => $type,
1954     format                     => $param->{format},
1955     params                     => { map { $_ => $param->{$_} } @pass_params },
1956     #?
1957     default_csv                => $opt->{default_csv},
1958     preinsert_callback         => $opt->{preinsert_callback},
1959     postinsert_callback        => $opt->{postinsert_callback},
1960     insert_args_callback       => $opt->{insert_args_callback},
1961   );
1962
1963   if ( $opt->{'batch_namecol'} ) {
1964     $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1965     $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1966   }
1967
1968   my $error = FS::Record::batch_import( \%iopt );
1969
1970   unlink $file;
1971
1972   die "$error\n" if $error;
1973 }
1974
1975 =item batch_import PARAM_HASHREF
1976
1977 Class method for batch imports.  Available params:
1978
1979 =over 4
1980
1981 =item table
1982
1983 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1984
1985 =item formats
1986
1987 =item format_types
1988
1989 =item format_headers
1990
1991 =item format_sep_chars
1992
1993 =item format_fixedlength_formats
1994
1995 =item format_row_callbacks
1996
1997 =item format_hash_callbacks - After parsing, before object creation
1998
1999 =item fields - Alternate way to specify import, specifying import fields directly as a listref
2000
2001 =item preinsert_callback
2002
2003 =item postinsert_callback
2004
2005 =item params
2006
2007 =item job
2008
2009 FS::queue object, will be updated with progress
2010
2011 =item file
2012
2013 =item type
2014
2015 csv, xls, fixedlength, xml
2016
2017 =item empty_ok
2018
2019 =back
2020
2021 =cut
2022
2023 use Data::Dumper;
2024 sub batch_import {
2025   my $param = shift;
2026
2027   warn "$me batch_import call with params: \n". Dumper($param)
2028     if $DEBUG;
2029
2030   my $table   = $param->{table};
2031
2032   my $job     = $param->{job};
2033   my $file    = $param->{file};
2034   my $params  = $param->{params} || {};
2035
2036   my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
2037   my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
2038
2039   my( $type, $header, $sep_char,
2040       $fixedlength_format, $xml_format, $asn_format,
2041       $parser_opt, $row_callback, $hash_callback, @fields );
2042
2043   my $postinsert_callback = '';
2044   $postinsert_callback = $param->{'postinsert_callback'}
2045           if $param->{'postinsert_callback'};
2046   my $preinsert_callback = '';
2047   $preinsert_callback = $param->{'preinsert_callback'}
2048           if $param->{'preinsert_callback'};
2049   my $insert_args_callback = '';
2050   $insert_args_callback = $param->{'insert_args_callback'}
2051           if $param->{'insert_args_callback'};
2052
2053   if ( $param->{'format'} ) {
2054
2055     my $format  = $param->{'format'};
2056     my $formats = $param->{formats};
2057     die "unknown format $format" unless exists $formats->{ $format };
2058
2059     $type = $param->{'format_types'}
2060             ? $param->{'format_types'}{ $format }
2061             : $param->{type} || 'csv';
2062
2063
2064     $header = $param->{'format_headers'}
2065                ? $param->{'format_headers'}{ $param->{'format'} }
2066                : 0;
2067
2068     $sep_char = $param->{'format_sep_chars'}
2069                   ? $param->{'format_sep_chars'}{ $param->{'format'} }
2070                   : ',';
2071
2072     $fixedlength_format =
2073       $param->{'format_fixedlength_formats'}
2074         ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
2075         : '';
2076
2077     $parser_opt =
2078       $param->{'format_parser_opts'}
2079         ? $param->{'format_parser_opts'}{ $param->{'format'} }
2080         : {};
2081
2082     $xml_format =
2083       $param->{'format_xml_formats'}
2084         ? $param->{'format_xml_formats'}{ $param->{'format'} }
2085         : '';
2086
2087     $asn_format =
2088       $param->{'format_asn_formats'}
2089         ? $param->{'format_asn_formats'}{ $param->{'format'} }
2090         : '';
2091
2092     $row_callback =
2093       $param->{'format_row_callbacks'}
2094         ? $param->{'format_row_callbacks'}{ $param->{'format'} }
2095         : '';
2096
2097     $hash_callback =
2098       $param->{'format_hash_callbacks'}
2099         ? $param->{'format_hash_callbacks'}{ $param->{'format'} }
2100         : '';
2101
2102     @fields = @{ $formats->{ $format } };
2103
2104   } elsif ( $param->{'fields'} ) {
2105
2106     $type = ''; #infer from filename
2107     $header = 0;
2108     $sep_char = ',';
2109     $fixedlength_format = '';
2110     $row_callback = '';
2111     $hash_callback = '';
2112     @fields = @{ $param->{'fields'} };
2113
2114   } else {
2115     die "neither format nor fields specified";
2116   }
2117
2118   #my $file    = $param->{file};
2119
2120   unless ( $type ) {
2121     if ( $file =~ /\.(\w+)$/i ) {
2122       $type = lc($1);
2123     } else {
2124       #or error out???
2125       warn "can't parse file type from filename $file; defaulting to CSV";
2126       $type = 'csv';
2127     }
2128     $type = 'csv'
2129       if $param->{'default_csv'} && $type ne 'xls';
2130   }
2131
2132
2133   my $row = 0;
2134   my $count;
2135   my $parser;
2136   my @buffer = ();
2137   my $asn_header_buffer;
2138   if ( $type eq 'csv' || $type eq 'fixedlength' ) {
2139
2140     if ( $type eq 'csv' ) {
2141
2142       $parser_opt->{'binary'} = 1;
2143       $parser_opt->{'sep_char'} = $sep_char if $sep_char;
2144       $parser = Text::CSV_XS->new($parser_opt);
2145
2146     } elsif ( $type eq 'fixedlength' ) {
2147
2148       eval "use Parse::FixedLength;";
2149       die $@ if $@;
2150       $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
2151
2152     } else {
2153       die "Unknown file type $type\n";
2154     }
2155
2156     @buffer = split(/\r?\n/, slurp($file) );
2157     splice(@buffer, 0, ($header || 0) );
2158     $count = scalar(@buffer);
2159
2160   } elsif ( $type eq 'xls' ) {
2161
2162     eval "use Spreadsheet::ParseExcel;";
2163     die $@ if $@;
2164
2165     eval "use DateTime::Format::Excel;";
2166     #for now, just let the error be thrown if it is used, since only CDR
2167     # formats bill_west and troop use it, not other excel-parsing things
2168     #die $@ if $@;
2169
2170     my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
2171
2172     $parser = $excel->{Worksheet}[0]; #first sheet
2173
2174     $count = $parser->{MaxRow} || $parser->{MinRow};
2175     $count++;
2176
2177     $row = $header || 0;
2178
2179   } elsif ( $type eq 'xml' ) {
2180
2181     # FS::pay_batch
2182     eval "use XML::Simple;";
2183     die $@ if $@;
2184     my $xmlrow = $xml_format->{'xmlrow'};
2185     $parser = $xml_format->{'xmlkeys'};
2186     die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
2187     my $data = XML::Simple::XMLin(
2188       $file,
2189       'SuppressEmpty' => '', #sets empty values to ''
2190       'KeepRoot'      => 1,
2191     );
2192     my $rows = $data;
2193     $rows = $rows->{$_} foreach @$xmlrow;
2194     $rows = [ $rows ] if ref($rows) ne 'ARRAY';
2195     $count = @buffer = @$rows;
2196
2197   } elsif ( $type eq 'asn.1' ) {
2198
2199     eval "use Convert::ASN1";
2200     die $@ if $@;
2201
2202     my $asn = Convert::ASN1->new;
2203     $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
2204
2205     $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
2206
2207     my $data = slurp($file);
2208     my $asn_output = $parser->decode( $data )
2209       or return "No ". $asn_format->{'macro'}. " found\n";
2210
2211     $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
2212
2213     my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
2214     $count = @buffer = @$rows;
2215
2216   } else {
2217     die "Unknown file type $type\n";
2218   }
2219
2220   #my $columns;
2221
2222   local $SIG{HUP} = 'IGNORE';
2223   local $SIG{INT} = 'IGNORE';
2224   local $SIG{QUIT} = 'IGNORE';
2225   local $SIG{TERM} = 'IGNORE';
2226   local $SIG{TSTP} = 'IGNORE';
2227   local $SIG{PIPE} = 'IGNORE';
2228
2229   my $oldAutoCommit = $FS::UID::AutoCommit;
2230   local $FS::UID::AutoCommit = 0;
2231   my $dbh = dbh;
2232
2233   #my $params  = $param->{params} || {};
2234   if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
2235     my $batch_col   = $param->{'batch_keycol'};
2236
2237     my $batch_class = 'FS::'. $param->{'batch_table'};
2238     my $batch = $batch_class->new({
2239       $param->{'batch_namecol'} => $param->{'batch_namevalue'}
2240     });
2241     my $error = $batch->insert;
2242     if ( $error ) {
2243       $dbh->rollback if $oldAutoCommit;
2244       return "can't insert batch record: $error";
2245     }
2246     #primary key via dbdef? (so the column names don't have to match)
2247     my $batch_value = $batch->get( $param->{'batch_keycol'} );
2248
2249     $params->{ $batch_col } = $batch_value;
2250   }
2251
2252   #my $job     = $param->{job};
2253   my $line;
2254   my $imported = 0;
2255   my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
2256   while (1) {
2257
2258     my @columns = ();
2259     my %hash = %$params;
2260     if ( $type eq 'csv' ) {
2261
2262       last unless scalar(@buffer);
2263       $line = shift(@buffer);
2264
2265       next if $line =~ /^\s*$/; #skip empty lines
2266
2267       $line = &{$row_callback}($line) if $row_callback;
2268
2269       next if $line =~ /^\s*$/; #skip empty lines
2270
2271       $parser->parse($line) or do {
2272         $dbh->rollback if $oldAutoCommit;
2273         return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
2274       };
2275       @columns = $parser->fields();
2276
2277     } elsif ( $type eq 'fixedlength' ) {
2278
2279       last unless scalar(@buffer);
2280       $line = shift(@buffer);
2281
2282       @columns = $parser->parse($line);
2283
2284     } elsif ( $type eq 'xls' ) {
2285
2286       last if $row > ($parser->{MaxRow} || $parser->{MinRow})
2287            || ! $parser->{Cells}[$row];
2288
2289       my @row = @{ $parser->{Cells}[$row] };
2290       @columns = map $_->{Val}, @row;
2291
2292       #my $z = 'A';
2293       #warn $z++. ": $_\n" for @columns;
2294
2295     } elsif ( $type eq 'xml' ) {
2296
2297       # $parser = [ 'Column0Key', 'Column1Key' ... ]
2298       last unless scalar(@buffer);
2299       my $row = shift @buffer;
2300       @columns = @{ $row }{ @$parser };
2301
2302     } elsif ( $type eq 'asn.1' ) {
2303
2304       last unless scalar(@buffer);
2305       my $row = shift @buffer;
2306       &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2307         if $asn_format->{row_callback};
2308       foreach my $key ( keys %{ $asn_format->{map} } ) {
2309         $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2310       }
2311
2312     } else {
2313       die "Unknown file type $type\n";
2314     }
2315
2316     my @later = ();
2317
2318     foreach my $field ( @fields ) {
2319
2320       my $value = shift @columns;
2321
2322       if ( ref($field) eq 'CODE' ) {
2323         #&{$field}(\%hash, $value);
2324         push @later, $field, $value;
2325       } else {
2326         #??? $hash{$field} = $value if length($value);
2327         $hash{$field} = $value if defined($value) && length($value);
2328       }
2329
2330     }
2331
2332     if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
2333                          && length($1) == $custnum_length ) {
2334       $hash{custnum} = $2;
2335     }
2336
2337     %hash = &{$hash_callback}(%hash) if $hash_callback;
2338
2339     #my $table   = $param->{table};
2340     my $class = "FS::$table";
2341
2342     my $record = $class->new( \%hash );
2343
2344     my $param = {};
2345     while ( scalar(@later) ) {
2346       my $sub = shift @later;
2347       my $data = shift @later;
2348       eval {
2349         &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2350       };
2351       if ( $@ ) {
2352         $dbh->rollback if $oldAutoCommit;
2353         return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2354       }
2355       last if exists( $param->{skiprow} );
2356     }
2357     next if exists( $param->{skiprow} );
2358
2359     if ( $preinsert_callback ) {
2360       my $error = &{$preinsert_callback}($record, $param);
2361       if ( $error ) {
2362         $dbh->rollback if $oldAutoCommit;
2363         return "preinsert_callback error". ( $line ? " for $line" : '' ).
2364                ": $error";
2365       }
2366       next if exists $param->{skiprow} && $param->{skiprow};
2367     }
2368
2369     my @insert_args = ();
2370     if ( $insert_args_callback ) {
2371       @insert_args = &{$insert_args_callback}($record, $param);
2372     }
2373
2374     my $error = $record->insert(@insert_args);
2375
2376     if ( $error ) {
2377       $dbh->rollback if $oldAutoCommit;
2378       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2379     }
2380
2381     $row++;
2382     $imported++;
2383
2384     if ( $postinsert_callback ) {
2385       my $error = &{$postinsert_callback}($record, $param);
2386       if ( $error ) {
2387         $dbh->rollback if $oldAutoCommit;
2388         return "postinsert_callback error". ( $line ? " for $line" : '' ).
2389                ": $error";
2390       }
2391     }
2392
2393     if ( $job && time - $min_sec > $last ) { #progress bar
2394       $job->update_statustext( int(100 * $imported / $count) );
2395       $last = time;
2396     }
2397
2398   }
2399
2400   unless ( $imported || $param->{empty_ok} ) {
2401     $dbh->rollback if $oldAutoCommit;
2402     return "Empty file!";
2403   }
2404
2405   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2406
2407   ''; #no error
2408
2409 }
2410
2411 sub _h_statement {
2412   my( $self, $action, $time ) = @_;
2413
2414   $time ||= time;
2415
2416   my %nohistory = map { $_=>1 } $self->nohistory_fields;
2417
2418   my @fields =
2419     grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2420     real_fields($self->table);
2421   ;
2422
2423   # If we're encrypting then don't store the payinfo in the history
2424   if ( $conf_encryption && $self->table ne 'banned_pay' ) {
2425     @fields = grep { $_ ne 'payinfo' } @fields;
2426   }
2427
2428   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2429
2430   "INSERT INTO h_". $self->table. " ( ".
2431       join(', ', qw(history_date history_usernum history_action), @fields ).
2432     ") VALUES (".
2433       join(', ', $time,
2434                  $FS::CurrentUser::CurrentUser->usernum,
2435                  dbh->quote($action),
2436                  @values
2437       ).
2438     ")"
2439   ;
2440 }
2441
2442 =item unique COLUMN
2443
2444 B<Warning>: External use is B<deprecated>.
2445
2446 Replaces COLUMN in record with a unique number, using counters in the
2447 filesystem.  Used by the B<insert> method on single-field unique columns
2448 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2449 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2450
2451 Returns the new value.
2452
2453 =cut
2454
2455 sub unique {
2456   my($self,$field) = @_;
2457   my($table)=$self->table;
2458
2459   croak "Unique called on field $field, but it is ",
2460         $self->getfield($field),
2461         ", not null!"
2462     if $self->getfield($field);
2463
2464   #warn "table $table is tainted" if is_tainted($table);
2465   #warn "field $field is tainted" if is_tainted($field);
2466
2467   my($counter) = new File::CounterFile "$table.$field",0;
2468
2469   my $index = $counter->inc;
2470   $index = $counter->inc while qsearchs($table, { $field=>$index } );
2471
2472   $index =~ /^(\d*)$/;
2473   $index=$1;
2474
2475   $self->setfield($field,$index);
2476
2477 }
2478
2479 =item ut_float COLUMN
2480
2481 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
2482 null.  If there is an error, returns the error, otherwise returns false.
2483
2484 =cut
2485
2486 sub ut_float {
2487   my($self,$field)=@_ ;
2488   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2489    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2490    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2491    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2492     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2493   $self->setfield($field,$1);
2494   '';
2495 }
2496 =item ut_floatn COLUMN
2497
2498 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2499 null.  If there is an error, returns the error, otherwise returns false.
2500
2501 =cut
2502
2503 #false laziness w/ut_ipn
2504 sub ut_floatn {
2505   my( $self, $field ) = @_;
2506   if ( $self->getfield($field) =~ /^()$/ ) {
2507     $self->setfield($field,'');
2508     '';
2509   } else {
2510     $self->ut_float($field);
2511   }
2512 }
2513
2514 =item ut_sfloat COLUMN
2515
2516 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2517 May not be null.  If there is an error, returns the error, otherwise returns
2518 false.
2519
2520 =cut
2521
2522 sub ut_sfloat {
2523   my($self,$field)=@_ ;
2524   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2525    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2526    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2527    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2528     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2529   $self->setfield($field,$1);
2530   '';
2531 }
2532 =item ut_sfloatn COLUMN
2533
2534 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2535 null.  If there is an error, returns the error, otherwise returns false.
2536
2537 =cut
2538
2539 sub ut_sfloatn {
2540   my( $self, $field ) = @_;
2541   if ( $self->getfield($field) =~ /^()$/ ) {
2542     $self->setfield($field,'');
2543     '';
2544   } else {
2545     $self->ut_sfloat($field);
2546   }
2547 }
2548
2549 =item ut_snumber COLUMN
2550
2551 Check/untaint signed numeric data (whole numbers).  If there is an error,
2552 returns the error, otherwise returns false.
2553
2554 =cut
2555
2556 sub ut_snumber {
2557   my($self, $field) = @_;
2558   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2559     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2560   $self->setfield($field, "$1$2");
2561   '';
2562 }
2563
2564 =item ut_snumbern COLUMN
2565
2566 Check/untaint signed numeric data (whole numbers).  If there is an error,
2567 returns the error, otherwise returns false.
2568
2569 =cut
2570
2571 sub ut_snumbern {
2572   my($self, $field) = @_;
2573   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2574     or return "Illegal (numeric) $field: ". $self->getfield($field);
2575   if ($1) {
2576     return "Illegal (numeric) $field: ". $self->getfield($field)
2577       unless $2;
2578   }
2579   $self->setfield($field, "$1$2");
2580   '';
2581 }
2582
2583 =item ut_number COLUMN
2584
2585 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
2586 is an error, returns the error, otherwise returns false.
2587
2588 =cut
2589
2590 sub ut_number {
2591   my($self,$field)=@_;
2592   $self->getfield($field) =~ /^\s*(\d+)\s*$/
2593     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2594   $self->setfield($field,$1);
2595   '';
2596 }
2597
2598 =item ut_numbern COLUMN
2599
2600 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
2601 an error, returns the error, otherwise returns false.
2602
2603 =cut
2604
2605 sub ut_numbern {
2606   my($self,$field)=@_;
2607   $self->getfield($field) =~ /^\s*(\d*)\s*$/
2608     or return "Illegal (numeric) $field: ". $self->getfield($field);
2609   $self->setfield($field,$1);
2610   '';
2611 }
2612
2613 =item ut_decimal COLUMN[, DIGITS]
2614
2615 Check/untaint decimal numbers (up to DIGITS decimal places.  If there is an
2616 error, returns the error, otherwise returns false.
2617
2618 =item ut_decimaln COLUMN[, DIGITS]
2619
2620 Check/untaint decimal numbers.  May be null.  If there is an error, returns
2621 the error, otherwise returns false.
2622
2623 =cut
2624
2625 sub ut_decimal {
2626   my($self, $field, $digits) = @_;
2627   $digits ||= '';
2628   $self->getfield($field) =~ /^\s*(\d+(\.\d{0,$digits})?)\s*$/
2629     or return "Illegal or empty (decimal) $field: ".$self->getfield($field);
2630   $self->setfield($field, $1);
2631   '';
2632 }
2633
2634 sub ut_decimaln {
2635   my($self, $field, $digits) = @_;
2636   $self->getfield($field) =~ /^\s*(\d*(\.\d{0,$digits})?)\s*$/
2637     or return "Illegal (decimal) $field: ".$self->getfield($field);
2638   $self->setfield($field, $1);
2639   '';
2640 }
2641
2642 =item ut_money COLUMN
2643
2644 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
2645 is an error, returns the error, otherwise returns false.
2646
2647 =cut
2648
2649 sub ut_money {
2650   my($self,$field)=@_;
2651
2652   if ( $self->getfield($field) eq '' ) {
2653     $self->setfield($field, 0);
2654   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2655     #handle one decimal place without barfing out
2656     $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2657   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2658     $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2659   } else {
2660     return "Illegal (money) $field: ". $self->getfield($field);
2661   }
2662
2663   '';
2664 }
2665
2666 =item ut_moneyn COLUMN
2667
2668 Check/untaint monetary numbers.  May be negative.  If there
2669 is an error, returns the error, otherwise returns false.
2670
2671 =cut
2672
2673 sub ut_moneyn {
2674   my($self,$field)=@_;
2675   if ($self->getfield($field) eq '') {
2676     $self->setfield($field, '');
2677     return '';
2678   }
2679   $self->ut_money($field);
2680 }
2681
2682 =item ut_currencyn COLUMN
2683
2684 Check/untaint currency indicators, such as USD or EUR.  May be null.  If there
2685 is an error, returns the error, otherwise returns false.
2686
2687 =cut
2688
2689 sub ut_currencyn {
2690   my($self, $field) = @_;
2691   if ($self->getfield($field) eq '') { #can be null
2692     $self->setfield($field, '');
2693     return '';
2694   }
2695   $self->ut_currency($field);
2696 }
2697
2698 =item ut_currency COLUMN
2699
2700 Check/untaint currency indicators, such as USD or EUR.  May not be null.  If
2701 there is an error, returns the error, otherwise returns false.
2702
2703 =cut
2704
2705 sub ut_currency {
2706   my($self, $field) = @_;
2707   my $value = uc( $self->getfield($field) );
2708   if ( code2currency($value) ) {
2709     $self->setfield($value);
2710   } else {
2711     return "Unknown currency $value";
2712   }
2713
2714   '';
2715 }
2716
2717 =item ut_text COLUMN
2718
2719 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2720 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < > ~
2721 May not be null.  If there is an error, returns the error, otherwise returns
2722 false.
2723
2724 =cut
2725
2726 sub ut_text {
2727   my($self,$field)=@_;
2728   #warn "msgcat ". \&msgcat. "\n";
2729   #warn "notexist ". \&notexist. "\n";
2730   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2731   # \p{Word} = alphanumerics, marks (diacritics), and connectors
2732   # see perldoc perluniprops
2733   $self->getfield($field)
2734     =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>\~$money_char]+)$/
2735       or return gettext('illegal_or_empty_text'). " $field: ".
2736                  $self->getfield($field);
2737   $self->setfield($field,$1);
2738   '';
2739 }
2740
2741 =item ut_textn COLUMN
2742
2743 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2744 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2745 May be null.  If there is an error, returns the error, otherwise returns false.
2746
2747 =cut
2748
2749 sub ut_textn {
2750   my($self,$field)=@_;
2751   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2752   $self->ut_text($field);
2753 }
2754
2755 =item ut_alpha COLUMN
2756
2757 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
2758 an error, returns the error, otherwise returns false.
2759
2760 =cut
2761
2762 sub ut_alpha {
2763   my($self,$field)=@_;
2764   $self->getfield($field) =~ /^(\w+)$/
2765     or return "Illegal or empty (alphanumeric) $field: ".
2766               $self->getfield($field);
2767   $self->setfield($field,$1);
2768   '';
2769 }
2770
2771 =item ut_alphan COLUMN
2772
2773 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
2774 error, returns the error, otherwise returns false.
2775
2776 =cut
2777
2778 sub ut_alphan {
2779   my($self,$field)=@_;
2780   $self->getfield($field) =~ /^(\w*)$/
2781     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2782   $self->setfield($field,$1);
2783   '';
2784 }
2785
2786 =item ut_alphasn COLUMN
2787
2788 Check/untaint alphanumeric strings, spaces allowed.  May be null.  If there is
2789 an error, returns the error, otherwise returns false.
2790
2791 =cut
2792
2793 sub ut_alphasn {
2794   my($self,$field)=@_;
2795   $self->getfield($field) =~ /^([\w ]*)$/
2796     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2797   $self->setfield($field,$1);
2798   '';
2799 }
2800
2801
2802 =item ut_alpha_lower COLUMN
2803
2804 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
2805 there is an error, returns the error, otherwise returns false.
2806
2807 =cut
2808
2809 sub ut_alpha_lower {
2810   my($self,$field)=@_;
2811   $self->getfield($field) =~ /[[:upper:]]/
2812     and return "Uppercase characters are not permitted in $field";
2813   $self->ut_alpha($field);
2814 }
2815
2816 =item ut_phonen COLUMN [ COUNTRY ]
2817
2818 Check/untaint phone numbers.  May be null.  If there is an error, returns
2819 the error, otherwise returns false.
2820
2821 Takes an optional two-letter ISO 3166-1 alpha-2 country code; without
2822 it or with unsupported countries, ut_phonen simply calls ut_alphan.
2823
2824 =cut
2825
2826 sub ut_phonen {
2827   my( $self, $field, $country ) = @_;
2828   return $self->ut_alphan($field) unless defined $country;
2829   my $phonen = $self->getfield($field);
2830   if ( $phonen eq '' ) {
2831     $self->setfield($field,'');
2832   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2833     $phonen =~ s/\D//g;
2834     $phonen = $conf->config('cust_main-default_areacode').$phonen
2835       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2836     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2837       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2838     $phonen = "$1-$2-$3";
2839     $phonen .= " x$4" if $4;
2840     $self->setfield($field,$phonen);
2841   } else {
2842     warn "warning: don't know how to check phone numbers for country $country";
2843     return $self->ut_textn($field);
2844   }
2845   '';
2846 }
2847
2848 =item ut_hex COLUMN
2849
2850 Check/untaint hexadecimal values.
2851
2852 =cut
2853
2854 sub ut_hex {
2855   my($self, $field) = @_;
2856   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2857     or return "Illegal (hex) $field: ". $self->getfield($field);
2858   $self->setfield($field, uc($1));
2859   '';
2860 }
2861
2862 =item ut_hexn COLUMN
2863
2864 Check/untaint hexadecimal values.  May be null.
2865
2866 =cut
2867
2868 sub ut_hexn {
2869   my($self, $field) = @_;
2870   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2871     or return "Illegal (hex) $field: ". $self->getfield($field);
2872   $self->setfield($field, uc($1));
2873   '';
2874 }
2875
2876 =item ut_mac_addr COLUMN
2877
2878 Check/untaint mac addresses.  May be null.
2879
2880 =cut
2881
2882 sub ut_mac_addr {
2883   my($self, $field) = @_;
2884
2885   my $mac = $self->get($field);
2886   $mac =~ s/\s+//g;
2887   $mac =~ s/://g;
2888   $self->set($field, $mac);
2889
2890   my $e = $self->ut_hex($field);
2891   return $e if $e;
2892
2893   return "Illegal (mac address) $field: ". $self->getfield($field)
2894     unless length($self->getfield($field)) == 12;
2895
2896   '';
2897
2898 }
2899
2900 =item ut_mac_addrn COLUMN
2901
2902 Check/untaint mac addresses.  May be null.
2903
2904 =cut
2905
2906 sub ut_mac_addrn {
2907   my($self, $field) = @_;
2908   ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2909 }
2910
2911 =item ut_ip COLUMN
2912
2913 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2914 to 127.0.0.1.
2915
2916 =cut
2917
2918 sub ut_ip {
2919   my( $self, $field ) = @_;
2920   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2921   return "Illegal (IP address) $field: ".$self->getfield($field)
2922     unless $self->getfield($field) =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/;
2923   $self->ut_ip46($field);
2924 }
2925
2926 =item ut_ipn COLUMN
2927
2928 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2929 to 127.0.0.1.  May be null.
2930
2931 =cut
2932
2933 sub ut_ipn {
2934   my( $self, $field ) = @_;
2935   if ( $self->getfield($field) =~ /^()$/ ) {
2936     $self->setfield($field,'');
2937     '';
2938   } else {
2939     $self->ut_ip($field);
2940   }
2941 }
2942
2943 =item ut_ip46 COLUMN
2944
2945 Check/untaint IPv4 or IPv6 address.
2946
2947 =cut
2948
2949 sub ut_ip46 {
2950   my( $self, $field ) = @_;
2951   my $ip = NetAddr::IP->new(
2952     $self->_ut_ip_strip_leading_zeros( $self->getfield( $field ) )
2953   ) or return "Illegal (IP address) $field: ".$self->getfield($field);
2954   $self->setfield($field, lc($ip->addr));
2955   return '';
2956 }
2957
2958 =item ut_ip46n
2959
2960 Check/untaint IPv6 or IPv6 address.  May be null.
2961
2962 =cut
2963
2964 sub ut_ip46n {
2965   my( $self, $field ) = @_;
2966   if ( $self->getfield($field) =~ /^$/ ) {
2967     $self->setfield($field, '');
2968     return '';
2969   }
2970   $self->ut_ip46($field);
2971 }
2972
2973 sub _ut_ip_strip_leading_zeros {
2974   # strip user-entered leading 0's from IP addresses
2975   # so parsers like NetAddr::IP don't mangle the address
2976   # e.g. NetAddr::IP converts 10.0.022.220 into 10.0.18.220
2977
2978   my ( $self, $ip ) = @_;
2979
2980   return join '.', map int, split /\./, $ip
2981     if $ip
2982     && $ip =~ /\./
2983     && $ip =~ /[\.^]0/;
2984   $ip;
2985 }
2986
2987
2988 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2989
2990 Check/untaint coordinates.
2991 Accepts the following forms:
2992 DDD.DDDDD
2993 -DDD.DDDDD
2994 DDD MM.MMM
2995 -DDD MM.MMM
2996 DDD MM SS
2997 -DDD MM SS
2998 DDD MM MMM
2999 -DDD MM MMM
3000
3001 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
3002 The latter form (that is, the MMM are thousands of minutes) is
3003 assumed if the "MMM" is exactly three digits or two digits > 59.
3004
3005 To be safe, just use the DDD.DDDDD form.
3006
3007 If LOWER or UPPER are specified, then the coordinate is checked
3008 for lower and upper bounds, respectively.
3009
3010 =cut
3011
3012 sub ut_coord {
3013   my ($self, $field) = (shift, shift);
3014
3015   my($lower, $upper);
3016   if ( $field =~ /latitude/ ) {
3017     $lower = $lat_lower;
3018     $upper = 90;
3019   } elsif ( $field =~ /longitude/ ) {
3020     $lower = -180;
3021     $upper = $lon_upper;
3022   }
3023
3024   my $coord = $self->getfield($field);
3025   my $neg = $coord =~ s/^(-)//;
3026
3027   # ignore degree symbol at the end,
3028   #   but not otherwise supporting degree/minutes/seconds symbols
3029   $coord =~ s/\N{DEGREE SIGN}\s*$//;
3030
3031   my ($d, $m, $s) = (0, 0, 0);
3032
3033   if (
3034     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
3035     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
3036     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
3037   ) {
3038     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
3039     $m = $m / 60;
3040     if ($m > 59) {
3041       return "Invalid (coordinate with minutes > 59) $field: "
3042              . $self->getfield($field);
3043     }
3044
3045     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
3046
3047     if (defined($lower) and ($coord < $lower)) {
3048       return "Invalid (coordinate < $lower) $field: "
3049              . $self->getfield($field);;
3050     }
3051
3052     if (defined($upper) and ($coord > $upper)) {
3053       return "Invalid (coordinate > $upper) $field: "
3054              . $self->getfield($field);;
3055     }
3056
3057     $self->setfield($field, $coord);
3058     return '';
3059   }
3060
3061   return "Invalid (coordinate) $field: " . $self->getfield($field);
3062
3063 }
3064
3065 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
3066
3067 Same as ut_coord, except optionally null.
3068
3069 =cut
3070
3071 sub ut_coordn {
3072
3073   my ($self, $field) = (shift, shift);
3074
3075   if ($self->getfield($field) =~ /^\s*$/) {
3076     return '';
3077   } else {
3078     return $self->ut_coord($field, @_);
3079   }
3080
3081 }
3082
3083 =item ut_domain COLUMN
3084
3085 Check/untaint host and domain names.  May not be null.
3086
3087 =cut
3088
3089 sub ut_domain {
3090   my( $self, $field ) = @_;
3091   #$self->getfield($field) =~/^(\w+\.)*\w+$/
3092   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
3093     or return "Illegal (hostname) $field: ". $self->getfield($field);
3094   $self->setfield($field,$1);
3095   '';
3096 }
3097
3098 =item ut_domainn COLUMN
3099
3100 Check/untaint host and domain names.  May be null.
3101
3102 =cut
3103
3104 sub ut_domainn {
3105   my( $self, $field ) = @_;
3106   if ( $self->getfield($field) =~ /^()$/ ) {
3107     $self->setfield($field,'');
3108     '';
3109   } else {
3110     $self->ut_domain($field);
3111   }
3112 }
3113
3114 =item ut_name COLUMN
3115
3116 Check/untaint proper names; allows alphanumerics, spaces and the following
3117 punctuation: , . - '
3118
3119 May not be null.
3120
3121 =cut
3122
3123 sub ut_name {
3124   my( $self, $field ) = @_;
3125   $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
3126     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
3127   my $name = $1;
3128   $name =~ s/^\s+//;
3129   $name =~ s/\s+$//;
3130   $name =~ s/\s+/ /g;
3131   $self->setfield($field, $name);
3132   '';
3133 }
3134
3135 =item ut_namen COLUMN
3136
3137 Check/untaint proper names; allows alphanumerics, spaces and the following
3138 punctuation: , . - '
3139
3140 May not be null.
3141
3142 =cut
3143
3144 sub ut_namen {
3145   my( $self, $field ) = @_;
3146   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
3147   $self->ut_name($field);
3148 }
3149
3150 =item ut_zip COLUMN
3151
3152 Check/untaint zip codes.
3153
3154 =cut
3155
3156 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
3157
3158 sub ut_zip {
3159   my( $self, $field, $country ) = @_;
3160
3161   if ( $country eq 'US' ) {
3162
3163     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
3164       or return gettext('illegal_zip'). " $field for country $country: ".
3165                 $self->getfield($field);
3166     $self->setfield($field, $1);
3167
3168   } elsif ( $country eq 'CA' ) {
3169
3170     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
3171       or return gettext('illegal_zip'). " $field for country $country: ".
3172                 $self->getfield($field);
3173     $self->setfield($field, "$1 $2");
3174
3175   } elsif ( $country eq 'AU' ) {
3176
3177     $self->getfield($field) =~ /^\s*(\d{4})\s*$/
3178       or return gettext('illegal_zip'). " $field for country $country: ".
3179                 $self->getfield($field);
3180     $self->setfield($field, $1);
3181
3182   } else {
3183
3184     if ( $self->getfield($field) =~ /^\s*$/
3185          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
3186        )
3187     {
3188       $self->setfield($field,'');
3189     } else {
3190       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
3191         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
3192       $self->setfield($field,$1);
3193     }
3194
3195   }
3196
3197   '';
3198 }
3199
3200 =item ut_country COLUMN
3201
3202 Check/untaint country codes.  Country names are changed to codes, if possible -
3203 see L<Locale::Country>.
3204
3205 =cut
3206
3207 sub ut_country {
3208   my( $self, $field ) = @_;
3209   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
3210     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
3211          && country2code($1) ) {
3212       $self->setfield($field,uc(country2code($1)));
3213     }
3214   }
3215   $self->getfield($field) =~ /^(\w\w)$/
3216     or return "Illegal (country) $field: ". $self->getfield($field);
3217   $self->setfield($field,uc($1));
3218   '';
3219 }
3220
3221 =item ut_anything COLUMN
3222
3223 Untaints arbitrary data.  Be careful.
3224
3225 =cut
3226
3227 sub ut_anything {
3228   my( $self, $field ) = @_;
3229   $self->getfield($field) =~ /^(.*)$/s
3230     or return "Illegal $field: ". $self->getfield($field);
3231   $self->setfield($field,$1);
3232   '';
3233 }
3234
3235 =item ut_enum COLUMN CHOICES_ARRAYREF
3236
3237 Check/untaint a column, supplying all possible choices, like the "enum" type.
3238
3239 =cut
3240
3241 sub ut_enum {
3242   my( $self, $field, $choices ) = @_;
3243   foreach my $choice ( @$choices ) {
3244     if ( $self->getfield($field) eq $choice ) {
3245       $self->setfield($field, $choice);
3246       return '';
3247     }
3248   }
3249   return "Illegal (enum) field $field: ". $self->getfield($field);
3250 }
3251
3252 =item ut_enumn COLUMN CHOICES_ARRAYREF
3253
3254 Like ut_enum, except the null value is also allowed.
3255
3256 =cut
3257
3258 sub ut_enumn {
3259   my( $self, $field, $choices ) = @_;
3260   $self->getfield($field)
3261     ? $self->ut_enum($field, $choices)
3262     : '';
3263 }
3264
3265 =item ut_date COLUMN
3266
3267 Check/untaint a column containing a date string.
3268
3269 Date will be normalized to YYYY-MM-DD format
3270
3271 =cut
3272
3273 sub ut_date {
3274   my ( $self, $field ) = @_;
3275   my $value = $self->getfield( $field );
3276
3277   my @date = split /[\-\/]/, $value;
3278   if ( scalar(@date) == 3 ) {
3279     @date = @date[2,0,1] if $date[2] >= 1900;
3280
3281     local $@;
3282     my $ymd;
3283     eval {
3284       # DateTime will die given invalid date
3285       $ymd = DateTime->new(
3286         year  => $date[0],
3287         month => $date[1],
3288         day   => $date[2],
3289       )->ymd('-');
3290     };
3291
3292     unless( $@ ) {
3293       $self->setfield( $field, $ymd ) unless $value eq $ymd;
3294       return '';
3295     }
3296
3297   }
3298   return "Illegal (date) field $field: $value";
3299 }
3300
3301 =item ut_daten COLUMN
3302
3303 Check/untaint a column containing a date string.
3304
3305 Column may be null.
3306
3307 Date will be normalized to YYYY-MM-DD format
3308
3309 =cut
3310
3311 sub ut_daten {
3312   my ( $self, $field ) = @_;
3313
3314   $self->getfield( $field ) =~ /^()$/
3315   ? $self->setfield( $field, '' )
3316   : $self->ut_date( $field );
3317 }
3318
3319 =item ut_flag COLUMN
3320
3321 Check/untaint a column if it contains either an empty string or 'Y'.  This
3322 is the standard form for boolean flags in Freeside.
3323
3324 =cut
3325
3326 sub ut_flag {
3327   my( $self, $field ) = @_;
3328   my $value = uc($self->getfield($field));
3329   if ( $value eq '' or $value eq 'Y' ) {
3330     $self->setfield($field, $value);
3331     return '';
3332   }
3333   return "Illegal (flag) field $field: $value";
3334 }
3335
3336 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3337
3338 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
3339 on the column first.
3340
3341 =cut
3342
3343 sub ut_foreign_key {
3344   my( $self, $field, $table, $foreign ) = @_;
3345   return $self->ut_number($field) if $no_check_foreign;
3346   qsearchs($table, { $foreign => $self->getfield($field) })
3347     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
3348               " in $table.$foreign";
3349   '';
3350 }
3351
3352 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3353
3354 Like ut_foreign_key, except the null value is also allowed.
3355
3356 =cut
3357
3358 sub ut_foreign_keyn {
3359   my( $self, $field, $table, $foreign ) = @_;
3360   $self->getfield($field)
3361     ? $self->ut_foreign_key($field, $table, $foreign)
3362     : '';
3363 }
3364
3365 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
3366
3367 Checks this column as an agentnum, taking into account the current users's
3368 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
3369 right or rights allowing no agentnum.
3370
3371 =cut
3372
3373 sub ut_agentnum_acl {
3374   my( $self, $field ) = (shift, shift);
3375   my $null_acl = scalar(@_) ? shift : [];
3376   $null_acl = [ $null_acl ] unless ref($null_acl);
3377
3378   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
3379   return "Illegal agentnum: $error" if $error;
3380
3381   my $curuser = $FS::CurrentUser::CurrentUser;
3382
3383   if ( $self->$field() ) {
3384
3385     return 'Access denied to agent '. $self->$field()
3386       unless $curuser->agentnum($self->$field());
3387
3388   } else {
3389
3390     return 'Access denied to global'
3391       unless grep $curuser->access_right($_), @$null_acl;
3392
3393   }
3394
3395   '';
3396
3397 }
3398
3399
3400 =item ut_email COLUMN
3401
3402 Check column contains a valid E-Mail address
3403
3404 =cut
3405
3406 sub ut_email {
3407   my ( $self, $field ) = @_;
3408   Email::Valid->address( $self->getfield( $field ) )
3409     ? ''
3410     : "Illegal (email) field $field: ". $self->getfield( $field );
3411 }
3412
3413 =item ut_emailn COLUMN
3414
3415 Check column contains a valid E-Mail address
3416
3417 May be null
3418
3419 =cut
3420
3421 sub ut_emailn {
3422   my ( $self, $field ) = @_;
3423
3424   $self->getfield( $field ) =~ /^$/
3425     ? $self->getfield( $field, '' )
3426     : $self->ut_email( $field );
3427 }
3428
3429 =item trim_whitespace FIELD[, FIELD ... ]
3430
3431 Strip leading and trailing spaces from the value in the named FIELD(s).
3432
3433 =cut
3434
3435 sub trim_whitespace {
3436   my $self = shift;
3437   foreach my $field (@_) {
3438     my $value = $self->get($field);
3439     $value =~ s/^\s+//;
3440     $value =~ s/\s+$//;
3441     $self->set($field, $value);
3442   }
3443 }
3444
3445 =item fields [ TABLE ]
3446
3447 This is a wrapper for real_fields.  Code that called
3448 fields before should probably continue to call fields.
3449
3450 =cut
3451
3452 sub fields {
3453   my $something = shift;
3454   my $table;
3455   if($something->isa('FS::Record')) {
3456     $table = $something->table;
3457   } else {
3458     $table = $something;
3459     #$something = "FS::$table";
3460   }
3461   return (real_fields($table));
3462 }
3463
3464
3465 =item encrypt($value)
3466
3467 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
3468
3469 Returns the encrypted string.
3470
3471 You should generally not have to worry about calling this, as the system handles this for you.
3472
3473 =cut
3474
3475 sub encrypt {
3476   my ($self, $value) = @_;
3477   my $encrypted = $value;
3478
3479   if ($conf_encryption) {
3480     if ($self->is_encrypted($value)) {
3481       # Return the original value if it isn't plaintext.
3482       $encrypted = $value;
3483     } else {
3484       $self->loadRSA;
3485       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
3486         # RSA doesn't like the empty string so let's pack it up
3487         # The database doesn't like the RSA data so uuencode it
3488         my $length = length($value)+1;
3489         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
3490       } else {
3491         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
3492       }
3493     }
3494   }
3495   return $encrypted;
3496 }
3497
3498 =item is_encrypted($value)
3499
3500 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
3501
3502 =cut
3503
3504
3505 sub is_encrypted {
3506   my ($self, $value) = @_;
3507   # could be more precise about it, but this will do for now
3508   $value =~ /^M/ && length($value) > 80;
3509 }
3510
3511 =item decrypt($value)
3512
3513 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
3514
3515 You should generally not have to worry about calling this, as the system handles this for you.
3516
3517 =cut
3518
3519 sub decrypt {
3520   my ($self,$value) = @_;
3521   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
3522   if ($conf_encryption && $self->is_encrypted($value)) {
3523     $self->loadRSA;
3524     if (ref($rsa_decrypt) =~ /::RSA/) {
3525       my $encrypted = unpack ("u*", $value);
3526       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
3527       if ($@) {warn "Decryption Failed"};
3528     }
3529   }
3530   return $decrypted;
3531 }
3532
3533 sub loadRSA {
3534   my $self = shift;
3535
3536   my $rsa_module = $conf_encryptionmodule || 'Crypt::OpenSSL::RSA';
3537
3538   # Initialize Encryption
3539   if ($conf_encryptionpublickey && $conf_encryptionpublickey ne '') {
3540     $rsa_encrypt = $rsa_module->new_public_key($conf_encryptionpublickey);
3541   }
3542
3543   # Intitalize Decryption
3544   if ($conf_encryptionprivatekey && $conf_encryptionprivatekey ne '') {
3545     $rsa_decrypt = $rsa_module->new_private_key($conf_encryptionprivatekey);
3546   }
3547 }
3548
3549 =item h_search ACTION
3550
3551 Given an ACTION, either "insert", or "delete", returns the appropriate history
3552 record corresponding to this record, if any.
3553
3554 =cut
3555
3556 sub h_search {
3557   my( $self, $action ) = @_;
3558
3559   my $table = $self->table;
3560   $table =~ s/^h_//;
3561
3562   my $primary_key = dbdef->table($table)->primary_key;
3563
3564   qsearchs({
3565     'table'   => "h_$table",
3566     'hashref' => { $primary_key     => $self->$primary_key(),
3567                    'history_action' => $action,
3568                  },
3569   });
3570
3571 }
3572
3573 =item h_date ACTION
3574
3575 Given an ACTION, either "insert", or "delete", returns the timestamp of the
3576 appropriate history record corresponding to this record, if any.
3577
3578 =cut
3579
3580 sub h_date {
3581   my($self, $action) = @_;
3582   my $h = $self->h_search($action);
3583   $h ? $h->history_date : '';
3584 }
3585
3586 =item scalar_sql SQL [ PLACEHOLDER, ... ]
3587
3588 A class or object method.  Executes the sql statement represented by SQL and
3589 returns a scalar representing the result: the first column of the first row.
3590
3591 Dies on bogus SQL.  Returns an empty string if no row is returned.
3592
3593 Typically used for statments which return a single value such as "SELECT
3594 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
3595
3596 =cut
3597
3598 sub scalar_sql {
3599   my($self, $sql) = (shift, shift);
3600   my $sth = dbh->prepare($sql) or die dbh->errstr;
3601   $sth->execute(@_)
3602     or die "Unexpected error executing statement $sql: ". $sth->errstr;
3603   my $row = $sth->fetchrow_arrayref or return '';
3604   my $scalar = $row->[0];
3605   defined($scalar) ? $scalar : '';
3606 }
3607
3608 =item count [ WHERE [, PLACEHOLDER ...] ]
3609
3610 Convenience method for the common case of "SELECT COUNT(*) FROM table",
3611 with optional WHERE.  Must be called as method on a class with an
3612 associated table.
3613
3614 =cut
3615
3616 sub count {
3617   my($self, $where) = (shift, shift);
3618   my $table = $self->table or die 'count called on object of class '.ref($self);
3619   my $sql = "SELECT COUNT(*) FROM $table";
3620   $sql .= " WHERE $where" if $where;
3621   $self->scalar_sql($sql, @_);
3622 }
3623
3624 =item row_exists [ WHERE [, PLACEHOLDER ...] ]
3625
3626 Convenience method for the common case of "SELECT 1 FROM table ... LIMIT 1"
3627 with optional (but almost always needed) WHERE.
3628
3629 =cut
3630
3631 sub row_exists {
3632   my($self, $where) = (shift, shift);
3633   my $table = $self->table or die 'row_exists called on object of class '.ref($self);
3634   my $sql = "SELECT 1 FROM $table";
3635   $sql .= " WHERE $where" if $where;
3636   $sql .= " LIMIT 1";
3637   $self->scalar_sql($sql, @_);
3638 }
3639
3640 =back
3641
3642 =head1 SUBROUTINES
3643
3644 =over 4
3645
3646 =item real_fields [ TABLE ]
3647
3648 Returns a list of the real columns in the specified table.  Called only by
3649 fields() and other subroutines elsewhere in FS::Record.
3650
3651 =cut
3652
3653 sub real_fields {
3654   my $table = shift;
3655
3656   my($table_obj) = dbdef->table($table);
3657   confess "Unknown table $table" unless $table_obj;
3658   $table_obj->columns;
3659 }
3660
3661 =item pvf FIELD_NAME
3662
3663 Returns the FS::part_virtual_field object corresponding to a field in the
3664 record (specified by FIELD_NAME).
3665
3666 =cut
3667
3668 sub pvf {
3669   my ($self, $name) = (shift, shift);
3670
3671   if(grep /^$name$/, $self->virtual_fields) {
3672     $name =~ s/^cf_//;
3673     my $concat = [ "'cf_'", "name" ];
3674     return qsearchs({   table   =>  'part_virtual_field',
3675                         hashref =>  { dbtable => $self->table,
3676                                       name    => $name
3677                                     },
3678                         select  =>  'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
3679                     });
3680   }
3681   ''
3682 }
3683
3684 =item _quote VALUE, TABLE, COLUMN
3685
3686 This is an internal function used to construct SQL statements.  It returns
3687 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3688 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3689
3690 =cut
3691
3692 sub _quote {
3693   my($value, $table, $column) = @_;
3694   my $column_obj = dbdef->table($table)->column($column);
3695   my $column_type = $column_obj->type;
3696   my $nullable = $column_obj->null;
3697
3698   utf8::upgrade($value);
3699
3700   warn "  $table.$column: $value ($column_type".
3701        ( $nullable ? ' NULL' : ' NOT NULL' ).
3702        ")\n" if $DEBUG > 2;
3703
3704   if ( $value eq '' && $nullable ) {
3705     'NULL';
3706   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3707     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3708           "using 0 instead";
3709     0;
3710   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3711             ! $column_type =~ /(char|binary|text)$/i ) {
3712     $value;
3713   } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3714            && driver_name eq 'Pg'
3715           )
3716   {
3717     local $@;
3718
3719     eval { $value = dbh->quote($value, { pg_type => PG_BYTEA() }); };
3720
3721     if ( $@ && $@ =~ /Wide character/i ) {
3722       warn 'Correcting malformed UTF-8 string for binary quote()'
3723         if $DEBUG;
3724       utf8::decode($value);
3725       utf8::encode($value);
3726       $value = dbh->quote($value, { pg_type => PG_BYTEA() });
3727     }
3728
3729     $value;
3730   } else {
3731     dbh->quote($value);
3732   }
3733 }
3734
3735 =item hfields TABLE
3736
3737 This is deprecated.  Don't use it.
3738
3739 It returns a hash-type list with the fields of this record's table set true.
3740
3741 =cut
3742
3743 sub hfields {
3744   carp "warning: hfields is deprecated";
3745   my($table)=@_;
3746   my(%hash);
3747   foreach (fields($table)) {
3748     $hash{$_}=1;
3749   }
3750   \%hash;
3751 }
3752
3753 sub _dump {
3754   my($self)=@_;
3755   join("\n", map {
3756     "$_: ". $self->getfield($_). "|"
3757   } (fields($self->table)) );
3758 }
3759
3760 sub DESTROY { return; }
3761
3762 #sub DESTROY {
3763 #  my $self = shift;
3764 #  #use Carp qw(cluck);
3765 #  #cluck "DESTROYING $self";
3766 #  warn "DESTROYING $self";
3767 #}
3768
3769 #sub is_tainted {
3770 #             return ! eval { join('',@_), kill 0; 1; };
3771 #         }
3772
3773 =item str2time_sql [ DRIVER_NAME ]
3774
3775 Returns a function to convert to unix time based on database type, such as
3776 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
3777 the str2time_sql_closing method to return a closing string rather than just
3778 using a closing parenthesis as previously suggested.
3779
3780 You can pass an optional driver name such as "Pg", "mysql" or
3781 $dbh->{Driver}->{Name} to return a function for that database instead of
3782 the current database.
3783
3784 =cut
3785
3786 sub str2time_sql {
3787   my $driver = shift || driver_name;
3788
3789   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
3790   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3791
3792   warn "warning: unknown database type $driver; guessing how to convert ".
3793        "dates to UNIX timestamps";
3794   return 'EXTRACT(EPOCH FROM ';
3795
3796 }
3797
3798 =item str2time_sql_closing [ DRIVER_NAME ]
3799
3800 Returns the closing suffix of a function to convert to unix time based on
3801 database type, such as ")::integer" for Pg or ")" for mysql.
3802
3803 You can pass an optional driver name such as "Pg", "mysql" or
3804 $dbh->{Driver}->{Name} to return a function for that database instead of
3805 the current database.
3806
3807 =cut
3808
3809 sub str2time_sql_closing {
3810   my $driver = shift || driver_name;
3811
3812   return ' )::INTEGER ' if $driver =~ /^Pg/i;
3813   return ' ) ';
3814 }
3815
3816 =item regexp_sql [ DRIVER_NAME ]
3817
3818 Returns the operator to do a regular expression comparison based on database
3819 type, such as '~' for Pg or 'REGEXP' for mysql.
3820
3821 You can pass an optional driver name such as "Pg", "mysql" or
3822 $dbh->{Driver}->{Name} to return a function for that database instead of
3823 the current database.
3824
3825 =cut
3826
3827 sub regexp_sql {
3828   my $driver = shift || driver_name;
3829
3830   return '~'      if $driver =~ /^Pg/i;
3831   return 'REGEXP' if $driver =~ /^mysql/i;
3832
3833   die "don't know how to use regular expressions in ". driver_name." databases";
3834
3835 }
3836
3837 =item not_regexp_sql [ DRIVER_NAME ]
3838
3839 Returns the operator to do a regular expression negation based on database
3840 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3841
3842 You can pass an optional driver name such as "Pg", "mysql" or
3843 $dbh->{Driver}->{Name} to return a function for that database instead of
3844 the current database.
3845
3846 =cut
3847
3848 sub not_regexp_sql {
3849   my $driver = shift || driver_name;
3850
3851   return '!~'         if $driver =~ /^Pg/i;
3852   return 'NOT REGEXP' if $driver =~ /^mysql/i;
3853
3854   die "don't know how to use regular expressions in ". driver_name." databases";
3855
3856 }
3857
3858 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3859
3860 Returns the items concatenated based on database type, using "CONCAT()" for
3861 mysql and " || " for Pg and other databases.
3862
3863 You can pass an optional driver name such as "Pg", "mysql" or
3864 $dbh->{Driver}->{Name} to return a function for that database instead of
3865 the current database.
3866
3867 =cut
3868
3869 sub concat_sql {
3870   my $driver = ref($_[0]) ? driver_name : shift;
3871   my $items = shift;
3872
3873   if ( $driver =~ /^mysql/i ) {
3874     'CONCAT('. join(',', @$items). ')';
3875   } else {
3876     join('||', @$items);
3877   }
3878
3879 }
3880
3881 =item group_concat_sql COLUMN, DELIMITER
3882
3883 Returns an SQL expression to concatenate an aggregate column, using
3884 GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg.
3885
3886 =cut
3887
3888 sub group_concat_sql {
3889   my ($col, $delim) = @_;
3890   $delim = dbh->quote($delim);
3891   if ( driver_name() =~ /^mysql/i ) {
3892     # DISTINCT(foo) is valid as $col
3893     return "GROUP_CONCAT($col SEPARATOR $delim)";
3894   } else {
3895     return "array_to_string(array_agg($col), $delim)";
3896   }
3897 }
3898
3899 =item midnight_sql DATE
3900
3901 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3902 on that day in the system timezone, using the default driver name.
3903
3904 =cut
3905
3906 sub midnight_sql {
3907   my $driver = driver_name;
3908   my $expr = shift;
3909   if ( $driver =~ /^mysql/i ) {
3910     "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3911   }
3912   else {
3913     "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3914   }
3915 }
3916
3917 =back
3918
3919 =head1 BUGS
3920
3921 This module should probably be renamed, since much of the functionality is
3922 of general use.  It is not completely unlike Adapter::DBI (see below).
3923
3924 Exported qsearch and qsearchs should be deprecated in favor of method calls
3925 (against an FS::Record object like the old search and searchs that qsearch
3926 and qsearchs were on top of.)
3927
3928 The whole fields / hfields mess should be removed.
3929
3930 The various WHERE clauses should be subroutined.
3931
3932 table string should be deprecated in favor of DBIx::DBSchema::Table.
3933
3934 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
3935 true maps to the database (and WHERE clauses) would also help.
3936
3937 The ut_ methods should ask the dbdef for a default length.
3938
3939 ut_sqltype (like ut_varchar) should all be defined
3940
3941 A fallback check method should be provided which uses the dbdef.
3942
3943 The ut_money method assumes money has two decimal digits.
3944
3945 The Pg money kludge in the new method only strips `$'.
3946
3947 The ut_phonen method only checks US-style phone numbers.
3948
3949 The _quote function should probably use ut_float instead of a regex.
3950
3951 All the subroutines probably should be methods, here or elsewhere.
3952
3953 Probably should borrow/use some dbdef methods where appropriate (like sub
3954 fields)
3955
3956 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3957 or allow it to be set.  Working around it is ugly any way around - DBI should
3958 be fixed.  (only affects RDBMS which return uppercase column names)
3959
3960 ut_zip should take an optional country like ut_phone.
3961
3962 =head1 SEE ALSO
3963
3964 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3965
3966 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
3967
3968 http://poop.sf.net/
3969
3970 =cut
3971
3972 1;