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