FS/FS/Record.pm

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