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     #per-import
1807     job                        => $job,
1808     file                       => $file,
1809     #type                       => $type,
1810     format                     => $param->{format},
1811     params                     => { map { $_ => $param->{$_} } @pass_params },
1812     #?
1813     default_csv                => $opt->{default_csv},
1814     postinsert_callback        => $opt->{postinsert_callback},
1815     insert_args_callback       => $opt->{insert_args_callback},
1816   );
1817
1818   if ( $opt->{'batch_namecol'} ) {
1819     $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1820     $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1821   }
1822
1823   my $error = FS::Record::batch_import( \%iopt );
1824
1825   unlink $file;
1826
1827   die "$error\n" if $error;
1828 }
1829
1830 =item batch_import PARAM_HASHREF
1831
1832 Class method for batch imports.  Available params:
1833
1834 =over 4
1835
1836 =item table
1837
1838 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1839
1840 =item formats
1841
1842 =item format_types
1843
1844 =item format_headers
1845
1846 =item format_sep_chars
1847
1848 =item format_fixedlength_formats
1849
1850 =item format_row_callbacks
1851
1852 =item fields - Alternate way to specify import, specifying import fields directly as a listref
1853
1854 =item preinsert_callback
1855
1856 =item postinsert_callback
1857
1858 =item params
1859
1860 =item job
1861
1862 FS::queue object, will be updated with progress
1863
1864 =item file
1865
1866 =item type
1867
1868 csv, xls, fixedlength, xml
1869
1870 =item empty_ok
1871
1872 =back
1873
1874 =cut
1875
1876 use Data::Dumper;
1877 sub batch_import {
1878   my $param = shift;
1879
1880   warn "$me batch_import call with params: \n". Dumper($param)
1881     if $DEBUG;
1882
1883   my $table   = $param->{table};
1884
1885   my $job     = $param->{job};
1886   my $file    = $param->{file};
1887   my $params  = $param->{params} || {};
1888
1889   my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
1890   my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
1891
1892   my( $type, $header, $sep_char,
1893       $fixedlength_format, $xml_format, $asn_format,
1894       $parser_opt, $row_callback, @fields );
1895
1896   my $postinsert_callback = '';
1897   $postinsert_callback = $param->{'postinsert_callback'}
1898           if $param->{'postinsert_callback'};
1899   my $preinsert_callback = '';
1900   $preinsert_callback = $param->{'preinsert_callback'}
1901           if $param->{'preinsert_callback'};
1902   my $insert_args_callback = '';
1903   $insert_args_callback = $param->{'insert_args_callback'}
1904           if $param->{'insert_args_callback'};
1905
1906   if ( $param->{'format'} ) {
1907
1908     my $format  = $param->{'format'};
1909     my $formats = $param->{formats};
1910     die "unknown format $format" unless exists $formats->{ $format };
1911
1912     $type = $param->{'format_types'}
1913             ? $param->{'format_types'}{ $format }
1914             : $param->{type} || 'csv';
1915
1916
1917     $header = $param->{'format_headers'}
1918                ? $param->{'format_headers'}{ $param->{'format'} }
1919                : 0;
1920
1921     $sep_char = $param->{'format_sep_chars'}
1922                   ? $param->{'format_sep_chars'}{ $param->{'format'} }
1923                   : ',';
1924
1925     $fixedlength_format =
1926       $param->{'format_fixedlength_formats'}
1927         ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1928         : '';
1929
1930     $parser_opt =
1931       $param->{'format_parser_opts'}
1932         ? $param->{'format_parser_opts'}{ $param->{'format'} }
1933         : {};
1934
1935     $xml_format =
1936       $param->{'format_xml_formats'}
1937         ? $param->{'format_xml_formats'}{ $param->{'format'} }
1938         : '';
1939
1940     $asn_format =
1941       $param->{'format_asn_formats'}
1942         ? $param->{'format_asn_formats'}{ $param->{'format'} }
1943         : '';
1944
1945     $row_callback =
1946       $param->{'format_row_callbacks'}
1947         ? $param->{'format_row_callbacks'}{ $param->{'format'} }
1948         : '';
1949
1950     @fields = @{ $formats->{ $format } };
1951
1952   } elsif ( $param->{'fields'} ) {
1953
1954     $type = ''; #infer from filename
1955     $header = 0;
1956     $sep_char = ',';
1957     $fixedlength_format = '';
1958     $row_callback = '';
1959     @fields = @{ $param->{'fields'} };
1960
1961   } else {
1962     die "neither format nor fields specified";
1963   }
1964
1965   #my $file    = $param->{file};
1966
1967   unless ( $type ) {
1968     if ( $file =~ /\.(\w+)$/i ) {
1969       $type = lc($1);
1970     } else {
1971       #or error out???
1972       warn "can't parse file type from filename $file; defaulting to CSV";
1973       $type = 'csv';
1974     }
1975     $type = 'csv'
1976       if $param->{'default_csv'} && $type ne 'xls';
1977   }
1978
1979
1980   my $row = 0;
1981   my $count;
1982   my $parser;
1983   my @buffer = ();
1984   my $asn_header_buffer;
1985   if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1986
1987     if ( $type eq 'csv' ) {
1988
1989       $parser_opt->{'binary'} = 1;
1990       $parser_opt->{'sep_char'} = $sep_char if $sep_char;
1991       $parser = Text::CSV_XS->new($parser_opt);
1992
1993     } elsif ( $type eq 'fixedlength' ) {
1994
1995       eval "use Parse::FixedLength;";
1996       die $@ if $@;
1997       $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
1998
1999     } else {
2000       die "Unknown file type $type\n";
2001     }
2002
2003     @buffer = split(/\r?\n/, slurp($file) );
2004     splice(@buffer, 0, ($header || 0) );
2005     $count = scalar(@buffer);
2006
2007   } elsif ( $type eq 'xls' ) {
2008
2009     eval "use Spreadsheet::ParseExcel;";
2010     die $@ if $@;
2011
2012     eval "use DateTime::Format::Excel;";
2013     #for now, just let the error be thrown if it is used, since only CDR
2014     # formats bill_west and troop use it, not other excel-parsing things
2015     #die $@ if $@;
2016
2017     my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
2018
2019     $parser = $excel->{Worksheet}[0]; #first sheet
2020
2021     $count = $parser->{MaxRow} || $parser->{MinRow};
2022     $count++;
2023
2024     $row = $header || 0;
2025
2026   } elsif ( $type eq 'xml' ) {
2027
2028     # FS::pay_batch
2029     eval "use XML::Simple;";
2030     die $@ if $@;
2031     my $xmlrow = $xml_format->{'xmlrow'};
2032     $parser = $xml_format->{'xmlkeys'};
2033     die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
2034     my $data = XML::Simple::XMLin(
2035       $file,
2036       'SuppressEmpty' => '', #sets empty values to ''
2037       'KeepRoot'      => 1,
2038     );
2039     my $rows = $data;
2040     $rows = $rows->{$_} foreach @$xmlrow;
2041     $rows = [ $rows ] if ref($rows) ne 'ARRAY';
2042     $count = @buffer = @$rows;
2043
2044   } elsif ( $type eq 'asn.1' ) {
2045
2046     eval "use Convert::ASN1";
2047     die $@ if $@;
2048
2049     my $asn = Convert::ASN1->new;
2050     $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
2051
2052     $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
2053
2054     my $data = slurp($file);
2055     my $asn_output = $parser->decode( $data )
2056       or return "No ". $asn_format->{'macro'}. " found\n";
2057
2058     $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
2059
2060     my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
2061     $count = @buffer = @$rows;
2062
2063   } else {
2064     die "Unknown file type $type\n";
2065   }
2066
2067   #my $columns;
2068
2069   local $SIG{HUP} = 'IGNORE';
2070   local $SIG{INT} = 'IGNORE';
2071   local $SIG{QUIT} = 'IGNORE';
2072   local $SIG{TERM} = 'IGNORE';
2073   local $SIG{TSTP} = 'IGNORE';
2074   local $SIG{PIPE} = 'IGNORE';
2075
2076   my $oldAutoCommit = $FS::UID::AutoCommit;
2077   local $FS::UID::AutoCommit = 0;
2078   my $dbh = dbh;
2079
2080   #my $params  = $param->{params} || {};
2081   if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
2082     my $batch_col   = $param->{'batch_keycol'};
2083
2084     my $batch_class = 'FS::'. $param->{'batch_table'};
2085     my $batch = $batch_class->new({
2086       $param->{'batch_namecol'} => $param->{'batch_namevalue'}
2087     });
2088     my $error = $batch->insert;
2089     if ( $error ) {
2090       $dbh->rollback if $oldAutoCommit;
2091       return "can't insert batch record: $error";
2092     }
2093     #primary key via dbdef? (so the column names don't have to match)
2094     my $batch_value = $batch->get( $param->{'batch_keycol'} );
2095
2096     $params->{ $batch_col } = $batch_value;
2097   }
2098
2099   #my $job     = $param->{job};
2100   my $line;
2101   my $imported = 0;
2102   my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
2103   while (1) {
2104
2105     my @columns = ();
2106     my %hash = %$params;
2107     if ( $type eq 'csv' ) {
2108
2109       last unless scalar(@buffer);
2110       $line = shift(@buffer);
2111
2112       next if $line =~ /^\s*$/; #skip empty lines
2113
2114       $line = &{$row_callback}($line) if $row_callback;
2115
2116       next if $line =~ /^\s*$/; #skip empty lines
2117
2118       $parser->parse($line) or do {
2119         $dbh->rollback if $oldAutoCommit;
2120         return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
2121       };
2122       @columns = $parser->fields();
2123
2124     } elsif ( $type eq 'fixedlength' ) {
2125
2126       last unless scalar(@buffer);
2127       $line = shift(@buffer);
2128
2129       @columns = $parser->parse($line);
2130
2131     } elsif ( $type eq 'xls' ) {
2132
2133       last if $row > ($parser->{MaxRow} || $parser->{MinRow})
2134            || ! $parser->{Cells}[$row];
2135
2136       my @row = @{ $parser->{Cells}[$row] };
2137       @columns = map $_->{Val}, @row;
2138
2139       #my $z = 'A';
2140       #warn $z++. ": $_\n" for @columns;
2141
2142     } elsif ( $type eq 'xml' ) {
2143
2144       # $parser = [ 'Column0Key', 'Column1Key' ... ]
2145       last unless scalar(@buffer);
2146       my $row = shift @buffer;
2147       @columns = @{ $row }{ @$parser };
2148
2149     } elsif ( $type eq 'asn.1' ) {
2150
2151       last unless scalar(@buffer);
2152       my $row = shift @buffer;
2153       &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2154         if $asn_format->{row_callback};
2155       foreach my $key ( keys %{ $asn_format->{map} } ) {
2156         $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2157       }
2158
2159     } else {
2160       die "Unknown file type $type\n";
2161     }
2162
2163     my @later = ();
2164
2165     foreach my $field ( @fields ) {
2166
2167       my $value = shift @columns;
2168
2169       if ( ref($field) eq 'CODE' ) {
2170         #&{$field}(\%hash, $value);
2171         push @later, $field, $value;
2172       } else {
2173         #??? $hash{$field} = $value if length($value);
2174         $hash{$field} = $value if defined($value) && length($value);
2175       }
2176
2177     }
2178
2179     if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
2180                          && length($1) == $custnum_length ) {
2181       $hash{custnum} = $2;
2182     }
2183
2184     #my $table   = $param->{table};
2185     my $class = "FS::$table";
2186
2187     my $record = $class->new( \%hash );
2188
2189     my $param = {};
2190     while ( scalar(@later) ) {
2191       my $sub = shift @later;
2192       my $data = shift @later;
2193       eval {
2194         &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2195       };
2196       if ( $@ ) {
2197         $dbh->rollback if $oldAutoCommit;
2198         return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2199       }
2200       last if exists( $param->{skiprow} );
2201     }
2202     next if exists( $param->{skiprow} );
2203
2204     if ( $preinsert_callback ) {
2205       my $error = &{$preinsert_callback}($record, $param);
2206       if ( $error ) {
2207         $dbh->rollback if $oldAutoCommit;
2208         return "preinsert_callback error". ( $line ? " for $line" : '' ).
2209                ": $error";
2210       }
2211       next if exists $param->{skiprow} && $param->{skiprow};
2212     }
2213
2214     my @insert_args = ();
2215     if ( $insert_args_callback ) {
2216       @insert_args = &{$insert_args_callback}($record, $param);
2217     }
2218
2219     my $error = $record->insert(@insert_args);
2220
2221     if ( $error ) {
2222       $dbh->rollback if $oldAutoCommit;
2223       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2224     }
2225
2226     $row++;
2227     $imported++;
2228
2229     if ( $postinsert_callback ) {
2230       my $error = &{$postinsert_callback}($record, $param);
2231       if ( $error ) {
2232         $dbh->rollback if $oldAutoCommit;
2233         return "postinsert_callback error". ( $line ? " for $line" : '' ).
2234                ": $error";
2235       }
2236     }
2237
2238     if ( $job && time - $min_sec > $last ) { #progress bar
2239       $job->update_statustext( int(100 * $imported / $count) );
2240       $last = time;
2241     }
2242
2243   }
2244
2245   unless ( $imported || $param->{empty_ok} ) {
2246     $dbh->rollback if $oldAutoCommit;
2247     return "Empty file!";
2248   }
2249
2250   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2251
2252   ''; #no error
2253
2254 }
2255
2256 sub _h_statement {
2257   my( $self, $action, $time ) = @_;
2258
2259   $time ||= time;
2260
2261   my %nohistory = map { $_=>1 } $self->nohistory_fields;
2262
2263   my @fields =
2264     grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2265     real_fields($self->table);
2266   ;
2267
2268   # If we're encrypting then don't store the payinfo in the history
2269   if ( $conf && $conf->exists('encryption') && $self->table ne 'banned_pay' ) {
2270     @fields = grep { $_ ne 'payinfo' } @fields;
2271   }
2272
2273   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2274
2275   "INSERT INTO h_". $self->table. " ( ".
2276       join(', ', qw(history_date history_usernum history_action), @fields ).
2277     ") VALUES (".
2278       join(', ', $time,
2279                  $FS::CurrentUser::CurrentUser->usernum,
2280                  dbh->quote($action),
2281                  @values
2282       ).
2283     ")"
2284   ;
2285 }
2286
2287 =item unique COLUMN
2288
2289 B<Warning>: External use is B<deprecated>.
2290
2291 Replaces COLUMN in record with a unique number, using counters in the
2292 filesystem.  Used by the B<insert> method on single-field unique columns
2293 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2294 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2295
2296 Returns the new value.
2297
2298 =cut
2299
2300 sub unique {
2301   my($self,$field) = @_;
2302   my($table)=$self->table;
2303
2304   croak "Unique called on field $field, but it is ",
2305         $self->getfield($field),
2306         ", not null!"
2307     if $self->getfield($field);
2308
2309   #warn "table $table is tainted" if is_tainted($table);
2310   #warn "field $field is tainted" if is_tainted($field);
2311
2312   my($counter) = new File::CounterFile "$table.$field",0;
2313
2314   my $index = $counter->inc;
2315   $index = $counter->inc while qsearchs($table, { $field=>$index } );
2316
2317   $index =~ /^(\d*)$/;
2318   $index=$1;
2319
2320   $self->setfield($field,$index);
2321
2322 }
2323
2324 =item ut_float COLUMN
2325
2326 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
2327 null.  If there is an error, returns the error, otherwise returns false.
2328
2329 =cut
2330
2331 sub ut_float {
2332   my($self,$field)=@_ ;
2333   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2334    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2335    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2336    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2337     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2338   $self->setfield($field,$1);
2339   '';
2340 }
2341 =item ut_floatn COLUMN
2342
2343 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2344 null.  If there is an error, returns the error, otherwise returns false.
2345
2346 =cut
2347
2348 #false laziness w/ut_ipn
2349 sub ut_floatn {
2350   my( $self, $field ) = @_;
2351   if ( $self->getfield($field) =~ /^()$/ ) {
2352     $self->setfield($field,'');
2353     '';
2354   } else {
2355     $self->ut_float($field);
2356   }
2357 }
2358
2359 =item ut_sfloat COLUMN
2360
2361 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2362 May not be null.  If there is an error, returns the error, otherwise returns
2363 false.
2364
2365 =cut
2366
2367 sub ut_sfloat {
2368   my($self,$field)=@_ ;
2369   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2370    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2371    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2372    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2373     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2374   $self->setfield($field,$1);
2375   '';
2376 }
2377 =item ut_sfloatn COLUMN
2378
2379 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2380 null.  If there is an error, returns the error, otherwise returns false.
2381
2382 =cut
2383
2384 sub ut_sfloatn {
2385   my( $self, $field ) = @_;
2386   if ( $self->getfield($field) =~ /^()$/ ) {
2387     $self->setfield($field,'');
2388     '';
2389   } else {
2390     $self->ut_sfloat($field);
2391   }
2392 }
2393
2394 =item ut_snumber COLUMN
2395
2396 Check/untaint signed numeric data (whole numbers).  If there is an error,
2397 returns the error, otherwise returns false.
2398
2399 =cut
2400
2401 sub ut_snumber {
2402   my($self, $field) = @_;
2403   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2404     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2405   $self->setfield($field, "$1$2");
2406   '';
2407 }
2408
2409 =item ut_snumbern COLUMN
2410
2411 Check/untaint signed numeric data (whole numbers).  If there is an error,
2412 returns the error, otherwise returns false.
2413
2414 =cut
2415
2416 sub ut_snumbern {
2417   my($self, $field) = @_;
2418   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2419     or return "Illegal (numeric) $field: ". $self->getfield($field);
2420   if ($1) {
2421     return "Illegal (numeric) $field: ". $self->getfield($field)
2422       unless $2;
2423   }
2424   $self->setfield($field, "$1$2");
2425   '';
2426 }
2427
2428 =item ut_number COLUMN
2429
2430 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
2431 is an error, returns the error, otherwise returns false.
2432
2433 =cut
2434
2435 sub ut_number {
2436   my($self,$field)=@_;
2437   $self->getfield($field) =~ /^\s*(\d+)\s*$/
2438     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2439   $self->setfield($field,$1);
2440   '';
2441 }
2442
2443 =item ut_numbern COLUMN
2444
2445 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
2446 an error, returns the error, otherwise returns false.
2447
2448 =cut
2449
2450 sub ut_numbern {
2451   my($self,$field)=@_;
2452   $self->getfield($field) =~ /^\s*(\d*)\s*$/
2453     or return "Illegal (numeric) $field: ". $self->getfield($field);
2454   $self->setfield($field,$1);
2455   '';
2456 }
2457
2458 =item ut_decimal COLUMN[, DIGITS]
2459
2460 Check/untaint decimal numbers (up to DIGITS decimal places.  If there is an
2461 error, returns the error, otherwise returns false.
2462
2463 =item ut_decimaln COLUMN[, DIGITS]
2464
2465 Check/untaint decimal numbers.  May be null.  If there is an error, returns
2466 the error, otherwise returns false.
2467
2468 =cut
2469
2470 sub ut_decimal {
2471   my($self, $field, $digits) = @_;
2472   $digits ||= '';
2473   $self->getfield($field) =~ /^\s*(\d+(\.\d{0,$digits})?)\s*$/
2474     or return "Illegal or empty (decimal) $field: ".$self->getfield($field);
2475   $self->setfield($field, $1);
2476   '';
2477 }
2478
2479 sub ut_decimaln {
2480   my($self, $field, $digits) = @_;
2481   $self->getfield($field) =~ /^\s*(\d*(\.\d{0,$digits})?)\s*$/
2482     or return "Illegal (decimal) $field: ".$self->getfield($field);
2483   $self->setfield($field, $1);
2484   '';
2485 }
2486
2487 =item ut_money COLUMN
2488
2489 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
2490 is an error, returns the error, otherwise returns false.
2491
2492 =cut
2493
2494 sub ut_money {
2495   my($self,$field)=@_;
2496
2497   if ( $self->getfield($field) eq '' ) {
2498     $self->setfield($field, 0);
2499   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2500     #handle one decimal place without barfing out
2501     $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2502   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2503     $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2504   } else {
2505     return "Illegal (money) $field: ". $self->getfield($field);
2506   }
2507
2508   '';
2509 }
2510
2511 =item ut_moneyn COLUMN
2512
2513 Check/untaint monetary numbers.  May be negative.  If there
2514 is an error, returns the error, otherwise returns false.
2515
2516 =cut
2517
2518 sub ut_moneyn {
2519   my($self,$field)=@_;
2520   if ($self->getfield($field) eq '') {
2521     $self->setfield($field, '');
2522     return '';
2523   }
2524   $self->ut_money($field);
2525 }
2526
2527 =item ut_currencyn COLUMN
2528
2529 Check/untaint currency indicators, such as USD or EUR.  May be null.  If there
2530 is an error, returns the error, otherwise returns false.
2531
2532 =cut
2533
2534 sub ut_currencyn {
2535   my($self, $field) = @_;
2536   if ($self->getfield($field) eq '') { #can be null
2537     $self->setfield($field, '');
2538     return '';
2539   }
2540   $self->ut_currency($field);
2541 }
2542
2543 =item ut_currency COLUMN
2544
2545 Check/untaint currency indicators, such as USD or EUR.  May not be null.  If
2546 there is an error, returns the error, otherwise returns false.
2547
2548 =cut
2549
2550 sub ut_currency {
2551   my($self, $field) = @_;
2552   my $value = uc( $self->getfield($field) );
2553   if ( code2currency($value) ) {
2554     $self->setfield($value);
2555   } else {
2556     return "Unknown currency $value";
2557   }
2558
2559   '';
2560 }
2561
2562 =item ut_text COLUMN
2563
2564 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2565 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2566 May not be null.  If there is an error, returns the error, otherwise returns
2567 false.
2568
2569 =cut
2570
2571 sub ut_text {
2572   my($self,$field)=@_;
2573   #warn "msgcat ". \&msgcat. "\n";
2574   #warn "notexist ". \&notexist. "\n";
2575   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2576   # \p{Word} = alphanumerics, marks (diacritics), and connectors
2577   # see perldoc perluniprops
2578   $self->getfield($field)
2579     =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
2580       or return gettext('illegal_or_empty_text'). " $field: ".
2581                  $self->getfield($field);
2582   $self->setfield($field,$1);
2583   '';
2584 }
2585
2586 =item ut_textn COLUMN
2587
2588 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2589 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2590 May be null.  If there is an error, returns the error, otherwise returns false.
2591
2592 =cut
2593
2594 sub ut_textn {
2595   my($self,$field)=@_;
2596   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2597   $self->ut_text($field);
2598 }
2599
2600 =item ut_alpha COLUMN
2601
2602 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
2603 an error, returns the error, otherwise returns false.
2604
2605 =cut
2606
2607 sub ut_alpha {
2608   my($self,$field)=@_;
2609   $self->getfield($field) =~ /^(\w+)$/
2610     or return "Illegal or empty (alphanumeric) $field: ".
2611               $self->getfield($field);
2612   $self->setfield($field,$1);
2613   '';
2614 }
2615
2616 =item ut_alphan COLUMN
2617
2618 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
2619 error, returns the error, otherwise returns false.
2620
2621 =cut
2622
2623 sub ut_alphan {
2624   my($self,$field)=@_;
2625   $self->getfield($field) =~ /^(\w*)$/
2626     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2627   $self->setfield($field,$1);
2628   '';
2629 }
2630
2631 =item ut_alphasn COLUMN
2632
2633 Check/untaint alphanumeric strings, spaces allowed.  May be null.  If there is
2634 an error, returns the error, otherwise returns false.
2635
2636 =cut
2637
2638 sub ut_alphasn {
2639   my($self,$field)=@_;
2640   $self->getfield($field) =~ /^([\w ]*)$/
2641     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2642   $self->setfield($field,$1);
2643   '';
2644 }
2645
2646
2647 =item ut_alpha_lower COLUMN
2648
2649 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
2650 there is an error, returns the error, otherwise returns false.
2651
2652 =cut
2653
2654 sub ut_alpha_lower {
2655   my($self,$field)=@_;
2656   $self->getfield($field) =~ /[[:upper:]]/
2657     and return "Uppercase characters are not permitted in $field";
2658   $self->ut_alpha($field);
2659 }
2660
2661 =item ut_phonen COLUMN [ COUNTRY ]
2662
2663 Check/untaint phone numbers.  May be null.  If there is an error, returns
2664 the error, otherwise returns false.
2665
2666 Takes an optional two-letter ISO 3166-1 alpha-2 country code; without
2667 it or with unsupported countries, ut_phonen simply calls ut_alphan.
2668
2669 =cut
2670
2671 sub ut_phonen {
2672   my( $self, $field, $country ) = @_;
2673   return $self->ut_alphan($field) unless defined $country;
2674   my $phonen = $self->getfield($field);
2675   if ( $phonen eq '' ) {
2676     $self->setfield($field,'');
2677   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2678     $phonen =~ s/\D//g;
2679     $phonen = $conf->config('cust_main-default_areacode').$phonen
2680       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2681     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2682       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2683     $phonen = "$1-$2-$3";
2684     $phonen .= " x$4" if $4;
2685     $self->setfield($field,$phonen);
2686   } else {
2687     warn "warning: don't know how to check phone numbers for country $country";
2688     return $self->ut_textn($field);
2689   }
2690   '';
2691 }
2692
2693 =item ut_hex COLUMN
2694
2695 Check/untaint hexadecimal values.
2696
2697 =cut
2698
2699 sub ut_hex {
2700   my($self, $field) = @_;
2701   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2702     or return "Illegal (hex) $field: ". $self->getfield($field);
2703   $self->setfield($field, uc($1));
2704   '';
2705 }
2706
2707 =item ut_hexn COLUMN
2708
2709 Check/untaint hexadecimal values.  May be null.
2710
2711 =cut
2712
2713 sub ut_hexn {
2714   my($self, $field) = @_;
2715   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2716     or return "Illegal (hex) $field: ". $self->getfield($field);
2717   $self->setfield($field, uc($1));
2718   '';
2719 }
2720
2721 =item ut_mac_addr COLUMN
2722
2723 Check/untaint mac addresses.  May be null.
2724
2725 =cut
2726
2727 sub ut_mac_addr {
2728   my($self, $field) = @_;
2729
2730   my $mac = $self->get($field);
2731   $mac =~ s/\s+//g;
2732   $mac =~ s/://g;
2733   $self->set($field, $mac);
2734
2735   my $e = $self->ut_hex($field);
2736   return $e if $e;
2737
2738   return "Illegal (mac address) $field: ". $self->getfield($field)
2739     unless length($self->getfield($field)) == 12;
2740
2741   '';
2742
2743 }
2744
2745 =item ut_mac_addrn COLUMN
2746
2747 Check/untaint mac addresses.  May be null.
2748
2749 =cut
2750
2751 sub ut_mac_addrn {
2752   my($self, $field) = @_;
2753   ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2754 }
2755
2756 =item ut_ip COLUMN
2757
2758 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2759 to 127.0.0.1.
2760
2761 =cut
2762
2763 sub ut_ip {
2764   my( $self, $field ) = @_;
2765   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2766   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2767     or return "Illegal (IP address) $field: ". $self->getfield($field);
2768   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2769   $self->setfield($field, "$1.$2.$3.$4");
2770   '';
2771 }
2772
2773 =item ut_ipn COLUMN
2774
2775 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2776 to 127.0.0.1.  May be null.
2777
2778 =cut
2779
2780 sub ut_ipn {
2781   my( $self, $field ) = @_;
2782   if ( $self->getfield($field) =~ /^()$/ ) {
2783     $self->setfield($field,'');
2784     '';
2785   } else {
2786     $self->ut_ip($field);
2787   }
2788 }
2789
2790 =item ut_ip46 COLUMN
2791
2792 Check/untaint IPv4 or IPv6 address.
2793
2794 =cut
2795
2796 sub ut_ip46 {
2797   my( $self, $field ) = @_;
2798   my $ip = NetAddr::IP->new($self->getfield($field))
2799     or return "Illegal (IP address) $field: ".$self->getfield($field);
2800   $self->setfield($field, lc($ip->addr));
2801   return '';
2802 }
2803
2804 =item ut_ip46n
2805
2806 Check/untaint IPv6 or IPv6 address.  May be null.
2807
2808 =cut
2809
2810 sub ut_ip46n {
2811   my( $self, $field ) = @_;
2812   if ( $self->getfield($field) =~ /^$/ ) {
2813     $self->setfield($field, '');
2814     return '';
2815   }
2816   $self->ut_ip46($field);
2817 }
2818
2819 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2820
2821 Check/untaint coordinates.
2822 Accepts the following forms:
2823 DDD.DDDDD
2824 -DDD.DDDDD
2825 DDD MM.MMM
2826 -DDD MM.MMM
2827 DDD MM SS
2828 -DDD MM SS
2829 DDD MM MMM
2830 -DDD MM MMM
2831
2832 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2833 The latter form (that is, the MMM are thousands of minutes) is
2834 assumed if the "MMM" is exactly three digits or two digits > 59.
2835
2836 To be safe, just use the DDD.DDDDD form.
2837
2838 If LOWER or UPPER are specified, then the coordinate is checked
2839 for lower and upper bounds, respectively.
2840
2841 =cut
2842
2843 sub ut_coord {
2844   my ($self, $field) = (shift, shift);
2845
2846   my($lower, $upper);
2847   if ( $field =~ /latitude/ ) {
2848     $lower = $lat_lower;
2849     $upper = 90;
2850   } elsif ( $field =~ /longitude/ ) {
2851     $lower = -180;
2852     $upper = $lon_upper;
2853   }
2854
2855   my $coord = $self->getfield($field);
2856   my $neg = $coord =~ s/^(-)//;
2857
2858   my ($d, $m, $s) = (0, 0, 0);
2859
2860   if (
2861     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2862     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2863     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2864   ) {
2865     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2866     $m = $m / 60;
2867     if ($m > 59) {
2868       return "Invalid (coordinate with minutes > 59) $field: "
2869              . $self->getfield($field);
2870     }
2871
2872     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2873
2874     if (defined($lower) and ($coord < $lower)) {
2875       return "Invalid (coordinate < $lower) $field: "
2876              . $self->getfield($field);;
2877     }
2878
2879     if (defined($upper) and ($coord > $upper)) {
2880       return "Invalid (coordinate > $upper) $field: "
2881              . $self->getfield($field);;
2882     }
2883
2884     $self->setfield($field, $coord);
2885     return '';
2886   }
2887
2888   return "Invalid (coordinate) $field: " . $self->getfield($field);
2889
2890 }
2891
2892 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2893
2894 Same as ut_coord, except optionally null.
2895
2896 =cut
2897
2898 sub ut_coordn {
2899
2900   my ($self, $field) = (shift, shift);
2901
2902   if ($self->getfield($field) =~ /^\s*$/) {
2903     return '';
2904   } else {
2905     return $self->ut_coord($field, @_);
2906   }
2907
2908 }
2909
2910 =item ut_domain COLUMN
2911
2912 Check/untaint host and domain names.  May not be null.
2913
2914 =cut
2915
2916 sub ut_domain {
2917   my( $self, $field ) = @_;
2918   #$self->getfield($field) =~/^(\w+\.)*\w+$/
2919   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2920     or return "Illegal (hostname) $field: ". $self->getfield($field);
2921   $self->setfield($field,$1);
2922   '';
2923 }
2924
2925 =item ut_domainn COLUMN
2926
2927 Check/untaint host and domain names.  May be null.
2928
2929 =cut
2930
2931 sub ut_domainn {
2932   my( $self, $field ) = @_;
2933   if ( $self->getfield($field) =~ /^()$/ ) {
2934     $self->setfield($field,'');
2935     '';
2936   } else {
2937     $self->ut_domain($field);
2938   }
2939 }
2940
2941 =item ut_name COLUMN
2942
2943 Check/untaint proper names; allows alphanumerics, spaces and the following
2944 punctuation: , . - '
2945
2946 May not be null.
2947
2948 =cut
2949
2950 sub ut_name {
2951   my( $self, $field ) = @_;
2952 #  warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
2953   $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
2954     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2955   my $name = $1;
2956   $name =~ s/^\s+//;
2957   $name =~ s/\s+$//;
2958   $name =~ s/\s+/ /g;
2959   $self->setfield($field, $name);
2960   '';
2961 }
2962
2963 =item ut_namen COLUMN
2964
2965 Check/untaint proper names; allows alphanumerics, spaces and the following
2966 punctuation: , . - '
2967
2968 May not be null.
2969
2970 =cut
2971
2972 sub ut_namen {
2973   my( $self, $field ) = @_;
2974   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2975   $self->ut_name($field);
2976 }
2977
2978 =item ut_zip COLUMN
2979
2980 Check/untaint zip codes.
2981
2982 =cut
2983
2984 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2985
2986 sub ut_zip {
2987   my( $self, $field, $country ) = @_;
2988
2989   if ( $country eq 'US' ) {
2990
2991     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2992       or return gettext('illegal_zip'). " $field for country $country: ".
2993                 $self->getfield($field);
2994     $self->setfield($field, $1);
2995
2996   } elsif ( $country eq 'CA' ) {
2997
2998     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2999       or return gettext('illegal_zip'). " $field for country $country: ".
3000                 $self->getfield($field);
3001     $self->setfield($field, "$1 $2");
3002
3003   } else {
3004
3005     if ( $self->getfield($field) =~ /^\s*$/
3006          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
3007        )
3008     {
3009       $self->setfield($field,'');
3010     } else {
3011       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
3012         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
3013       $self->setfield($field,$1);
3014     }
3015
3016   }
3017
3018   '';
3019 }
3020
3021 =item ut_country COLUMN
3022
3023 Check/untaint country codes.  Country names are changed to codes, if possible -
3024 see L<Locale::Country>.
3025
3026 =cut
3027
3028 sub ut_country {
3029   my( $self, $field ) = @_;
3030   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
3031     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
3032          && country2code($1) ) {
3033       $self->setfield($field,uc(country2code($1)));
3034     }
3035   }
3036   $self->getfield($field) =~ /^(\w\w)$/
3037     or return "Illegal (country) $field: ". $self->getfield($field);
3038   $self->setfield($field,uc($1));
3039   '';
3040 }
3041
3042 =item ut_anything COLUMN
3043
3044 Untaints arbitrary data.  Be careful.
3045
3046 =cut
3047
3048 sub ut_anything {
3049   my( $self, $field ) = @_;
3050   $self->getfield($field) =~ /^(.*)$/s
3051     or return "Illegal $field: ". $self->getfield($field);
3052   $self->setfield($field,$1);
3053   '';
3054 }
3055
3056 =item ut_enum COLUMN CHOICES_ARRAYREF
3057
3058 Check/untaint a column, supplying all possible choices, like the "enum" type.
3059
3060 =cut
3061
3062 sub ut_enum {
3063   my( $self, $field, $choices ) = @_;
3064   foreach my $choice ( @$choices ) {
3065     if ( $self->getfield($field) eq $choice ) {
3066       $self->setfield($field, $choice);
3067       return '';
3068     }
3069   }
3070   return "Illegal (enum) field $field: ". $self->getfield($field);
3071 }
3072
3073 =item ut_enumn COLUMN CHOICES_ARRAYREF
3074
3075 Like ut_enum, except the null value is also allowed.
3076
3077 =cut
3078
3079 sub ut_enumn {
3080   my( $self, $field, $choices ) = @_;
3081   $self->getfield($field)
3082     ? $self->ut_enum($field, $choices)
3083     : '';
3084 }
3085
3086 =item ut_flag COLUMN
3087
3088 Check/untaint a column if it contains either an empty string or 'Y'.  This
3089 is the standard form for boolean flags in Freeside.
3090
3091 =cut
3092
3093 sub ut_flag {
3094   my( $self, $field ) = @_;
3095   my $value = uc($self->getfield($field));
3096   if ( $value eq '' or $value eq 'Y' ) {
3097     $self->setfield($field, $value);
3098     return '';
3099   }
3100   return "Illegal (flag) field $field: $value";
3101 }
3102
3103 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3104
3105 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
3106 on the column first.
3107
3108 =cut
3109
3110 sub ut_foreign_key {
3111   my( $self, $field, $table, $foreign ) = @_;
3112   return $self->ut_number($field) if $no_check_foreign;
3113   qsearchs($table, { $foreign => $self->getfield($field) })
3114     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
3115               " in $table.$foreign";
3116   '';
3117 }
3118
3119 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3120
3121 Like ut_foreign_key, except the null value is also allowed.
3122
3123 =cut
3124
3125 sub ut_foreign_keyn {
3126   my( $self, $field, $table, $foreign ) = @_;
3127   $self->getfield($field)
3128     ? $self->ut_foreign_key($field, $table, $foreign)
3129     : '';
3130 }
3131
3132 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
3133
3134 Checks this column as an agentnum, taking into account the current users's
3135 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
3136 right or rights allowing no agentnum.
3137
3138 =cut
3139
3140 sub ut_agentnum_acl {
3141   my( $self, $field ) = (shift, shift);
3142   my $null_acl = scalar(@_) ? shift : [];
3143   $null_acl = [ $null_acl ] unless ref($null_acl);
3144
3145   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
3146   return "Illegal agentnum: $error" if $error;
3147
3148   my $curuser = $FS::CurrentUser::CurrentUser;
3149
3150   if ( $self->$field() ) {
3151
3152     return 'Access denied to agent '. $self->$field()
3153       unless $curuser->agentnum($self->$field());
3154
3155   } else {
3156
3157     return 'Access denied to global'
3158       unless grep $curuser->access_right($_), @$null_acl;
3159
3160   }
3161
3162   '';
3163
3164 }
3165
3166 =item fields [ TABLE ]
3167
3168 This is a wrapper for real_fields.  Code that called
3169 fields before should probably continue to call fields.
3170
3171 =cut
3172
3173 sub fields {
3174   my $something = shift;
3175   my $table;
3176   if($something->isa('FS::Record')) {
3177     $table = $something->table;
3178   } else {
3179     $table = $something;
3180     #$something = "FS::$table";
3181   }
3182   return (real_fields($table));
3183 }
3184
3185
3186 =item encrypt($value)
3187
3188 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
3189
3190 Returns the encrypted string.
3191
3192 You should generally not have to worry about calling this, as the system handles this for you.
3193
3194 =cut
3195
3196 sub encrypt {
3197   my ($self, $value) = @_;
3198   my $encrypted = $value;
3199
3200   if ($conf->exists('encryption')) {
3201     if ($self->is_encrypted($value)) {
3202       # Return the original value if it isn't plaintext.
3203       $encrypted = $value;
3204     } else {
3205       $self->loadRSA;
3206       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
3207         # RSA doesn't like the empty string so let's pack it up
3208         # The database doesn't like the RSA data so uuencode it
3209         my $length = length($value)+1;
3210         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
3211       } else {
3212         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
3213       }
3214     }
3215   }
3216   return $encrypted;
3217 }
3218
3219 =item is_encrypted($value)
3220
3221 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
3222
3223 =cut
3224
3225
3226 sub is_encrypted {
3227   my ($self, $value) = @_;
3228   # could be more precise about it, but this will do for now
3229   $value =~ /^M/ && length($value) > 80;
3230 }
3231
3232 =item decrypt($value)
3233
3234 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
3235
3236 You should generally not have to worry about calling this, as the system handles this for you.
3237
3238 =cut
3239
3240 sub decrypt {
3241   my ($self,$value) = @_;
3242   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
3243   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
3244     $self->loadRSA;
3245     if (ref($rsa_decrypt) =~ /::RSA/) {
3246       my $encrypted = unpack ("u*", $value);
3247       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
3248       if ($@) {warn "Decryption Failed"};
3249     }
3250   }
3251   return $decrypted;
3252 }
3253
3254 sub loadRSA {
3255     my $self = shift;
3256     #Initialize the Module
3257     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
3258
3259     if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
3260       $rsa_module = $conf->config('encryptionmodule');
3261     }
3262
3263     if (!$rsa_loaded) {
3264         eval ("require $rsa_module"); # No need to import the namespace
3265         $rsa_loaded++;
3266     }
3267     # Initialize Encryption
3268     if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
3269       my $public_key = join("\n",$conf->config('encryptionpublickey'));
3270       $rsa_encrypt = $rsa_module->new_public_key($public_key);
3271     }
3272
3273     # Intitalize Decryption
3274     if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
3275       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
3276       $rsa_decrypt = $rsa_module->new_private_key($private_key);
3277     }
3278 }
3279
3280 =item h_search ACTION
3281
3282 Given an ACTION, either "insert", or "delete", returns the appropriate history
3283 record corresponding to this record, if any.
3284
3285 =cut
3286
3287 sub h_search {
3288   my( $self, $action ) = @_;
3289
3290   my $table = $self->table;
3291   $table =~ s/^h_//;
3292
3293   my $primary_key = dbdef->table($table)->primary_key;
3294
3295   qsearchs({
3296     'table'   => "h_$table",
3297     'hashref' => { $primary_key     => $self->$primary_key(),
3298                    'history_action' => $action,
3299                  },
3300   });
3301
3302 }
3303
3304 =item h_date ACTION
3305
3306 Given an ACTION, either "insert", or "delete", returns the timestamp of the
3307 appropriate history record corresponding to this record, if any.
3308
3309 =cut
3310
3311 sub h_date {
3312   my($self, $action) = @_;
3313   my $h = $self->h_search($action);
3314   $h ? $h->history_date : '';
3315 }
3316
3317 =item scalar_sql SQL [ PLACEHOLDER, ... ]
3318
3319 A class or object method.  Executes the sql statement represented by SQL and
3320 returns a scalar representing the result: the first column of the first row.
3321
3322 Dies on bogus SQL.  Returns an empty string if no row is returned.
3323
3324 Typically used for statments which return a single value such as "SELECT
3325 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
3326
3327 =cut
3328
3329 sub scalar_sql {
3330   my($self, $sql) = (shift, shift);
3331   my $sth = dbh->prepare($sql) or die dbh->errstr;
3332   $sth->execute(@_)
3333     or die "Unexpected error executing statement $sql: ". $sth->errstr;
3334   my $row = $sth->fetchrow_arrayref or return '';
3335   my $scalar = $row->[0];
3336   defined($scalar) ? $scalar : '';
3337 }
3338
3339 =item count [ WHERE [, PLACEHOLDER ...] ]
3340
3341 Convenience method for the common case of "SELECT COUNT(*) FROM table",
3342 with optional WHERE.  Must be called as method on a class with an
3343 associated table.
3344
3345 =cut
3346
3347 sub count {
3348   my($self, $where) = (shift, shift);
3349   my $table = $self->table or die 'count called on object of class '.ref($self);
3350   my $sql = "SELECT COUNT(*) FROM $table";
3351   $sql .= " WHERE $where" if $where;
3352   $self->scalar_sql($sql, @_);
3353 }
3354
3355 =item row_exists [ WHERE [, PLACEHOLDER ...] ]
3356
3357 Convenience method for the common case of "SELECT 1 FROM table ... LIMIT 1"
3358 with optional (but almost always needed) WHERE.
3359
3360 =cut
3361
3362 sub row_exists {
3363   my($self, $where) = (shift, shift);
3364   my $table = $self->table or die 'row_exists called on object of class '.ref($self);
3365   my $sql = "SELECT 1 FROM $table";
3366   $sql .= " WHERE $where" if $where;
3367   $sql .= " LIMIT 1";
3368   $self->scalar_sql($sql, @_);
3369 }
3370
3371 =back
3372
3373 =head1 SUBROUTINES
3374
3375 =over 4
3376
3377 =item real_fields [ TABLE ]
3378
3379 Returns a list of the real columns in the specified table.  Called only by
3380 fields() and other subroutines elsewhere in FS::Record.
3381
3382 =cut
3383
3384 sub real_fields {
3385   my $table = shift;
3386
3387   my($table_obj) = dbdef->table($table);
3388   confess "Unknown table $table" unless $table_obj;
3389   $table_obj->columns;
3390 }
3391
3392 =item pvf FIELD_NAME
3393
3394 Returns the FS::part_virtual_field object corresponding to a field in the
3395 record (specified by FIELD_NAME).
3396
3397 =cut
3398
3399 sub pvf {
3400   my ($self, $name) = (shift, shift);
3401
3402   if(grep /^$name$/, $self->virtual_fields) {
3403     $name =~ s/^cf_//;
3404     my $concat = [ "'cf_'", "name" ];
3405     return qsearchs({   table   =>  'part_virtual_field',
3406                         hashref =>  { dbtable => $self->table,
3407                                       name    => $name
3408                                     },
3409                         select  =>  'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
3410                     });
3411   }
3412   ''
3413 }
3414
3415 =item _quote VALUE, TABLE, COLUMN
3416
3417 This is an internal function used to construct SQL statements.  It returns
3418 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3419 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3420
3421 =cut
3422
3423 sub _quote {
3424   my($value, $table, $column) = @_;
3425   my $column_obj = dbdef->table($table)->column($column);
3426   my $column_type = $column_obj->type;
3427   my $nullable = $column_obj->null;
3428
3429   utf8::upgrade($value);
3430
3431   warn "  $table.$column: $value ($column_type".
3432        ( $nullable ? ' NULL' : ' NOT NULL' ).
3433        ")\n" if $DEBUG > 2;
3434
3435   if ( $value eq '' && $nullable ) {
3436     'NULL';
3437   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3438     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3439           "using 0 instead";
3440     0;
3441   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3442             ! $column_type =~ /(char|binary|text)$/i ) {
3443     $value;
3444   } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3445            && driver_name eq 'Pg'
3446           )
3447   {
3448     no strict 'subs';
3449 #    dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right
3450     # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\,
3451     # single-quote the whole mess, and put an "E" in front.
3452     return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'");
3453   } else {
3454     dbh->quote($value);
3455   }
3456 }
3457
3458 =item hfields TABLE
3459
3460 This is deprecated.  Don't use it.
3461
3462 It returns a hash-type list with the fields of this record's table set true.
3463
3464 =cut
3465
3466 sub hfields {
3467   carp "warning: hfields is deprecated";
3468   my($table)=@_;
3469   my(%hash);
3470   foreach (fields($table)) {
3471     $hash{$_}=1;
3472   }
3473   \%hash;
3474 }
3475
3476 sub _dump {
3477   my($self)=@_;
3478   join("\n", map {
3479     "$_: ". $self->getfield($_). "|"
3480   } (fields($self->table)) );
3481 }
3482
3483 sub DESTROY { return; }
3484
3485 #sub DESTROY {
3486 #  my $self = shift;
3487 #  #use Carp qw(cluck);
3488 #  #cluck "DESTROYING $self";
3489 #  warn "DESTROYING $self";
3490 #}
3491
3492 #sub is_tainted {
3493 #             return ! eval { join('',@_), kill 0; 1; };
3494 #         }
3495
3496 =item str2time_sql [ DRIVER_NAME ]
3497
3498 Returns a function to convert to unix time based on database type, such as
3499 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
3500 the str2time_sql_closing method to return a closing string rather than just
3501 using a closing parenthesis as previously suggested.
3502
3503 You can pass an optional driver name such as "Pg", "mysql" or
3504 $dbh->{Driver}->{Name} to return a function for that database instead of
3505 the current database.
3506
3507 =cut
3508
3509 sub str2time_sql {
3510   my $driver = shift || driver_name;
3511
3512   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
3513   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3514
3515   warn "warning: unknown database type $driver; guessing how to convert ".
3516        "dates to UNIX timestamps";
3517   return 'EXTRACT(EPOCH FROM ';
3518
3519 }
3520
3521 =item str2time_sql_closing [ DRIVER_NAME ]
3522
3523 Returns the closing suffix of a function to convert to unix time based on
3524 database type, such as ")::integer" for Pg or ")" for mysql.
3525
3526 You can pass an optional driver name such as "Pg", "mysql" or
3527 $dbh->{Driver}->{Name} to return a function for that database instead of
3528 the current database.
3529
3530 =cut
3531
3532 sub str2time_sql_closing {
3533   my $driver = shift || driver_name;
3534
3535   return ' )::INTEGER ' if $driver =~ /^Pg/i;
3536   return ' ) ';
3537 }
3538
3539 =item regexp_sql [ DRIVER_NAME ]
3540
3541 Returns the operator to do a regular expression comparison based on database
3542 type, such as '~' for Pg or 'REGEXP' for mysql.
3543
3544 You can pass an optional driver name such as "Pg", "mysql" or
3545 $dbh->{Driver}->{Name} to return a function for that database instead of
3546 the current database.
3547
3548 =cut
3549
3550 sub regexp_sql {
3551   my $driver = shift || driver_name;
3552
3553   return '~'      if $driver =~ /^Pg/i;
3554   return 'REGEXP' if $driver =~ /^mysql/i;
3555
3556   die "don't know how to use regular expressions in ". driver_name." databases";
3557
3558 }
3559
3560 =item not_regexp_sql [ DRIVER_NAME ]
3561
3562 Returns the operator to do a regular expression negation based on database
3563 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3564
3565 You can pass an optional driver name such as "Pg", "mysql" or
3566 $dbh->{Driver}->{Name} to return a function for that database instead of
3567 the current database.
3568
3569 =cut
3570
3571 sub not_regexp_sql {
3572   my $driver = shift || driver_name;
3573
3574   return '!~'         if $driver =~ /^Pg/i;
3575   return 'NOT REGEXP' if $driver =~ /^mysql/i;
3576
3577   die "don't know how to use regular expressions in ". driver_name." databases";
3578
3579 }
3580
3581 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3582
3583 Returns the items concatenated based on database type, using "CONCAT()" for
3584 mysql and " || " for Pg and other databases.
3585
3586 You can pass an optional driver name such as "Pg", "mysql" or
3587 $dbh->{Driver}->{Name} to return a function for that database instead of
3588 the current database.
3589
3590 =cut
3591
3592 sub concat_sql {
3593   my $driver = ref($_[0]) ? driver_name : shift;
3594   my $items = shift;
3595
3596   if ( $driver =~ /^mysql/i ) {
3597     'CONCAT('. join(',', @$items). ')';
3598   } else {
3599     join('||', @$items);
3600   }
3601
3602 }
3603
3604 =item group_concat_sql COLUMN, DELIMITER
3605
3606 Returns an SQL expression to concatenate an aggregate column, using
3607 GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg.
3608
3609 =cut
3610
3611 sub group_concat_sql {
3612   my ($col, $delim) = @_;
3613   $delim = dbh->quote($delim);
3614   if ( driver_name() =~ /^mysql/i ) {
3615     # DISTINCT(foo) is valid as $col
3616     return "GROUP_CONCAT($col SEPARATOR $delim)";
3617   } else {
3618     return "array_to_string(array_agg($col), $delim)";
3619   }
3620 }
3621
3622 =item midnight_sql DATE
3623
3624 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3625 on that day in the system timezone, using the default driver name.
3626
3627 =cut
3628
3629 sub midnight_sql {
3630   my $driver = driver_name;
3631   my $expr = shift;
3632   if ( $driver =~ /^mysql/i ) {
3633     "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3634   }
3635   else {
3636     "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3637   }
3638 }
3639
3640 =back
3641
3642 =head1 BUGS
3643
3644 This module should probably be renamed, since much of the functionality is
3645 of general use.  It is not completely unlike Adapter::DBI (see below).
3646
3647 Exported qsearch and qsearchs should be deprecated in favor of method calls
3648 (against an FS::Record object like the old search and searchs that qsearch
3649 and qsearchs were on top of.)
3650
3651 The whole fields / hfields mess should be removed.
3652
3653 The various WHERE clauses should be subroutined.
3654
3655 table string should be deprecated in favor of DBIx::DBSchema::Table.
3656
3657 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
3658 true maps to the database (and WHERE clauses) would also help.
3659
3660 The ut_ methods should ask the dbdef for a default length.
3661
3662 ut_sqltype (like ut_varchar) should all be defined
3663
3664 A fallback check method should be provided which uses the dbdef.
3665
3666 The ut_money method assumes money has two decimal digits.
3667
3668 The Pg money kludge in the new method only strips `$'.
3669
3670 The ut_phonen method only checks US-style phone numbers.
3671
3672 The _quote function should probably use ut_float instead of a regex.
3673
3674 All the subroutines probably should be methods, here or elsewhere.
3675
3676 Probably should borrow/use some dbdef methods where appropriate (like sub
3677 fields)
3678
3679 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3680 or allow it to be set.  Working around it is ugly any way around - DBI should
3681 be fixed.  (only affects RDBMS which return uppercase column names)
3682
3683 ut_zip should take an optional country like ut_phone.
3684
3685 =head1 SEE ALSO
3686
3687 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3688
3689 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
3690
3691 http://poop.sf.net/
3692
3693 =cut
3694
3695 1;
3696