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