FS/FS/Record.pm

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