FS/FS/Record.pm

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