FS/FS/Record.pm

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