FS/FS/Record.pm

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