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       $saved->{$field} = $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 ". ref($new)."->replace ".
1186            ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
1187          ": records identical"
1188       unless $nowarn_identical;
1189     return '';
1190   }
1191
1192   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1193     map {
1194       "$_ = ". _quote($new->getfield($_),$old->table,$_)
1195     } real_fields($old->table)
1196   ). ' WHERE '.
1197     join(' AND ',
1198       map {
1199
1200         if ( $old->getfield($_) eq '' ) {
1201
1202          #false laziness w/qsearch
1203          if ( driver_name eq 'Pg' ) {
1204             my $type = $old->dbdef_table->column($_)->type;
1205             if ( $type =~ /(int|(big)?serial)/i ) {
1206               qq-( $_ IS NULL )-;
1207             } else {
1208               qq-( $_ IS NULL OR $_ = '' )-;
1209             }
1210           } else {
1211             qq-( $_ IS NULL OR $_ = "" )-;
1212           }
1213
1214         } else {
1215           "$_ = ". _quote($old->getfield($_),$old->table,$_);
1216         }
1217
1218       } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1219     )
1220   ;
1221   warn "[debug]$me $statement\n" if $DEBUG > 1;
1222   my $sth = dbh->prepare($statement) or return dbh->errstr;
1223
1224   my $h_old_sth;
1225   if ( defined dbdef->table('h_'. $old->table) ) {
1226     my $h_old_statement = $old->_h_statement('replace_old');
1227     warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1228     $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1229   } else {
1230     $h_old_sth = '';
1231   }
1232
1233   my $h_new_sth;
1234   if ( defined dbdef->table('h_'. $new->table) ) {
1235     my $h_new_statement = $new->_h_statement('replace_new');
1236     warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1237     $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1238   } else {
1239     $h_new_sth = '';
1240   }
1241
1242   local $SIG{HUP} = 'IGNORE';
1243   local $SIG{INT} = 'IGNORE';
1244   local $SIG{QUIT} = 'IGNORE';
1245   local $SIG{TERM} = 'IGNORE';
1246   local $SIG{TSTP} = 'IGNORE';
1247   local $SIG{PIPE} = 'IGNORE';
1248
1249   my $rc = $sth->execute or return $sth->errstr;
1250   #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1251   $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1252   $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1253
1254   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1255
1256   # Now that it has been saved, reset the encrypted fields so that $new
1257   # can still be used.
1258   foreach my $field (keys %{$saved}) {
1259     $new->setfield($field, $saved->{$field});
1260   }
1261
1262   '';
1263
1264 }
1265
1266 sub replace_old {
1267   my( $self ) = shift;
1268   warn "[$me] replace called with no arguments; autoloading old record\n"
1269     if $DEBUG;
1270
1271   my $primary_key = $self->dbdef_table->primary_key;
1272   if ( $primary_key ) {
1273     $self->by_key( $self->$primary_key() ) #this is what's returned
1274       or croak "can't find ". $self->table. ".$primary_key ".
1275         $self->$primary_key();
1276   } else {
1277     croak $self->table. " has no primary key; pass old record as argument";
1278   }
1279
1280 }
1281
1282 =item rep
1283
1284 Depriciated (use replace instead).
1285
1286 =cut
1287
1288 sub rep {
1289   cluck "warning: FS::Record::rep deprecated!";
1290   replace @_; #call method in this scope
1291 }
1292
1293 =item check
1294
1295 Checks custom fields. Subclasses should still provide a check method to validate
1296 non-custom fields, foreign keys, etc., and call this method via $self->SUPER::check.
1297
1298 =cut
1299
1300 sub check {
1301     my $self = shift;
1302     foreach my $field ($self->virtual_fields) {
1303         my $error = $self->ut_textn($field);
1304         return $error if $error;
1305     }
1306     '';
1307 }
1308
1309 =item virtual_fields [ TABLE ]
1310
1311 Returns a list of virtual fields defined for the table.  This should not
1312 be exported, and should only be called as an instance or class method.
1313
1314 =cut
1315
1316 sub virtual_fields {
1317   my $self = shift;
1318   my $table;
1319   $table = $self->table or confess "virtual_fields called on non-table";
1320
1321   confess "Unknown table $table" unless dbdef->table($table);
1322
1323   return () unless dbdef->table('part_virtual_field');
1324
1325   unless ( $virtual_fields_cache{$table} ) {
1326     my $concat = [ "'cf_'", "name" ];
1327     my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' .
1328                 "WHERE dbtable = '$table'";
1329     my $dbh = dbh;
1330     my $result = $dbh->selectcol_arrayref($query);
1331     confess "Error executing virtual fields query: $query: ". $dbh->errstr
1332       if $dbh->err;
1333     $virtual_fields_cache{$table} = $result;
1334   }
1335
1336   @{$virtual_fields_cache{$table}};
1337
1338 }
1339
1340 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1341
1342 Processes a batch import as a queued JSRPC job
1343
1344 JOB is an FS::queue entry.
1345
1346 OPTIONS_HASHREF can have the following keys:
1347
1348 =over 4
1349
1350 =item table
1351
1352 Table name (required).
1353
1354 =item params
1355
1356 Listref of field names for static fields.  They will be given values from the
1357 PARAMS hashref and passed as a "params" hashref to batch_import.
1358
1359 =item formats
1360
1361 Formats hashref.  Keys are field names, values are listrefs that define the
1362 format.
1363
1364 Each listref value can be a column name or a code reference.  Coderefs are run
1365 with the row object, data and a FS::Conf object as the three parameters.
1366 For example, this coderef does the same thing as using the "columnname" string:
1367
1368   sub {
1369     my( $record, $data, $conf ) = @_;
1370     $record->columnname( $data );
1371   },
1372
1373 Coderefs are run after all "column name" fields are assigned.
1374
1375 =item format_types
1376
1377 Optional format hashref of types.  Keys are field names, values are "csv",
1378 "xls" or "fixedlength".  Overrides automatic determination of file type
1379 from extension.
1380
1381 =item format_headers
1382
1383 Optional format hashref of header lines.  Keys are field names, values are 0
1384 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1385 number of lines.
1386
1387 =item format_sep_chars
1388
1389 Optional format hashref of CSV sep_chars.  Keys are field names, values are the
1390 CSV separation character.
1391
1392 =item format_fixedlenth_formats
1393
1394 Optional format hashref of fixed length format defintiions.  Keys are field
1395 names, values Parse::FixedLength listrefs of field definitions.
1396
1397 =item default_csv
1398
1399 Set true to default to CSV file type if the filename does not contain a
1400 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1401 format_types).
1402
1403 =back
1404
1405 PARAMS is a base64-encoded Storable string containing the POSTed data as
1406 a hash ref.  It normally contains at least one field, "uploaded files",
1407 generated by /elements/file-upload.html and containing the list of uploaded
1408 files.  Currently only supports a single file named "file".
1409
1410 =cut
1411
1412 use Storable qw(thaw);
1413 use Data::Dumper;
1414 use MIME::Base64;
1415 sub process_batch_import {
1416   my($job, $opt) = ( shift, shift );
1417
1418   my $table = $opt->{table};
1419   my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1420   my %formats = %{ $opt->{formats} };
1421
1422   my $param = thaw(decode_base64(shift));
1423   warn Dumper($param) if $DEBUG;
1424
1425   my $files = $param->{'uploaded_files'}
1426     or die "No files provided.\n";
1427
1428   my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1429
1430   my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1431   my $file = $dir. $files{'file'};
1432
1433   my %iopt = (
1434     #class-static
1435     table                      => $table,
1436     formats                    => \%formats,
1437     format_types               => $opt->{format_types},
1438     format_headers             => $opt->{format_headers},
1439     format_sep_chars           => $opt->{format_sep_chars},
1440     format_fixedlength_formats => $opt->{format_fixedlength_formats},
1441     format_xml_formats         => $opt->{format_xml_formats},
1442     format_row_callbacks       => $opt->{format_row_callbacks},
1443     #per-import
1444     job                        => $job,
1445     file                       => $file,
1446     #type                       => $type,
1447     format                     => $param->{format},
1448     params                     => { map { $_ => $param->{$_} } @pass_params },
1449     #?
1450     default_csv                => $opt->{default_csv},
1451     postinsert_callback        => $opt->{postinsert_callback},
1452   );
1453
1454   if ( $opt->{'batch_namecol'} ) {
1455     $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1456     $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1457   }
1458
1459   my $error = FS::Record::batch_import( \%iopt );
1460
1461   unlink $file;
1462
1463   die "$error\n" if $error;
1464 }
1465
1466 =item batch_import PARAM_HASHREF
1467
1468 Class method for batch imports.  Available params:
1469
1470 =over 4
1471
1472 =item table
1473
1474 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1475
1476 =item formats
1477
1478 =item format_types
1479
1480 =item format_headers
1481
1482 =item format_sep_chars
1483
1484 =item format_fixedlength_formats
1485
1486 =item format_row_callbacks
1487
1488 =item fields - Alternate way to specify import, specifying import fields directly as a listref
1489
1490 =item preinsert_callback
1491
1492 =item postinsert_callback
1493
1494 =item params
1495
1496 =item job
1497
1498 FS::queue object, will be updated with progress
1499
1500 =item file
1501
1502 =item type
1503
1504 csv, xls, fixedlength, xml
1505
1506 =item empty_ok
1507
1508 =back
1509
1510 =cut
1511
1512 sub batch_import {
1513   my $param = shift;
1514
1515   warn "$me batch_import call with params: \n". Dumper($param)
1516     if $DEBUG;
1517
1518   my $table   = $param->{table};
1519
1520   my $job     = $param->{job};
1521   my $file    = $param->{file};
1522   my $params  = $param->{params} || {};
1523
1524   my( $type, $header, $sep_char, $fixedlength_format,
1525       $xml_format, $row_callback, @fields );
1526
1527   my $postinsert_callback = '';
1528   $postinsert_callback = $param->{'postinsert_callback'}
1529           if $param->{'postinsert_callback'};
1530   my $preinsert_callback = '';
1531   $preinsert_callback = $param->{'preinsert_callback'}
1532           if $param->{'preinsert_callback'};
1533
1534   if ( $param->{'format'} ) {
1535
1536     my $format  = $param->{'format'};
1537     my $formats = $param->{formats};
1538     die "unknown format $format" unless exists $formats->{ $format };
1539
1540     $type = $param->{'format_types'}
1541             ? $param->{'format_types'}{ $format }
1542             : $param->{type} || 'csv';
1543
1544
1545     $header = $param->{'format_headers'}
1546                ? $param->{'format_headers'}{ $param->{'format'} }
1547                : 0;
1548
1549     $sep_char = $param->{'format_sep_chars'}
1550                   ? $param->{'format_sep_chars'}{ $param->{'format'} }
1551                   : ',';
1552
1553     $fixedlength_format =
1554       $param->{'format_fixedlength_formats'}
1555         ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1556         : '';
1557
1558     $xml_format =
1559       $param->{'format_xml_formats'}
1560         ? $param->{'format_xml_formats'}{ $param->{'format'} }
1561         : '';
1562
1563     $row_callback =
1564       $param->{'format_row_callbacks'}
1565         ? $param->{'format_row_callbacks'}{ $param->{'format'} }
1566         : '';
1567
1568     @fields = @{ $formats->{ $format } };
1569
1570   } elsif ( $param->{'fields'} ) {
1571
1572     $type = ''; #infer from filename
1573     $header = 0;
1574     $sep_char = ',';
1575     $fixedlength_format = '';
1576     $row_callback = '';
1577     @fields = @{ $param->{'fields'} };
1578
1579   } else {
1580     die "neither format nor fields specified";
1581   }
1582
1583   #my $file    = $param->{file};
1584
1585   unless ( $type ) {
1586     if ( $file =~ /\.(\w+)$/i ) {
1587       $type = lc($1);
1588     } else {
1589       #or error out???
1590       warn "can't parse file type from filename $file; defaulting to CSV";
1591       $type = 'csv';
1592     }
1593     $type = 'csv'
1594       if $param->{'default_csv'} && $type ne 'xls';
1595   }
1596
1597
1598   my $row = 0;
1599   my $count;
1600   my $parser;
1601   my @buffer = ();
1602   if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1603
1604     if ( $type eq 'csv' ) {
1605
1606       my %attr = ();
1607       $attr{sep_char} = $sep_char if $sep_char;
1608       $parser = new Text::CSV_XS \%attr;
1609
1610     } elsif ( $type eq 'fixedlength' ) {
1611
1612       eval "use Parse::FixedLength;";
1613       die $@ if $@;
1614       $parser = Parse::FixedLength->new($fixedlength_format);
1615
1616     }
1617     else {
1618       die "Unknown file type $type\n";
1619     }
1620
1621     @buffer = split(/\r?\n/, slurp($file) );
1622     splice(@buffer, 0, ($header || 0) );
1623     $count = scalar(@buffer);
1624
1625   } elsif ( $type eq 'xls' ) {
1626
1627     eval "use Spreadsheet::ParseExcel;";
1628     die $@ if $@;
1629
1630     eval "use DateTime::Format::Excel;";
1631     #for now, just let the error be thrown if it is used, since only CDR
1632     # formats bill_west and troop use it, not other excel-parsing things
1633     #die $@ if $@;
1634
1635     my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
1636
1637     $parser = $excel->{Worksheet}[0]; #first sheet
1638
1639     $count = $parser->{MaxRow} || $parser->{MinRow};
1640     $count++;
1641
1642     $row = $header || 0;
1643   } elsif ( $type eq 'xml' ) {
1644     # FS::pay_batch
1645     eval "use XML::Simple;";
1646     die $@ if $@;
1647     my $xmlrow = $xml_format->{'xmlrow'};
1648     $parser = $xml_format->{'xmlkeys'};
1649     die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
1650     my $data = XML::Simple::XMLin(
1651       $file,
1652       'SuppressEmpty' => '', #sets empty values to ''
1653       'KeepRoot'      => 1,
1654     );
1655     my $rows = $data;
1656     $rows = $rows->{$_} foreach @$xmlrow;
1657     $rows = [ $rows ] if ref($rows) ne 'ARRAY';
1658     $count = @buffer = @$rows;
1659   } else {
1660     die "Unknown file type $type\n";
1661   }
1662
1663   #my $columns;
1664
1665   local $SIG{HUP} = 'IGNORE';
1666   local $SIG{INT} = 'IGNORE';
1667   local $SIG{QUIT} = 'IGNORE';
1668   local $SIG{TERM} = 'IGNORE';
1669   local $SIG{TSTP} = 'IGNORE';
1670   local $SIG{PIPE} = 'IGNORE';
1671
1672   my $oldAutoCommit = $FS::UID::AutoCommit;
1673   local $FS::UID::AutoCommit = 0;
1674   my $dbh = dbh;
1675
1676   #my $params  = $param->{params} || {};
1677   if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
1678     my $batch_col   = $param->{'batch_keycol'};
1679
1680     my $batch_class = 'FS::'. $param->{'batch_table'};
1681     my $batch = $batch_class->new({
1682       $param->{'batch_namecol'} => $param->{'batch_namevalue'}
1683     });
1684     my $error = $batch->insert;
1685     if ( $error ) {
1686       $dbh->rollback if $oldAutoCommit;
1687       return "can't insert batch record: $error";
1688     }
1689     #primary key via dbdef? (so the column names don't have to match)
1690     my $batch_value = $batch->get( $param->{'batch_keycol'} );
1691
1692     $params->{ $batch_col } = $batch_value;
1693   }
1694
1695   #my $job     = $param->{job};
1696   my $line;
1697   my $imported = 0;
1698   my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
1699   while (1) {
1700
1701     my @columns = ();
1702     if ( $type eq 'csv' ) {
1703
1704       last unless scalar(@buffer);
1705       $line = shift(@buffer);
1706
1707       next if $line =~ /^\s*$/; #skip empty lines
1708
1709       $line = &{$row_callback}($line) if $row_callback;
1710
1711       next if $line =~ /^\s*$/; #skip empty lines
1712
1713       $parser->parse($line) or do {
1714         $dbh->rollback if $oldAutoCommit;
1715         return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
1716       };
1717       @columns = $parser->fields();
1718
1719     } elsif ( $type eq 'fixedlength' ) {
1720
1721       last unless scalar(@buffer);
1722       $line = shift(@buffer);
1723
1724       @columns = $parser->parse($line);
1725
1726     } elsif ( $type eq 'xls' ) {
1727
1728       last if $row > ($parser->{MaxRow} || $parser->{MinRow})
1729            || ! $parser->{Cells}[$row];
1730
1731       my @row = @{ $parser->{Cells}[$row] };
1732       @columns = map $_->{Val}, @row;
1733
1734       #my $z = 'A';
1735       #warn $z++. ": $_\n" for @columns;
1736
1737     } elsif ( $type eq 'xml' ) {
1738       # $parser = [ 'Column0Key', 'Column1Key' ... ]
1739       last unless scalar(@buffer);
1740       my $row = shift @buffer;
1741       @columns = @{ $row }{ @$parser };
1742     } else {
1743       die "Unknown file type $type\n";
1744     }
1745
1746     my @later = ();
1747     my %hash = %$params;
1748
1749     foreach my $field ( @fields ) {
1750
1751       my $value = shift @columns;
1752
1753       if ( ref($field) eq 'CODE' ) {
1754         #&{$field}(\%hash, $value);
1755         push @later, $field, $value;
1756       } else {
1757         #??? $hash{$field} = $value if length($value);
1758         $hash{$field} = $value if defined($value) && length($value);
1759       }
1760
1761     }
1762
1763     #my $table   = $param->{table};
1764     my $class = "FS::$table";
1765
1766     my $record = $class->new( \%hash );
1767
1768     my $param = {};
1769     while ( scalar(@later) ) {
1770       my $sub = shift @later;
1771       my $data = shift @later;
1772       eval {
1773         &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
1774       };
1775       if ( $@ ) {
1776         $dbh->rollback if $oldAutoCommit;
1777         return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
1778       }
1779       last if exists( $param->{skiprow} );
1780     }
1781     next if exists( $param->{skiprow} );
1782
1783     if ( $preinsert_callback ) {
1784       my $error = &{$preinsert_callback}($record, $param);
1785       if ( $error ) {
1786         $dbh->rollback if $oldAutoCommit;
1787         return "preinsert_callback error". ( $line ? " for $line" : '' ).
1788                ": $error";
1789       }
1790       next if exists $param->{skiprow} && $param->{skiprow};
1791     }
1792
1793     my $error = $record->insert;
1794
1795     if ( $error ) {
1796       $dbh->rollback if $oldAutoCommit;
1797       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
1798     }
1799
1800     $row++;
1801     $imported++;
1802
1803     if ( $postinsert_callback ) {
1804       my $error = &{$postinsert_callback}($record, $param);
1805       if ( $error ) {
1806         $dbh->rollback if $oldAutoCommit;
1807         return "postinsert_callback error". ( $line ? " for $line" : '' ).
1808                ": $error";
1809       }
1810     }
1811
1812     if ( $job && time - $min_sec > $last ) { #progress bar
1813       $job->update_statustext( int(100 * $imported / $count) );
1814       $last = time;
1815     }
1816
1817   }
1818
1819   unless ( $imported || $param->{empty_ok} ) {
1820     $dbh->rollback if $oldAutoCommit;
1821     return "Empty file!";
1822   }
1823
1824   $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
1825
1826   ''; #no error
1827
1828 }
1829
1830 sub _h_statement {
1831   my( $self, $action, $time ) = @_;
1832
1833   $time ||= time;
1834
1835   my %nohistory = map { $_=>1 } $self->nohistory_fields;
1836
1837   my @fields =
1838     grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
1839     real_fields($self->table);
1840   ;
1841
1842   # If we're encrypting then don't store the payinfo in the history
1843   if ( $conf && $conf->exists('encryption') && $self->table ne 'banned_pay' ) {
1844     @fields = grep { $_ ne 'payinfo' } @fields;
1845   }
1846
1847   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1848
1849   "INSERT INTO h_". $self->table. " ( ".
1850       join(', ', qw(history_date history_user history_action), @fields ).
1851     ") VALUES (".
1852       join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1853     ")"
1854   ;
1855 }
1856
1857 =item unique COLUMN
1858
1859 B<Warning>: External use is B<deprecated>.
1860
1861 Replaces COLUMN in record with a unique number, using counters in the
1862 filesystem.  Used by the B<insert> method on single-field unique columns
1863 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1864 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1865
1866 Returns the new value.
1867
1868 =cut
1869
1870 sub unique {
1871   my($self,$field) = @_;
1872   my($table)=$self->table;
1873
1874   croak "Unique called on field $field, but it is ",
1875         $self->getfield($field),
1876         ", not null!"
1877     if $self->getfield($field);
1878
1879   #warn "table $table is tainted" if is_tainted($table);
1880   #warn "field $field is tainted" if is_tainted($field);
1881
1882   my($counter) = new File::CounterFile "$table.$field",0;
1883 # hack for web demo
1884 #  getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1885 #  my($user)=$1;
1886 #  my($counter) = new File::CounterFile "$user/$table.$field",0;
1887 # endhack
1888
1889   my $index = $counter->inc;
1890   $index = $counter->inc while qsearchs($table, { $field=>$index } );
1891
1892   $index =~ /^(\d*)$/;
1893   $index=$1;
1894
1895   $self->setfield($field,$index);
1896
1897 }
1898
1899 =item ut_float COLUMN
1900
1901 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
1902 null.  If there is an error, returns the error, otherwise returns false.
1903
1904 =cut
1905
1906 sub ut_float {
1907   my($self,$field)=@_ ;
1908   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
1909    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
1910    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
1911    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
1912     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1913   $self->setfield($field,$1);
1914   '';
1915 }
1916 =item ut_floatn COLUMN
1917
1918 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1919 null.  If there is an error, returns the error, otherwise returns false.
1920
1921 =cut
1922
1923 #false laziness w/ut_ipn
1924 sub ut_floatn {
1925   my( $self, $field ) = @_;
1926   if ( $self->getfield($field) =~ /^()$/ ) {
1927     $self->setfield($field,'');
1928     '';
1929   } else {
1930     $self->ut_float($field);
1931   }
1932 }
1933
1934 =item ut_sfloat COLUMN
1935
1936 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1937 May not be null.  If there is an error, returns the error, otherwise returns
1938 false.
1939
1940 =cut
1941
1942 sub ut_sfloat {
1943   my($self,$field)=@_ ;
1944   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
1945    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
1946    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
1947    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
1948     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1949   $self->setfield($field,$1);
1950   '';
1951 }
1952 =item ut_sfloatn COLUMN
1953
1954 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1955 null.  If there is an error, returns the error, otherwise returns false.
1956
1957 =cut
1958
1959 sub ut_sfloatn {
1960   my( $self, $field ) = @_;
1961   if ( $self->getfield($field) =~ /^()$/ ) {
1962     $self->setfield($field,'');
1963     '';
1964   } else {
1965     $self->ut_sfloat($field);
1966   }
1967 }
1968
1969 =item ut_snumber COLUMN
1970
1971 Check/untaint signed numeric data (whole numbers).  If there is an error,
1972 returns the error, otherwise returns false.
1973
1974 =cut
1975
1976 sub ut_snumber {
1977   my($self, $field) = @_;
1978   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
1979     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1980   $self->setfield($field, "$1$2");
1981   '';
1982 }
1983
1984 =item ut_snumbern COLUMN
1985
1986 Check/untaint signed numeric data (whole numbers).  If there is an error,
1987 returns the error, otherwise returns false.
1988
1989 =cut
1990
1991 sub ut_snumbern {
1992   my($self, $field) = @_;
1993   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
1994     or return "Illegal (numeric) $field: ". $self->getfield($field);
1995   if ($1) {
1996     return "Illegal (numeric) $field: ". $self->getfield($field)
1997       unless $2;
1998   }
1999   $self->setfield($field, "$1$2");
2000   '';
2001 }
2002
2003 =item ut_number COLUMN
2004
2005 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
2006 is an error, returns the error, otherwise returns false.
2007
2008 =cut
2009
2010 sub ut_number {
2011   my($self,$field)=@_;
2012   $self->getfield($field) =~ /^\s*(\d+)\s*$/
2013     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2014   $self->setfield($field,$1);
2015   '';
2016 }
2017
2018 =item ut_numbern COLUMN
2019
2020 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
2021 an error, returns the error, otherwise returns false.
2022
2023 =cut
2024
2025 sub ut_numbern {
2026   my($self,$field)=@_;
2027   $self->getfield($field) =~ /^\s*(\d*)\s*$/
2028     or return "Illegal (numeric) $field: ". $self->getfield($field);
2029   $self->setfield($field,$1);
2030   '';
2031 }
2032
2033 =item ut_money COLUMN
2034
2035 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
2036 is an error, returns the error, otherwise returns false.
2037
2038 =cut
2039
2040 sub ut_money {
2041   my($self,$field)=@_;
2042   $self->setfield($field, 0) if $self->getfield($field) eq '';
2043   $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/
2044     or return "Illegal (money) $field: ". $self->getfield($field);
2045   #$self->setfield($field, "$1$2$3" || 0);
2046   $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2047   '';
2048 }
2049
2050 =item ut_moneyn COLUMN
2051
2052 Check/untaint monetary numbers.  May be negative.  If there
2053 is an error, returns the error, otherwise returns false.
2054
2055 =cut
2056
2057 sub ut_moneyn {
2058   my($self,$field)=@_;
2059   if ($self->getfield($field) eq '') {
2060     $self->setfield($field, '');
2061     return '';
2062   }
2063   $self->ut_money($field);
2064 }
2065
2066 =item ut_text COLUMN
2067
2068 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2069 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2070 May not be null.  If there is an error, returns the error, otherwise returns
2071 false.
2072
2073 =cut
2074
2075 sub ut_text {
2076   my($self,$field)=@_;
2077   #warn "msgcat ". \&msgcat. "\n";
2078   #warn "notexist ". \&notexist. "\n";
2079   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2080   $self->getfield($field)
2081     =~ /^([\wô \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
2082       or return gettext('illegal_or_empty_text'). " $field: ".
2083                  $self->getfield($field);
2084   $self->setfield($field,$1);
2085   '';
2086 }
2087
2088 =item ut_textn COLUMN
2089
2090 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2091 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2092 May be null.  If there is an error, returns the error, otherwise returns false.
2093
2094 =cut
2095
2096 sub ut_textn {
2097   my($self,$field)=@_;
2098   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2099   $self->ut_text($field);
2100 }
2101
2102 =item ut_alpha COLUMN
2103
2104 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
2105 an error, returns the error, otherwise returns false.
2106
2107 =cut
2108
2109 sub ut_alpha {
2110   my($self,$field)=@_;
2111   $self->getfield($field) =~ /^(\w+)$/
2112     or return "Illegal or empty (alphanumeric) $field: ".
2113               $self->getfield($field);
2114   $self->setfield($field,$1);
2115   '';
2116 }
2117
2118 =item ut_alphan COLUMN
2119
2120 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
2121 error, returns the error, otherwise returns false.
2122
2123 =cut
2124
2125 sub ut_alphan {
2126   my($self,$field)=@_;
2127   $self->getfield($field) =~ /^(\w*)$/
2128     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2129   $self->setfield($field,$1);
2130   '';
2131 }
2132
2133 =item ut_alphasn COLUMN
2134
2135 Check/untaint alphanumeric strings, spaces allowed.  May be null.  If there is
2136 an error, returns the error, otherwise returns false.
2137
2138 =cut
2139
2140 sub ut_alphasn {
2141   my($self,$field)=@_;
2142   $self->getfield($field) =~ /^([\w ]*)$/
2143     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2144   $self->setfield($field,$1);
2145   '';
2146 }
2147
2148
2149 =item ut_alpha_lower COLUMN
2150
2151 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
2152 there is an error, returns the error, otherwise returns false.
2153
2154 =cut
2155
2156 sub ut_alpha_lower {
2157   my($self,$field)=@_;
2158   $self->getfield($field) =~ /[[:upper:]]/
2159     and return "Uppercase characters are not permitted in $field";
2160   $self->ut_alpha($field);
2161 }
2162
2163 =item ut_phonen COLUMN [ COUNTRY ]
2164
2165 Check/untaint phone numbers.  May be null.  If there is an error, returns
2166 the error, otherwise returns false.
2167
2168 Takes an optional two-letter ISO country code; without it or with unsupported
2169 countries, ut_phonen simply calls ut_alphan.
2170
2171 =cut
2172
2173 sub ut_phonen {
2174   my( $self, $field, $country ) = @_;
2175   return $self->ut_alphan($field) unless defined $country;
2176   my $phonen = $self->getfield($field);
2177   if ( $phonen eq '' ) {
2178     $self->setfield($field,'');
2179   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2180     $phonen =~ s/\D//g;
2181     $phonen = $conf->config('cust_main-default_areacode').$phonen
2182       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2183     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2184       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2185     $phonen = "$1-$2-$3";
2186     $phonen .= " x$4" if $4;
2187     $self->setfield($field,$phonen);
2188   } else {
2189     warn "warning: don't know how to check phone numbers for country $country";
2190     return $self->ut_textn($field);
2191   }
2192   '';
2193 }
2194
2195 =item ut_hex COLUMN
2196
2197 Check/untaint hexadecimal values.
2198
2199 =cut
2200
2201 sub ut_hex {
2202   my($self, $field) = @_;
2203   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2204     or return "Illegal (hex) $field: ". $self->getfield($field);
2205   $self->setfield($field, uc($1));
2206   '';
2207 }
2208
2209 =item ut_hexn COLUMN
2210
2211 Check/untaint hexadecimal values.  May be null.
2212
2213 =cut
2214
2215 sub ut_hexn {
2216   my($self, $field) = @_;
2217   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2218     or return "Illegal (hex) $field: ". $self->getfield($field);
2219   $self->setfield($field, uc($1));
2220   '';
2221 }
2222
2223 =item ut_mac_addr COLUMN
2224
2225 Check/untaint mac addresses.  May be null.
2226
2227 =cut
2228
2229 sub ut_mac_addr {
2230   my($self, $field) = @_;
2231
2232   my $mac = $self->get($field);
2233   $mac =~ s/\s+//g;
2234   $mac =~ s/://g;
2235   $self->set($field, $mac);
2236
2237   my $e = $self->ut_hex($field);
2238   return $e if $e;
2239
2240   return "Illegal (mac address) $field: ". $self->getfield($field)
2241     unless length($self->getfield($field)) == 12;
2242
2243   '';
2244
2245 }
2246
2247 =item ut_mac_addrn COLUMN
2248
2249 Check/untaint mac addresses.  May be null.
2250
2251 =cut
2252
2253 sub ut_mac_addrn {
2254   my($self, $field) = @_;
2255   ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2256 }
2257
2258 =item ut_ip COLUMN
2259
2260 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2261 to 127.0.0.1.
2262
2263 =cut
2264
2265 sub ut_ip {
2266   my( $self, $field ) = @_;
2267   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2268   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2269     or return "Illegal (IP address) $field: ". $self->getfield($field);
2270   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2271   $self->setfield($field, "$1.$2.$3.$4");
2272   '';
2273 }
2274
2275 =item ut_ipn COLUMN
2276
2277 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2278 to 127.0.0.1.  May be null.
2279
2280 =cut
2281
2282 sub ut_ipn {
2283   my( $self, $field ) = @_;
2284   if ( $self->getfield($field) =~ /^()$/ ) {
2285     $self->setfield($field,'');
2286     '';
2287   } else {
2288     $self->ut_ip($field);
2289   }
2290 }
2291
2292 =item ut_ip46 COLUMN
2293
2294 Check/untaint IPv4 or IPv6 address.
2295
2296 =cut
2297
2298 sub ut_ip46 {
2299   my( $self, $field ) = @_;
2300   my $ip = NetAddr::IP->new($self->getfield($field))
2301     or return "Illegal (IP address) $field: ".$self->getfield($field);
2302   $self->setfield($field, lc($ip->addr));
2303   return '';
2304 }
2305
2306 =item ut_ip46n
2307
2308 Check/untaint IPv6 or IPv6 address.  May be null.
2309
2310 =cut
2311
2312 sub ut_ip46n {
2313   my( $self, $field ) = @_;
2314   if ( $self->getfield($field) =~ /^$/ ) {
2315     $self->setfield($field, '');
2316     return '';
2317   }
2318   $self->ut_ip46($field);
2319 }
2320
2321 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2322
2323 Check/untaint coordinates.
2324 Accepts the following forms:
2325 DDD.DDDDD
2326 -DDD.DDDDD
2327 DDD MM.MMM
2328 -DDD MM.MMM
2329 DDD MM SS
2330 -DDD MM SS
2331 DDD MM MMM
2332 -DDD MM MMM
2333
2334 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2335 The latter form (that is, the MMM are thousands of minutes) is
2336 assumed if the "MMM" is exactly three digits or two digits > 59.
2337
2338 To be safe, just use the DDD.DDDDD form.
2339
2340 If LOWER or UPPER are specified, then the coordinate is checked
2341 for lower and upper bounds, respectively.
2342
2343 =cut
2344
2345 sub ut_coord {
2346
2347   my ($self, $field) = (shift, shift);
2348
2349   my $lower = shift if scalar(@_);
2350   my $upper = shift if scalar(@_);
2351   my $coord = $self->getfield($field);
2352   my $neg = $coord =~ s/^(-)//;
2353
2354   my ($d, $m, $s) = (0, 0, 0);
2355
2356   if (
2357     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2358     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2359     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2360   ) {
2361     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2362     $m = $m / 60;
2363     if ($m > 59) {
2364       return "Invalid (coordinate with minutes > 59) $field: "
2365              . $self->getfield($field);
2366     }
2367
2368     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2369
2370     if (defined($lower) and ($coord < $lower)) {
2371       return "Invalid (coordinate < $lower) $field: "
2372              . $self->getfield($field);;
2373     }
2374
2375     if (defined($upper) and ($coord > $upper)) {
2376       return "Invalid (coordinate > $upper) $field: "
2377              . $self->getfield($field);;
2378     }
2379
2380     $self->setfield($field, $coord);
2381     return '';
2382   }
2383
2384   return "Invalid (coordinate) $field: " . $self->getfield($field);
2385
2386 }
2387
2388 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2389
2390 Same as ut_coord, except optionally null.
2391
2392 =cut
2393
2394 sub ut_coordn {
2395
2396   my ($self, $field) = (shift, shift);
2397
2398   if ($self->getfield($field) =~ /^$/) {
2399     return '';
2400   } else {
2401     return $self->ut_coord($field, @_);
2402   }
2403
2404 }
2405
2406
2407 =item ut_domain COLUMN
2408
2409 Check/untaint host and domain names.
2410
2411 =cut
2412
2413 sub ut_domain {
2414   my( $self, $field ) = @_;
2415   #$self->getfield($field) =~/^(\w+\.)*\w+$/
2416   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2417     or return "Illegal (domain) $field: ". $self->getfield($field);
2418   $self->setfield($field,$1);
2419   '';
2420 }
2421
2422 =item ut_name COLUMN
2423
2424 Check/untaint proper names; allows alphanumerics, spaces and the following
2425 punctuation: , . - '
2426
2427 May not be null.
2428
2429 =cut
2430
2431 sub ut_name {
2432   my( $self, $field ) = @_;
2433 #  warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
2434   $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
2435     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2436   $self->setfield($field,$1);
2437   '';
2438 }
2439
2440 =item ut_zip COLUMN
2441
2442 Check/untaint zip codes.
2443
2444 =cut
2445
2446 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2447
2448 sub ut_zip {
2449   my( $self, $field, $country ) = @_;
2450
2451   if ( $country eq 'US' ) {
2452
2453     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2454       or return gettext('illegal_zip'). " $field for country $country: ".
2455                 $self->getfield($field);
2456     $self->setfield($field, $1);
2457
2458   } elsif ( $country eq 'CA' ) {
2459
2460     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2461       or return gettext('illegal_zip'). " $field for country $country: ".
2462                 $self->getfield($field);
2463     $self->setfield($field, "$1 $2");
2464
2465   } else {
2466
2467     if ( $self->getfield($field) =~ /^\s*$/
2468          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2469        )
2470     {
2471       $self->setfield($field,'');
2472     } else {
2473       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
2474         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2475       $self->setfield($field,$1);
2476     }
2477
2478   }
2479
2480   '';
2481 }
2482
2483 =item ut_country COLUMN
2484
2485 Check/untaint country codes.  Country names are changed to codes, if possible -
2486 see L<Locale::Country>.
2487
2488 =cut
2489
2490 sub ut_country {
2491   my( $self, $field ) = @_;
2492   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2493     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2494          && country2code($1) ) {
2495       $self->setfield($field,uc(country2code($1)));
2496     }
2497   }
2498   $self->getfield($field) =~ /^(\w\w)$/
2499     or return "Illegal (country) $field: ". $self->getfield($field);
2500   $self->setfield($field,uc($1));
2501   '';
2502 }
2503
2504 =item ut_anything COLUMN
2505
2506 Untaints arbitrary data.  Be careful.
2507
2508 =cut
2509
2510 sub ut_anything {
2511   my( $self, $field ) = @_;
2512   $self->getfield($field) =~ /^(.*)$/s
2513     or return "Illegal $field: ". $self->getfield($field);
2514   $self->setfield($field,$1);
2515   '';
2516 }
2517
2518 =item ut_enum COLUMN CHOICES_ARRAYREF
2519
2520 Check/untaint a column, supplying all possible choices, like the "enum" type.
2521
2522 =cut
2523
2524 sub ut_enum {
2525   my( $self, $field, $choices ) = @_;
2526   foreach my $choice ( @$choices ) {
2527     if ( $self->getfield($field) eq $choice ) {
2528       $self->setfield($field, $choice);
2529       return '';
2530     }
2531   }
2532   return "Illegal (enum) field $field: ". $self->getfield($field);
2533 }
2534
2535 =item ut_enumn COLUMN CHOICES_ARRAYREF
2536
2537 Like ut_enum, except the null value is also allowed.
2538
2539 =cut
2540
2541 sub ut_enumn {
2542   my( $self, $field, $choices ) = @_;
2543   $self->getfield($field)
2544     ? $self->ut_enum($field, $choices)
2545     : '';
2546 }
2547
2548
2549 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2550
2551 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
2552 on the column first.
2553
2554 =cut
2555
2556 sub ut_foreign_key {
2557   my( $self, $field, $table, $foreign ) = @_;
2558   return '' if $no_check_foreign;
2559   qsearchs($table, { $foreign => $self->getfield($field) })
2560     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
2561               " in $table.$foreign";
2562   '';
2563 }
2564
2565 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2566
2567 Like ut_foreign_key, except the null value is also allowed.
2568
2569 =cut
2570
2571 sub ut_foreign_keyn {
2572   my( $self, $field, $table, $foreign ) = @_;
2573   $self->getfield($field)
2574     ? $self->ut_foreign_key($field, $table, $foreign)
2575     : '';
2576 }
2577
2578 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
2579
2580 Checks this column as an agentnum, taking into account the current users's
2581 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
2582 right or rights allowing no agentnum.
2583
2584 =cut
2585
2586 sub ut_agentnum_acl {
2587   my( $self, $field ) = (shift, shift);
2588   my $null_acl = scalar(@_) ? shift : [];
2589   $null_acl = [ $null_acl ] unless ref($null_acl);
2590
2591   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
2592   return "Illegal agentnum: $error" if $error;
2593
2594   my $curuser = $FS::CurrentUser::CurrentUser;
2595
2596   if ( $self->$field() ) {
2597
2598     return "Access denied"
2599       unless $curuser->agentnum($self->$field());
2600
2601   } else {
2602
2603     return "Access denied"
2604       unless grep $curuser->access_right($_), @$null_acl;
2605
2606   }
2607
2608   '';
2609
2610 }
2611
2612 =item fields [ TABLE ]
2613
2614 This is a wrapper for real_fields.  Code that called
2615 fields before should probably continue to call fields.
2616
2617 =cut
2618
2619 sub fields {
2620   my $something = shift;
2621   my $table;
2622   if($something->isa('FS::Record')) {
2623     $table = $something->table;
2624   } else {
2625     $table = $something;
2626     $something = "FS::$table";
2627   }
2628   return (real_fields($table));
2629 }
2630
2631
2632 =item encrypt($value)
2633
2634 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2635
2636 Returns the encrypted string.
2637
2638 You should generally not have to worry about calling this, as the system handles this for you.
2639
2640 =cut
2641
2642 sub encrypt {
2643   my ($self, $value) = @_;
2644   my $encrypted;
2645
2646   if ($conf->exists('encryption')) {
2647     if ($self->is_encrypted($value)) {
2648       # Return the original value if it isn't plaintext.
2649       $encrypted = $value;
2650     } else {
2651       $self->loadRSA;
2652       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2653         # RSA doesn't like the empty string so let's pack it up
2654         # The database doesn't like the RSA data so uuencode it
2655         my $length = length($value)+1;
2656         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2657       } else {
2658         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2659       }
2660     }
2661   }
2662   return $encrypted;
2663 }
2664
2665 =item is_encrypted($value)
2666
2667 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2668
2669 =cut
2670
2671
2672 sub is_encrypted {
2673   my ($self, $value) = @_;
2674   # Possible Bug - Some work may be required here....
2675
2676   if ($value =~ /^M/ && length($value) > 80) {
2677     return 1;
2678   } else {
2679     return 0;
2680   }
2681 }
2682
2683 =item decrypt($value)
2684
2685 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2686
2687 You should generally not have to worry about calling this, as the system handles this for you.
2688
2689 =cut
2690
2691 sub decrypt {
2692   my ($self,$value) = @_;
2693   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2694   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2695     $self->loadRSA;
2696     if (ref($rsa_decrypt) =~ /::RSA/) {
2697       my $encrypted = unpack ("u*", $value);
2698       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2699       if ($@) {warn "Decryption Failed"};
2700     }
2701   }
2702   return $decrypted;
2703 }
2704
2705 sub loadRSA {
2706     my $self = shift;
2707     #Initialize the Module
2708     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2709
2710     if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
2711       $rsa_module = $conf->config('encryptionmodule');
2712     }
2713
2714     if (!$rsa_loaded) {
2715         eval ("require $rsa_module"); # No need to import the namespace
2716         $rsa_loaded++;
2717     }
2718     # Initialize Encryption
2719     if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
2720       my $public_key = join("\n",$conf->config('encryptionpublickey'));
2721       $rsa_encrypt = $rsa_module->new_public_key($public_key);
2722     }
2723
2724     # Intitalize Decryption
2725     if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
2726       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2727       $rsa_decrypt = $rsa_module->new_private_key($private_key);
2728     }
2729 }
2730
2731 =item h_search ACTION
2732
2733 Given an ACTION, either "insert", or "delete", returns the appropriate history
2734 record corresponding to this record, if any.
2735
2736 =cut
2737
2738 sub h_search {
2739   my( $self, $action ) = @_;
2740
2741   my $table = $self->table;
2742   $table =~ s/^h_//;
2743
2744   my $primary_key = dbdef->table($table)->primary_key;
2745
2746   qsearchs({
2747     'table'   => "h_$table",
2748     'hashref' => { $primary_key     => $self->$primary_key(),
2749                    'history_action' => $action,
2750                  },
2751   });
2752
2753 }
2754
2755 =item h_date ACTION
2756
2757 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2758 appropriate history record corresponding to this record, if any.
2759
2760 =cut
2761
2762 sub h_date {
2763   my($self, $action) = @_;
2764   my $h = $self->h_search($action);
2765   $h ? $h->history_date : '';
2766 }
2767
2768 =item scalar_sql SQL [ PLACEHOLDER, ... ]
2769
2770 A class or object method.  Executes the sql statement represented by SQL and
2771 returns a scalar representing the result: the first column of the first row.
2772
2773 Dies on bogus SQL.  Returns an empty string if no row is returned.
2774
2775 Typically used for statments which return a single value such as "SELECT
2776 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
2777
2778 =cut
2779
2780 sub scalar_sql {
2781   my($self, $sql) = (shift, shift);
2782   my $sth = dbh->prepare($sql) or die dbh->errstr;
2783   $sth->execute(@_)
2784     or die "Unexpected error executing statement $sql: ". $sth->errstr;
2785   my $row = $sth->fetchrow_arrayref or return '';
2786   my $scalar = $row->[0];
2787   defined($scalar) ? $scalar : '';
2788 }
2789
2790 =back
2791
2792 =head1 SUBROUTINES
2793
2794 =over 4
2795
2796 =item real_fields [ TABLE ]
2797
2798 Returns a list of the real columns in the specified table.  Called only by
2799 fields() and other subroutines elsewhere in FS::Record.
2800
2801 =cut
2802
2803 sub real_fields {
2804   my $table = shift;
2805
2806   my($table_obj) = dbdef->table($table);
2807   confess "Unknown table $table" unless $table_obj;
2808   $table_obj->columns;
2809 }
2810
2811 =item pvf FIELD_NAME
2812
2813 Returns the FS::part_virtual_field object corresponding to a field in the
2814 record (specified by FIELD_NAME).
2815
2816 =cut
2817
2818 sub pvf {
2819   my ($self, $name) = (shift, shift);
2820
2821   if(grep /^$name$/, $self->virtual_fields) {
2822     $name =~ s/^cf_//;
2823     my $concat = [ "'cf_'", "name" ];
2824     return qsearchs({   table   =>  'part_virtual_field',
2825                         hashref =>  { dbtable => $self->table,
2826                                       name    => $name
2827                                     },
2828                         select  =>  'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
2829                     });
2830   }
2831   ''
2832 }
2833
2834 =item _quote VALUE, TABLE, COLUMN
2835
2836 This is an internal function used to construct SQL statements.  It returns
2837 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2838 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2839
2840 =cut
2841
2842 sub _quote {
2843   my($value, $table, $column) = @_;
2844   my $column_obj = dbdef->table($table)->column($column);
2845   my $column_type = $column_obj->type;
2846   my $nullable = $column_obj->null;
2847
2848   warn "  $table.$column: $value ($column_type".
2849        ( $nullable ? ' NULL' : ' NOT NULL' ).
2850        ")\n" if $DEBUG > 2;
2851
2852   if ( $value eq '' && $nullable ) {
2853     'NULL';
2854   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2855     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2856           "using 0 instead";
2857     0;
2858   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2859             ! $column_type =~ /(char|binary|text)$/i ) {
2860     $value;
2861   } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
2862            && driver_name eq 'Pg'
2863           )
2864   {
2865     no strict 'subs';
2866 #    dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right
2867     # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\,
2868     # single-quote the whole mess, and put an "E" in front.
2869     return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'");
2870   } else {
2871     dbh->quote($value);
2872   }
2873 }
2874
2875 =item hfields TABLE
2876
2877 This is deprecated.  Don't use it.
2878
2879 It returns a hash-type list with the fields of this record's table set true.
2880
2881 =cut
2882
2883 sub hfields {
2884   carp "warning: hfields is deprecated";
2885   my($table)=@_;
2886   my(%hash);
2887   foreach (fields($table)) {
2888     $hash{$_}=1;
2889   }
2890   \%hash;
2891 }
2892
2893 sub _dump {
2894   my($self)=@_;
2895   join("\n", map {
2896     "$_: ". $self->getfield($_). "|"
2897   } (fields($self->table)) );
2898 }
2899
2900 sub DESTROY { return; }
2901
2902 #sub DESTROY {
2903 #  my $self = shift;
2904 #  #use Carp qw(cluck);
2905 #  #cluck "DESTROYING $self";
2906 #  warn "DESTROYING $self";
2907 #}
2908
2909 #sub is_tainted {
2910 #             return ! eval { join('',@_), kill 0; 1; };
2911 #         }
2912
2913 =item str2time_sql [ DRIVER_NAME ]
2914
2915 Returns a function to convert to unix time based on database type, such as
2916 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
2917 the str2time_sql_closing method to return a closing string rather than just
2918 using a closing parenthesis as previously suggested.
2919
2920 You can pass an optional driver name such as "Pg", "mysql" or
2921 $dbh->{Driver}->{Name} to return a function for that database instead of
2922 the current database.
2923
2924 =cut
2925
2926 sub str2time_sql {
2927   my $driver = shift || driver_name;
2928
2929   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
2930   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
2931
2932   warn "warning: unknown database type $driver; guessing how to convert ".
2933        "dates to UNIX timestamps";
2934   return 'EXTRACT(EPOCH FROM ';
2935
2936 }
2937
2938 =item str2time_sql_closing [ DRIVER_NAME ]
2939
2940 Returns the closing suffix of a function to convert to unix time based on
2941 database type, such as ")::integer" for Pg or ")" for mysql.
2942
2943 You can pass an optional driver name such as "Pg", "mysql" or
2944 $dbh->{Driver}->{Name} to return a function for that database instead of
2945 the current database.
2946
2947 =cut
2948
2949 sub str2time_sql_closing {
2950   my $driver = shift || driver_name;
2951
2952   return ' )::INTEGER ' if $driver =~ /^Pg/i;
2953   return ' ) ';
2954 }
2955
2956 =item regexp_sql [ DRIVER_NAME ]
2957
2958 Returns the operator to do a regular expression comparison based on database
2959 type, such as '~' for Pg or 'REGEXP' for mysql.
2960
2961 You can pass an optional driver name such as "Pg", "mysql" or
2962 $dbh->{Driver}->{Name} to return a function for that database instead of
2963 the current database.
2964
2965 =cut
2966
2967 sub regexp_sql {
2968   my $driver = shift || driver_name;
2969
2970   return '~'      if $driver =~ /^Pg/i;
2971   return 'REGEXP' if $driver =~ /^mysql/i;
2972
2973   die "don't know how to use regular expressions in ". driver_name." databases";
2974
2975 }
2976
2977 =item not_regexp_sql [ DRIVER_NAME ]
2978
2979 Returns the operator to do a regular expression negation based on database
2980 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
2981
2982 You can pass an optional driver name such as "Pg", "mysql" or
2983 $dbh->{Driver}->{Name} to return a function for that database instead of
2984 the current database.
2985
2986 =cut
2987
2988 sub not_regexp_sql {
2989   my $driver = shift || driver_name;
2990
2991   return '!~'         if $driver =~ /^Pg/i;
2992   return 'NOT REGEXP' if $driver =~ /^mysql/i;
2993
2994   die "don't know how to use regular expressions in ". driver_name." databases";
2995
2996 }
2997
2998 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
2999
3000 Returns the items concatendated based on database type, using "CONCAT()" for
3001 mysql and " || " for Pg and other databases.
3002
3003 You can pass an optional driver name such as "Pg", "mysql" or
3004 $dbh->{Driver}->{Name} to return a function for that database instead of
3005 the current database.
3006
3007 =cut
3008
3009 sub concat_sql {
3010   my $driver = ref($_[0]) ? driver_name : shift;
3011   my $items = shift;
3012
3013   if ( $driver =~ /^mysql/i ) {
3014     'CONCAT('. join(',', @$items). ')';
3015   } else {
3016     join('||', @$items);
3017   }
3018
3019 }
3020
3021 =back
3022
3023 =head1 BUGS
3024
3025 This module should probably be renamed, since much of the functionality is
3026 of general use.  It is not completely unlike Adapter::DBI (see below).
3027
3028 Exported qsearch and qsearchs should be deprecated in favor of method calls
3029 (against an FS::Record object like the old search and searchs that qsearch
3030 and qsearchs were on top of.)
3031
3032 The whole fields / hfields mess should be removed.
3033
3034 The various WHERE clauses should be subroutined.
3035
3036 table string should be deprecated in favor of DBIx::DBSchema::Table.
3037
3038 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
3039 true maps to the database (and WHERE clauses) would also help.
3040
3041 The ut_ methods should ask the dbdef for a default length.
3042
3043 ut_sqltype (like ut_varchar) should all be defined
3044
3045 A fallback check method should be provided which uses the dbdef.
3046
3047 The ut_money method assumes money has two decimal digits.
3048
3049 The Pg money kludge in the new method only strips `$'.
3050
3051 The ut_phonen method only checks US-style phone numbers.
3052
3053 The _quote function should probably use ut_float instead of a regex.
3054
3055 All the subroutines probably should be methods, here or elsewhere.
3056
3057 Probably should borrow/use some dbdef methods where appropriate (like sub
3058 fields)
3059
3060 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3061 or allow it to be set.  Working around it is ugly any way around - DBI should
3062 be fixed.  (only affects RDBMS which return uppercase column names)
3063
3064 ut_zip should take an optional country like ut_phone.
3065
3066 =head1 SEE ALSO
3067
3068 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3069
3070 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
3071
3072 http://poop.sf.net/
3073
3074 =cut
3075
3076 1;
3077