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