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
2221 =item ut_mac_addr COLUMN
2222
2223 Check/untaint mac addresses.  May be null.
2224
2225 =cut
2226
2227 sub ut_mac_addr {
2228   my($self, $field) = @_;
2229
2230   my $mac = $self->get($field);
2231   $mac =~ s/\s+//g;
2232   $mac =~ s/://g;
2233   $self->set($field, $mac);
2234
2235   my $e = $self->ut_hex($field);
2236   return $e if $e;
2237
2238   return "Illegal (mac address) $field: ". $self->getfield($field)
2239     unless length($self->getfield($field)) == 12;
2240
2241   '';
2242
2243 }
2244
2245 =item ut_mac_addrn COLUMN
2246
2247 Check/untaint mac addresses.  May be null.
2248
2249 =cut
2250
2251 sub ut_mac_addrn {
2252   my($self, $field) = @_;
2253   ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2254 }
2255
2256 =item ut_ip COLUMN
2257
2258 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2259 to 127.0.0.1.
2260
2261 =cut
2262
2263 sub ut_ip {
2264   my( $self, $field ) = @_;
2265   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2266   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2267     or return "Illegal (IP address) $field: ". $self->getfield($field);
2268   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2269   $self->setfield($field, "$1.$2.$3.$4");
2270   '';
2271 }
2272
2273 =item ut_ipn COLUMN
2274
2275 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2276 to 127.0.0.1.  May be null.
2277
2278 =cut
2279
2280 sub ut_ipn {
2281   my( $self, $field ) = @_;
2282   if ( $self->getfield($field) =~ /^()$/ ) {
2283     $self->setfield($field,'');
2284     '';
2285   } else {
2286     $self->ut_ip($field);
2287   }
2288 }
2289
2290 =item ut_ip46 COLUMN
2291
2292 Check/untaint IPv4 or IPv6 address.
2293
2294 =cut
2295
2296 sub ut_ip46 {
2297   my( $self, $field ) = @_;
2298   my $ip = NetAddr::IP->new($self->getfield($field))
2299     or return "Illegal (IP address) $field: ".$self->getfield($field);
2300   $self->setfield($field, lc($ip->addr));
2301   return '';
2302 }
2303
2304 =item ut_ip46n
2305
2306 Check/untaint IPv6 or IPv6 address.  May be null.
2307
2308 =cut
2309
2310 sub ut_ip46n {
2311   my( $self, $field ) = @_;
2312   if ( $self->getfield($field) =~ /^$/ ) {
2313     $self->setfield($field, '');
2314     return '';
2315   }
2316   $self->ut_ip46($field);
2317 }
2318
2319 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2320
2321 Check/untaint coordinates.
2322 Accepts the following forms:
2323 DDD.DDDDD
2324 -DDD.DDDDD
2325 DDD MM.MMM
2326 -DDD MM.MMM
2327 DDD MM SS
2328 -DDD MM SS
2329 DDD MM MMM
2330 -DDD MM MMM
2331
2332 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2333 The latter form (that is, the MMM are thousands of minutes) is
2334 assumed if the "MMM" is exactly three digits or two digits > 59.
2335
2336 To be safe, just use the DDD.DDDDD form.
2337
2338 If LOWER or UPPER are specified, then the coordinate is checked
2339 for lower and upper bounds, respectively.
2340
2341 =cut
2342
2343 sub ut_coord {
2344
2345   my ($self, $field) = (shift, shift);
2346
2347   my $lower = shift if scalar(@_);
2348   my $upper = shift if scalar(@_);
2349   my $coord = $self->getfield($field);
2350   my $neg = $coord =~ s/^(-)//;
2351
2352   my ($d, $m, $s) = (0, 0, 0);
2353
2354   if (
2355     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2356     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2357     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2358   ) {
2359     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2360     $m = $m / 60;
2361     if ($m > 59) {
2362       return "Invalid (coordinate with minutes > 59) $field: "
2363              . $self->getfield($field);
2364     }
2365
2366     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2367
2368     if (defined($lower) and ($coord < $lower)) {
2369       return "Invalid (coordinate < $lower) $field: "
2370              . $self->getfield($field);;
2371     }
2372
2373     if (defined($upper) and ($coord > $upper)) {
2374       return "Invalid (coordinate > $upper) $field: "
2375              . $self->getfield($field);;
2376     }
2377
2378     $self->setfield($field, $coord);
2379     return '';
2380   }
2381
2382   return "Invalid (coordinate) $field: " . $self->getfield($field);
2383
2384 }
2385
2386 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2387
2388 Same as ut_coord, except optionally null.
2389
2390 =cut
2391
2392 sub ut_coordn {
2393
2394   my ($self, $field) = (shift, shift);
2395
2396   if ($self->getfield($field) =~ /^$/) {
2397     return '';
2398   } else {
2399     return $self->ut_coord($field, @_);
2400   }
2401
2402 }
2403
2404
2405 =item ut_domain COLUMN
2406
2407 Check/untaint host and domain names.
2408
2409 =cut
2410
2411 sub ut_domain {
2412   my( $self, $field ) = @_;
2413   #$self->getfield($field) =~/^(\w+\.)*\w+$/
2414   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2415     or return "Illegal (domain) $field: ". $self->getfield($field);
2416   $self->setfield($field,$1);
2417   '';
2418 }
2419
2420 =item ut_name COLUMN
2421
2422 Check/untaint proper names; allows alphanumerics, spaces and the following
2423 punctuation: , . - '
2424
2425 May not be null.
2426
2427 =cut
2428
2429 sub ut_name {
2430   my( $self, $field ) = @_;
2431 #  warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
2432   $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
2433     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2434   $self->setfield($field,$1);
2435   '';
2436 }
2437
2438 =item ut_zip COLUMN
2439
2440 Check/untaint zip codes.
2441
2442 =cut
2443
2444 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2445
2446 sub ut_zip {
2447   my( $self, $field, $country ) = @_;
2448
2449   if ( $country eq 'US' ) {
2450
2451     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2452       or return gettext('illegal_zip'). " $field for country $country: ".
2453                 $self->getfield($field);
2454     $self->setfield($field, $1);
2455
2456   } elsif ( $country eq 'CA' ) {
2457
2458     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2459       or return gettext('illegal_zip'). " $field for country $country: ".
2460                 $self->getfield($field);
2461     $self->setfield($field, "$1 $2");
2462
2463   } else {
2464
2465     if ( $self->getfield($field) =~ /^\s*$/
2466          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2467        )
2468     {
2469       $self->setfield($field,'');
2470     } else {
2471       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
2472         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2473       $self->setfield($field,$1);
2474     }
2475
2476   }
2477
2478   '';
2479 }
2480
2481 =item ut_country COLUMN
2482
2483 Check/untaint country codes.  Country names are changed to codes, if possible -
2484 see L<Locale::Country>.
2485
2486 =cut
2487
2488 sub ut_country {
2489   my( $self, $field ) = @_;
2490   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2491     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2492          && country2code($1) ) {
2493       $self->setfield($field,uc(country2code($1)));
2494     }
2495   }
2496   $self->getfield($field) =~ /^(\w\w)$/
2497     or return "Illegal (country) $field: ". $self->getfield($field);
2498   $self->setfield($field,uc($1));
2499   '';
2500 }
2501
2502 =item ut_anything COLUMN
2503
2504 Untaints arbitrary data.  Be careful.
2505
2506 =cut
2507
2508 sub ut_anything {
2509   my( $self, $field ) = @_;
2510   $self->getfield($field) =~ /^(.*)$/s
2511     or return "Illegal $field: ". $self->getfield($field);
2512   $self->setfield($field,$1);
2513   '';
2514 }
2515
2516 =item ut_enum COLUMN CHOICES_ARRAYREF
2517
2518 Check/untaint a column, supplying all possible choices, like the "enum" type.
2519
2520 =cut
2521
2522 sub ut_enum {
2523   my( $self, $field, $choices ) = @_;
2524   foreach my $choice ( @$choices ) {
2525     if ( $self->getfield($field) eq $choice ) {
2526       $self->setfield($field, $choice);
2527       return '';
2528     }
2529   }
2530   return "Illegal (enum) field $field: ". $self->getfield($field);
2531 }
2532
2533 =item ut_enumn COLUMN CHOICES_ARRAYREF
2534
2535 Like ut_enum, except the null value is also allowed.
2536
2537 =cut
2538
2539 sub ut_enumn {
2540   my( $self, $field, $choices ) = @_;
2541   $self->getfield($field)
2542     ? $self->ut_enum($field, $choices)
2543     : '';
2544 }
2545
2546
2547 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2548
2549 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
2550 on the column first.
2551
2552 =cut
2553
2554 sub ut_foreign_key {
2555   my( $self, $field, $table, $foreign ) = @_;
2556   return '' if $no_check_foreign;
2557   qsearchs($table, { $foreign => $self->getfield($field) })
2558     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
2559               " in $table.$foreign";
2560   '';
2561 }
2562
2563 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2564
2565 Like ut_foreign_key, except the null value is also allowed.
2566
2567 =cut
2568
2569 sub ut_foreign_keyn {
2570   my( $self, $field, $table, $foreign ) = @_;
2571   $self->getfield($field)
2572     ? $self->ut_foreign_key($field, $table, $foreign)
2573     : '';
2574 }
2575
2576 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
2577
2578 Checks this column as an agentnum, taking into account the current users's
2579 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
2580 right or rights allowing no agentnum.
2581
2582 =cut
2583
2584 sub ut_agentnum_acl {
2585   my( $self, $field ) = (shift, shift);
2586   my $null_acl = scalar(@_) ? shift : [];
2587   $null_acl = [ $null_acl ] unless ref($null_acl);
2588
2589   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
2590   return "Illegal agentnum: $error" if $error;
2591
2592   my $curuser = $FS::CurrentUser::CurrentUser;
2593
2594   if ( $self->$field() ) {
2595
2596     return "Access denied"
2597       unless $curuser->agentnum($self->$field());
2598
2599   } else {
2600
2601     return "Access denied"
2602       unless grep $curuser->access_right($_), @$null_acl;
2603
2604   }
2605
2606   '';
2607
2608 }
2609
2610 =item fields [ TABLE ]
2611
2612 This is a wrapper for real_fields.  Code that called
2613 fields before should probably continue to call fields.
2614
2615 =cut
2616
2617 sub fields {
2618   my $something = shift;
2619   my $table;
2620   if($something->isa('FS::Record')) {
2621     $table = $something->table;
2622   } else {
2623     $table = $something;
2624     $something = "FS::$table";
2625   }
2626   return (real_fields($table));
2627 }
2628
2629
2630 =item encrypt($value)
2631
2632 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2633
2634 Returns the encrypted string.
2635
2636 You should generally not have to worry about calling this, as the system handles this for you.
2637
2638 =cut
2639
2640 sub encrypt {
2641   my ($self, $value) = @_;
2642   my $encrypted;
2643
2644   if ($conf->exists('encryption')) {
2645     if ($self->is_encrypted($value)) {
2646       # Return the original value if it isn't plaintext.
2647       $encrypted = $value;
2648     } else {
2649       $self->loadRSA;
2650       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2651         # RSA doesn't like the empty string so let's pack it up
2652         # The database doesn't like the RSA data so uuencode it
2653         my $length = length($value)+1;
2654         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2655       } else {
2656         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2657       }
2658     }
2659   }
2660   return $encrypted;
2661 }
2662
2663 =item is_encrypted($value)
2664
2665 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2666
2667 =cut
2668
2669
2670 sub is_encrypted {
2671   my ($self, $value) = @_;
2672   # Possible Bug - Some work may be required here....
2673
2674   if ($value =~ /^M/ && length($value) > 80) {
2675     return 1;
2676   } else {
2677     return 0;
2678   }
2679 }
2680
2681 =item decrypt($value)
2682
2683 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2684
2685 You should generally not have to worry about calling this, as the system handles this for you.
2686
2687 =cut
2688
2689 sub decrypt {
2690   my ($self,$value) = @_;
2691   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2692   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2693     $self->loadRSA;
2694     if (ref($rsa_decrypt) =~ /::RSA/) {
2695       my $encrypted = unpack ("u*", $value);
2696       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2697       if ($@) {warn "Decryption Failed"};
2698     }
2699   }
2700   return $decrypted;
2701 }
2702
2703 sub loadRSA {
2704     my $self = shift;
2705     #Initialize the Module
2706     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2707
2708     if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
2709       $rsa_module = $conf->config('encryptionmodule');
2710     }
2711
2712     if (!$rsa_loaded) {
2713         eval ("require $rsa_module"); # No need to import the namespace
2714         $rsa_loaded++;
2715     }
2716     # Initialize Encryption
2717     if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
2718       my $public_key = join("\n",$conf->config('encryptionpublickey'));
2719       $rsa_encrypt = $rsa_module->new_public_key($public_key);
2720     }
2721
2722     # Intitalize Decryption
2723     if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
2724       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2725       $rsa_decrypt = $rsa_module->new_private_key($private_key);
2726     }
2727 }
2728
2729 =item h_search ACTION
2730
2731 Given an ACTION, either "insert", or "delete", returns the appropriate history
2732 record corresponding to this record, if any.
2733
2734 =cut
2735
2736 sub h_search {
2737   my( $self, $action ) = @_;
2738
2739   my $table = $self->table;
2740   $table =~ s/^h_//;
2741
2742   my $primary_key = dbdef->table($table)->primary_key;
2743
2744   qsearchs({
2745     'table'   => "h_$table",
2746     'hashref' => { $primary_key     => $self->$primary_key(),
2747                    'history_action' => $action,
2748                  },
2749   });
2750
2751 }
2752
2753 =item h_date ACTION
2754
2755 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2756 appropriate history record corresponding to this record, if any.
2757
2758 =cut
2759
2760 sub h_date {
2761   my($self, $action) = @_;
2762   my $h = $self->h_search($action);
2763   $h ? $h->history_date : '';
2764 }
2765
2766 =item scalar_sql SQL [ PLACEHOLDER, ... ]
2767
2768 A class or object method.  Executes the sql statement represented by SQL and
2769 returns a scalar representing the result: the first column of the first row.
2770
2771 Dies on bogus SQL.  Returns an empty string if no row is returned.
2772
2773 Typically used for statments which return a single value such as "SELECT
2774 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
2775
2776 =cut
2777
2778 sub scalar_sql {
2779   my($self, $sql) = (shift, shift);
2780   my $sth = dbh->prepare($sql) or die dbh->errstr;
2781   $sth->execute(@_)
2782     or die "Unexpected error executing statement $sql: ". $sth->errstr;
2783   my $row = $sth->fetchrow_arrayref or return '';
2784   my $scalar = $row->[0];
2785   defined($scalar) ? $scalar : '';
2786 }
2787
2788 =back
2789
2790 =head1 SUBROUTINES
2791
2792 =over 4
2793
2794 =item real_fields [ TABLE ]
2795
2796 Returns a list of the real columns in the specified table.  Called only by
2797 fields() and other subroutines elsewhere in FS::Record.
2798
2799 =cut
2800
2801 sub real_fields {
2802   my $table = shift;
2803
2804   my($table_obj) = dbdef->table($table);
2805   confess "Unknown table $table" unless $table_obj;
2806   $table_obj->columns;
2807 }
2808
2809 =item pvf FIELD_NAME
2810
2811 Returns the FS::part_virtual_field object corresponding to a field in the
2812 record (specified by FIELD_NAME).
2813
2814 =cut
2815
2816 sub pvf {
2817   my ($self, $name) = (shift, shift);
2818
2819   if(grep /^$name$/, $self->virtual_fields) {
2820     $name =~ s/^cf_//;
2821     my $concat = [ "'cf_'", "name" ];
2822     return qsearchs({   table   =>  'part_virtual_field',
2823                         hashref =>  { dbtable => $self->table,
2824                                       name    => $name
2825                                     },
2826                         select  =>  'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
2827                     });
2828   }
2829   ''
2830 }
2831
2832 =item _quote VALUE, TABLE, COLUMN
2833
2834 This is an internal function used to construct SQL statements.  It returns
2835 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2836 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2837
2838 =cut
2839
2840 sub _quote {
2841   my($value, $table, $column) = @_;
2842   my $column_obj = dbdef->table($table)->column($column);
2843   my $column_type = $column_obj->type;
2844   my $nullable = $column_obj->null;
2845
2846   warn "  $table.$column: $value ($column_type".
2847        ( $nullable ? ' NULL' : ' NOT NULL' ).
2848        ")\n" if $DEBUG > 2;
2849
2850   if ( $value eq '' && $nullable ) {
2851     'NULL';
2852   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2853     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2854           "using 0 instead";
2855     0;
2856   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2857             ! $column_type =~ /(char|binary|text)$/i ) {
2858     $value;
2859   } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
2860            && driver_name eq 'Pg'
2861           )
2862   {
2863     no strict 'subs';
2864 #    dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right
2865     # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\,
2866     # single-quote the whole mess, and put an "E" in front.
2867     return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'");
2868   } else {
2869     dbh->quote($value);
2870   }
2871 }
2872
2873 =item hfields TABLE
2874
2875 This is deprecated.  Don't use it.
2876
2877 It returns a hash-type list with the fields of this record's table set true.
2878
2879 =cut
2880
2881 sub hfields {
2882   carp "warning: hfields is deprecated";
2883   my($table)=@_;
2884   my(%hash);
2885   foreach (fields($table)) {
2886     $hash{$_}=1;
2887   }
2888   \%hash;
2889 }
2890
2891 sub _dump {
2892   my($self)=@_;
2893   join("\n", map {
2894     "$_: ". $self->getfield($_). "|"
2895   } (fields($self->table)) );
2896 }
2897
2898 sub DESTROY { return; }
2899
2900 #sub DESTROY {
2901 #  my $self = shift;
2902 #  #use Carp qw(cluck);
2903 #  #cluck "DESTROYING $self";
2904 #  warn "DESTROYING $self";
2905 #}
2906
2907 #sub is_tainted {
2908 #             return ! eval { join('',@_), kill 0; 1; };
2909 #         }
2910
2911 =item str2time_sql [ DRIVER_NAME ]
2912
2913 Returns a function to convert to unix time based on database type, such as
2914 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
2915 the str2time_sql_closing method to return a closing string rather than just
2916 using a closing parenthesis as previously suggested.
2917
2918 You can pass an optional driver name such as "Pg", "mysql" or
2919 $dbh->{Driver}->{Name} to return a function for that database instead of
2920 the current database.
2921
2922 =cut
2923
2924 sub str2time_sql {
2925   my $driver = shift || driver_name;
2926
2927   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
2928   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
2929
2930   warn "warning: unknown database type $driver; guessing how to convert ".
2931        "dates to UNIX timestamps";
2932   return 'EXTRACT(EPOCH FROM ';
2933
2934 }
2935
2936 =item str2time_sql_closing [ DRIVER_NAME ]
2937
2938 Returns the closing suffix of a function to convert to unix time based on
2939 database type, such as ")::integer" for Pg or ")" for mysql.
2940
2941 You can pass an optional driver name such as "Pg", "mysql" or
2942 $dbh->{Driver}->{Name} to return a function for that database instead of
2943 the current database.
2944
2945 =cut
2946
2947 sub str2time_sql_closing {
2948   my $driver = shift || driver_name;
2949
2950   return ' )::INTEGER ' if $driver =~ /^Pg/i;
2951   return ' ) ';
2952 }
2953
2954 =item regexp_sql [ DRIVER_NAME ]
2955
2956 Returns the operator to do a regular expression comparison based on database
2957 type, such as '~' for Pg or 'REGEXP' for mysql.
2958
2959 You can pass an optional driver name such as "Pg", "mysql" or
2960 $dbh->{Driver}->{Name} to return a function for that database instead of
2961 the current database.
2962
2963 =cut
2964
2965 sub regexp_sql {
2966   my $driver = shift || driver_name;
2967
2968   return '~'      if $driver =~ /^Pg/i;
2969   return 'REGEXP' if $driver =~ /^mysql/i;
2970
2971   die "don't know how to use regular expressions in ". driver_name." databases";
2972
2973 }
2974
2975 =item not_regexp_sql [ DRIVER_NAME ]
2976
2977 Returns the operator to do a regular expression negation based on database
2978 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
2979
2980 You can pass an optional driver name such as "Pg", "mysql" or
2981 $dbh->{Driver}->{Name} to return a function for that database instead of
2982 the current database.
2983
2984 =cut
2985
2986 sub not_regexp_sql {
2987   my $driver = shift || driver_name;
2988
2989   return '!~'         if $driver =~ /^Pg/i;
2990   return 'NOT REGEXP' if $driver =~ /^mysql/i;
2991
2992   die "don't know how to use regular expressions in ". driver_name." databases";
2993
2994 }
2995
2996 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
2997
2998 Returns the items concatendated based on database type, using "CONCAT()" for
2999 mysql and " || " for Pg and other databases.
3000
3001 You can pass an optional driver name such as "Pg", "mysql" or
3002 $dbh->{Driver}->{Name} to return a function for that database instead of
3003 the current database.
3004
3005 =cut
3006
3007 sub concat_sql {
3008   my $driver = ref($_[0]) ? driver_name : shift;
3009   my $items = shift;
3010
3011   if ( $driver =~ /^mysql/i ) {
3012     'CONCAT('. join(',', @$items). ')';
3013   } else {
3014     join('||', @$items);
3015   }
3016
3017 }
3018
3019 =back
3020
3021 =head1 BUGS
3022
3023 This module should probably be renamed, since much of the functionality is
3024 of general use.  It is not completely unlike Adapter::DBI (see below).
3025
3026 Exported qsearch and qsearchs should be deprecated in favor of method calls
3027 (against an FS::Record object like the old search and searchs that qsearch
3028 and qsearchs were on top of.)
3029
3030 The whole fields / hfields mess should be removed.
3031
3032 The various WHERE clauses should be subroutined.
3033
3034 table string should be deprecated in favor of DBIx::DBSchema::Table.
3035
3036 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
3037 true maps to the database (and WHERE clauses) would also help.
3038
3039 The ut_ methods should ask the dbdef for a default length.
3040
3041 ut_sqltype (like ut_varchar) should all be defined
3042
3043 A fallback check method should be provided which uses the dbdef.
3044
3045 The ut_money method assumes money has two decimal digits.
3046
3047 The Pg money kludge in the new method only strips `$'.
3048
3049 The ut_phonen method only checks US-style phone numbers.
3050
3051 The _quote function should probably use ut_float instead of a regex.
3052
3053 All the subroutines probably should be methods, here or elsewhere.
3054
3055 Probably should borrow/use some dbdef methods where appropriate (like sub
3056 fields)
3057
3058 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3059 or allow it to be set.  Working around it is ugly any way around - DBI should
3060 be fixed.  (only affects RDBMS which return uppercase column names)
3061
3062 ut_zip should take an optional country like ut_phone.
3063
3064 =head1 SEE ALSO
3065
3066 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3067
3068 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
3069
3070 http://poop.sf.net/
3071
3072 =cut
3073
3074 1;
3075