FS/FS/Record.pm

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