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