FS/FS/Record.pm

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