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