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