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