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