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