FS/FS/Record.pm

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