FS/FS/Record.pm

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