FS/FS/Record.pm

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