FS/FS/Record.pm

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