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