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