FS/FS/Record.pm

   1 package FS::Record;
   2
   3 use strict;
   4 use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG
   5              $conf $me
   6              %virtual_fields_cache $nowarn_identical $no_update_diff );
   7 use Exporter;
   8 use Carp qw(carp cluck croak confess);
   9 use Scalar::Util qw( blessed );
  10 use File::CounterFile;
  11 use Locale::Country;
  12 use DBI qw(:sql_types);
  13 use DBIx::DBSchema 0.33;
  14 use FS::UID qw(dbh getotaker datasrc driver_name);
  15 use FS::CurrentUser;
  16 use FS::Schema qw(dbdef);
  17 use FS::SearchCache;
  18 use FS::Msgcat qw(gettext);
  19 #use FS::Conf; #dependency loop bs, in install_callback below instead
  20
  21 use FS::part_virtual_field;
  22
  23 use Tie::IxHash;
  24
  25 @ISA = qw(Exporter);
  26
  27 #export dbdef for now... everything else expects to find it here
  28 @EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch
  29                 str2time_sql str2time_sql_closing );
  30
  31 $DEBUG = 0;
  32 $me = '[FS::Record]';
  33
  34 $nowarn_identical = 0;
  35 $no_update_diff = 0;
  36
  37 my $rsa_module;
  38 my $rsa_loaded;
  39 my $rsa_encrypt;
  40 my $rsa_decrypt;
  41
  42 FS::UID->install_callback( sub {
  43   eval "use FS::Conf;";
  44   die $@ if $@;
  45   $conf = new FS::Conf;
  46   $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
  47 } );
  48
  49
  50 =head1 NAME
  51
  52 FS::Record - Database record objects
  53
  54 =head1 SYNOPSIS
  55
  56     use FS::Record;
  57     use FS::Record qw(dbh fields qsearch qsearchs);
  58
  59     $record = new FS::Record 'table', \%hash;
  60     $record = new FS::Record 'table', { 'column' => 'value', ... };
  61
  62     $record  = qsearchs FS::Record 'table', \%hash;
  63     $record  = qsearchs FS::Record 'table', { 'column' => 'value', ... };
  64     @records = qsearch  FS::Record 'table', \%hash;
  65     @records = qsearch  FS::Record 'table', { 'column' => 'value', ... };
  66
  67     $table = $record->table;
  68     $dbdef_table = $record->dbdef_table;
  69
  70     $value = $record->get('column');
  71     $value = $record->getfield('column');
  72     $value = $record->column;
  73
  74     $record->set( 'column' => 'value' );
  75     $record->setfield( 'column' => 'value' );
  76     $record->column('value');
  77
  78     %hash = $record->hash;
  79
  80     $hashref = $record->hashref;
  81
  82     $error = $record->insert;
  83
  84     $error = $record->delete;
  85
  86     $error = $new_record->replace($old_record);
  87
  88     # external use deprecated - handled by the database (at least for Pg, mysql)
  89     $value = $record->unique('column');
  90
  91     $error = $record->ut_float('column');
  92     $error = $record->ut_floatn('column');
  93     $error = $record->ut_number('column');
  94     $error = $record->ut_numbern('column');
  95     $error = $record->ut_snumber('column');
  96     $error = $record->ut_snumbern('column');
  97     $error = $record->ut_money('column');
  98     $error = $record->ut_text('column');
  99     $error = $record->ut_textn('column');
 100     $error = $record->ut_alpha('column');
 101     $error = $record->ut_alphan('column');
 102     $error = $record->ut_phonen('column');
 103     $error = $record->ut_anything('column');
 104     $error = $record->ut_name('column');
 105
 106     $quoted_value = _quote($value,'table','field');
 107
 108     #deprecated
 109     $fields = hfields('table');
 110     if ( $fields->{Field} ) { # etc.
 111
 112     @fields = fields 'table'; #as a subroutine
 113     @fields = $record->fields; #as a method call
 114
 115
 116 =head1 DESCRIPTION
 117
 118 (Mostly) object-oriented interface to database records.  Records are currently
 119 implemented on top of DBI.  FS::Record is intended as a base class for
 120 table-specific classes to inherit from, i.e. FS::cust_main.
 121
 122 =head1 CONSTRUCTORS
 123
 124 =over 4
 125
 126 =item new [ TABLE, ] HASHREF
 127
 128 Creates a new record.  It doesn't store it in the database, though.  See
 129 L<"insert"> for that.
 130
 131 Note that the object stores this hash reference, not a distinct copy of the
 132 hash it points to.  You can ask the object for a copy with the I<hash>
 133 method.
 134
 135 TABLE can only be omitted when a dervived class overrides the table method.
 136
 137 =cut
 138
 139 sub new {
 140   my $proto = shift;
 141   my $class = ref($proto) || $proto;
 142   my $self = {};
 143   bless ($self, $class);
 144
 145   unless ( defined ( $self->table ) ) {
 146     $self->{'Table'} = shift;
 147     carp "warning: FS::Record::new called with table name ". $self->{'Table'};
 148   }
 149
 150   $self->{'Hash'} = shift;
 151
 152   foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
 153     $self->{'Hash'}{$field}='';
 154   }
 155
 156   $self->_rebless if $self->can('_rebless');
 157
 158   $self->{'modified'} = 0;
 159
 160   $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
 161
 162   $self;
 163 }
 164
 165 sub new_or_cached {
 166   my $proto = shift;
 167   my $class = ref($proto) || $proto;
 168   my $self = {};
 169   bless ($self, $class);
 170
 171   $self->{'Table'} = shift unless defined ( $self->table );
 172
 173   my $hashref = $self->{'Hash'} = shift;
 174   my $cache = shift;
 175   if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
 176     my $obj = $cache->cache->{$hashref->{$cache->key}};
 177     $obj->_cache($hashref, $cache) if $obj->can('_cache');
 178     $obj;
 179   } else {
 180     $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
 181   }
 182
 183 }
 184
 185 sub create {
 186   my $proto = shift;
 187   my $class = ref($proto) || $proto;
 188   my $self = {};
 189   bless ($self, $class);
 190   if ( defined $self->table ) {
 191     cluck "create constructor is deprecated, use new!";
 192     $self->new(@_);
 193   } else {
 194     croak "FS::Record::create called (not from a subclass)!";
 195   }
 196 }
 197
 198 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 199
 200 Searches the database for all records matching (at least) the key/value pairs
 201 in HASHREF.  Returns all the records found as `FS::TABLE' objects if that
 202 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
 203 objects.
 204
 205 The preferred usage is to pass a hash reference of named parameters:
 206
 207   my @records = qsearch( {
 208                            'table'     => 'table_name',
 209                            'hashref'   => { 'field' => 'value'
 210                                             'field' => { 'op'    => '<',
 211                                                          'value' => '420',
 212                                                        },
 213                                           },
 214
 215                            #these are optional...
 216                            'select'    => '*',
 217                            'extra_sql' => 'AND field ',
 218                            'order_by'  => 'ORDER BY something',
 219                            #'cache_obj' => '', #optional
 220                            'addl_from' => 'LEFT JOIN othtable USING ( field )',
 221                            'debug'     => 1,
 222                          }
 223                        );
 224
 225 Much code still uses old-style positional parameters, this is also probably
 226 fine in the common case where there are only two parameters:
 227
 228   my @records = qsearch( 'table', { 'field' => 'value' } );
 229
 230 ###oops, argh, FS::Record::new only lets us create database fields.
 231 #Normal behaviour if SELECT is not specified is `*', as in
 232 #C<SELECT * FROM table WHERE ...>.  However, there is an experimental new
 233 #feature where you can specify SELECT - remember, the objects returned,
 234 #although blessed into the appropriate `FS::TABLE' package, will only have the
 235 #fields you specify.  This might have unwanted results if you then go calling
 236 #regular FS::TABLE methods
 237 #on it.
 238
 239 =cut
 240
 241 sub qsearch {
 242   my($stable, $record, $select, $extra_sql, $order_by, $cache, $addl_from );
 243   my $debug = '';
 244   if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too
 245     my $opt = shift;
 246     $stable    = $opt->{'table'}     or die "table name is required";
 247     $record    = $opt->{'hashref'}   || {};
 248     $select    = $opt->{'select'}    || '*';
 249     $extra_sql = $opt->{'extra_sql'} || '';
 250     $order_by  = $opt->{'order_by'}  || '';
 251     $cache     = $opt->{'cache_obj'} || '';
 252     $addl_from = $opt->{'addl_from'} || '';
 253     $debug     = $opt->{'debug'}     || '';
 254   } else {
 255     ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_;
 256     $select ||= '*';
 257   }
 258
 259   #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
 260   #for jsearch
 261   $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
 262   $stable = $1;
 263   my $dbh = dbh;
 264
 265   my $table = $cache ? $cache->table : $stable;
 266   my $dbdef_table = dbdef->table($table)
 267     or die "No schema for table $table found - ".
 268            "do you need to run freeside-upgrade?";
 269   my $pkey = $dbdef_table->primary_key;
 270
 271   my @real_fields = grep exists($record->{$_}), real_fields($table);
 272   my @virtual_fields;
 273   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
 274     @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
 275   } else {
 276     cluck "warning: FS::$table not loaded; virtual fields not searchable";
 277     @virtual_fields = ();
 278   }
 279
 280   my $statement = "SELECT $select FROM $stable";
 281   $statement .= " $addl_from" if $addl_from;
 282   if ( @real_fields or @virtual_fields ) {
 283     $statement .= ' WHERE '. join(' AND ',
 284       get_real_fields($table, $record, \@real_fields) ,
 285       get_virtual_fields($table, $pkey, $record, \@virtual_fields),
 286       );
 287   }
 288
 289   $statement .= " $extra_sql" if defined($extra_sql);
 290   $statement .= " $order_by"  if defined($order_by);
 291
 292   warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
 293   my $sth = $dbh->prepare($statement)
 294     or croak "$dbh->errstr doing $statement";
 295
 296   my $bind = 1;
 297
 298   foreach my $field (
 299     grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
 300   ) {
 301     if ( $record->{$field} =~ /^\d+(\.\d+)?$/
 302          && dbdef->table($table)->column($field)->type =~ /(int|(big)?serial)/i
 303     ) {
 304       $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } );
 305     }elsif ( $record->{$field} =~ /^[+-]?\d+(\.\d+)?$/
 306          && dbdef->table($table)->column($field)->type =~ /(numeric)/i
 307     ) {
 308       $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_FLOAT } );
 309     }elsif ( $record->{$field} =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/
 310          && dbdef->table($table)->column($field)->type =~ /(float4)/i
 311     ) {
 312       $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_FLOAT } );
 313     } else {
 314       $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_VARCHAR } );
 315     }
 316   }
 317
 318 #  $sth->execute( map $record->{$_},
 319 #    grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
 320 #  ) or croak "Error executing \"$statement\": ". $sth->errstr;
 321
 322   $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
 323
 324   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
 325     @virtual_fields = "FS::$table"->virtual_fields;
 326   } else {
 327     cluck "warning: FS::$table not loaded; virtual fields not returned either";
 328     @virtual_fields = ();
 329   }
 330
 331   my %result;
 332   tie %result, "Tie::IxHash";
 333   my @stuff = @{ $sth->fetchall_arrayref( {} ) };
 334   if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
 335     %result = map { $_->{$pkey}, $_ } @stuff;
 336   } else {
 337     @result{@stuff} = @stuff;
 338   }
 339
 340   $sth->finish;
 341
 342   if ( keys(%result) and @virtual_fields ) {
 343     $statement =
 344       "SELECT virtual_field.recnum, part_virtual_field.name, ".
 345              "virtual_field.value ".
 346       "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ".
 347       "WHERE part_virtual_field.dbtable = '$table' AND ".
 348       "virtual_field.recnum IN (".
 349       join(',', keys(%result)). ") AND part_virtual_field.name IN ('".
 350       join(q!', '!, @virtual_fields) . "')";
 351     warn "[debug]$me $statement\n" if $DEBUG > 1;
 352     $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement";
 353     $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
 354
 355     foreach (@{ $sth->fetchall_arrayref({}) }) {
 356       my $recnum = $_->{recnum};
 357       my $name = $_->{name};
 358       my $value = $_->{value};
 359       if (exists($result{$recnum})) {
 360         $result{$recnum}->{$name} = $value;
 361       }
 362     }
 363   }
 364   my @return;
 365   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
 366     if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
 367       #derivied class didn't override new method, so this optimization is safe
 368       if ( $cache ) {
 369         @return = map {
 370           new_or_cached( "FS::$table", { %{$_} }, $cache )
 371         } values(%result);
 372       } else {
 373         @return = map {
 374           new( "FS::$table", { %{$_} } )
 375         } values(%result);
 376       }
 377     } else {
 378       #okay, its been tested
 379       # warn "untested code (class FS::$table uses custom new method)";
 380       @return = map {
 381         eval 'FS::'. $table. '->new( { %{$_} } )';
 382       } values(%result);
 383     }
 384
 385     # Check for encrypted fields and decrypt them.
 386    ## only in the local copy, not the cached object
 387     if ( $conf && $conf->exists('encryption') # $conf doesn't exist when doing
 388                                               # the initial search for
 389                                               # access_user
 390          && eval 'defined(@FS::'. $table . '::encrypted_fields)') {
 391       foreach my $record (@return) {
 392         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 393           # Set it directly... This may cause a problem in the future...
 394           $record->setfield($field, $record->decrypt($record->getfield($field)));
 395         }
 396       }
 397     }
 398   } else {
 399     cluck "warning: FS::$table not loaded; returning FS::Record objects";
 400     @return = map {
 401       FS::Record->new( $table, { %{$_} } );
 402     } values(%result);
 403   }
 404   return @return;
 405 }
 406
 407 ## makes this easier to read
 408
 409 sub get_virtual_fields {
 410    my $table = shift;
 411    my $pkey = shift;
 412    my $record = shift;
 413    my $virtual_fields = shift;
 414
 415    return
 416     ( map {
 417       my $op = '=';
 418       my $column = $_;
 419       if ( ref($record->{$_}) ) {
 420         $op = $record->{$_}{'op'} if $record->{$_}{'op'};
 421         if ( uc($op) eq 'ILIKE' ) {
 422           $op = 'LIKE';
 423           $record->{$_}{'value'} = lc($record->{$_}{'value'});
 424           $column = "LOWER($_)";
 425         }
 426         $record->{$_} = $record->{$_}{'value'};
 427       }
 428
 429       # ... EXISTS ( SELECT name, value FROM part_virtual_field
 430       #              JOIN virtual_field
 431       #              ON part_virtual_field.vfieldpart = virtual_field.vfieldpart
 432       #              WHERE recnum = svc_acct.svcnum
 433       #              AND (name, value) = ('egad', 'brain') )
 434
 435       my $value = $record->{$_};
 436
 437       my $subq;
 438
 439       $subq = ($value ? 'EXISTS ' : 'NOT EXISTS ') .
 440       "( SELECT part_virtual_field.name, virtual_field.value ".
 441       "FROM part_virtual_field JOIN virtual_field ".
 442       "ON part_virtual_field.vfieldpart = virtual_field.vfieldpart ".
 443       "WHERE virtual_field.recnum = ${table}.${pkey} ".
 444       "AND part_virtual_field.name = '${column}'".
 445       ($value ?
 446         " AND virtual_field.value ${op} '${value}'"
 447       : "") . ")";
 448       $subq;
 449
 450     } @{ $virtual_fields } ) ;
 451 }
 452
 453 sub get_real_fields {
 454   my $table = shift;
 455   my $record = shift;
 456   my $real_fields = shift;
 457
 458    ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability
 459       return (
 460       map {
 461
 462       my $op = '=';
 463       my $column = $_;
 464       if ( ref($record->{$_}) ) {
 465         $op = $record->{$_}{'op'} if $record->{$_}{'op'};
 466         #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
 467         if ( uc($op) eq 'ILIKE' ) {
 468           $op = 'LIKE';
 469           $record->{$_}{'value'} = lc($record->{$_}{'value'});
 470           $column = "LOWER($_)";
 471         }
 472         $record->{$_} = $record->{$_}{'value'}
 473       }
 474
 475       if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
 476         if ( $op eq '=' ) {
 477           if ( driver_name eq 'Pg' ) {
 478             my $type = dbdef->table($table)->column($column)->type;
 479             if ( $type =~ /(int|(big)?serial)/i ) {
 480               qq-( $column IS NULL )-;
 481             } else {
 482               qq-( $column IS NULL OR $column = '' )-;
 483             }
 484           } else {
 485             qq-( $column IS NULL OR $column = "" )-;
 486           }
 487         } elsif ( $op eq '!=' ) {
 488           if ( driver_name eq 'Pg' ) {
 489             my $type = dbdef->table($table)->column($column)->type;
 490             if ( $type =~ /(int|(big)?serial)/i ) {
 491               qq-( $column IS NOT NULL )-;
 492             } else {
 493               qq-( $column IS NOT NULL AND $column != '' )-;
 494             }
 495           } else {
 496             qq-( $column IS NOT NULL AND $column != "" )-;
 497           }
 498         } else {
 499           if ( driver_name eq 'Pg' ) {
 500             qq-( $column $op '' )-;
 501           } else {
 502             qq-( $column $op "" )-;
 503           }
 504         }
 505       } else {
 506         "$column $op ?";
 507       }
 508     } @{ $real_fields } );
 509 }
 510
 511 =item by_key PRIMARY_KEY_VALUE
 512
 513 This is a class method that returns the record with the given primary key
 514 value.  This method is only useful in FS::Record subclasses.  For example:
 515
 516   my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
 517
 518 is equivalent to:
 519
 520   my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
 521
 522 =cut
 523
 524 sub by_key {
 525   my ($class, $pkey_value) = @_;
 526
 527   my $table = $class->table
 528     or croak "No table for $class found";
 529
 530   my $dbdef_table = dbdef->table($table)
 531     or die "No schema for table $table found - ".
 532            "do you need to create it or run dbdef-create?";
 533   my $pkey = $dbdef_table->primary_key
 534     or die "No primary key for table $table";
 535
 536   return qsearchs($table, { $pkey => $pkey_value });
 537 }
 538
 539 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
 540
 541 Experimental JOINed search method.  Using this method, you can execute a
 542 single SELECT spanning multiple tables, and cache the results for subsequent
 543 method calls.  Interface will almost definately change in an incompatible
 544 fashion.
 545
 546 Arguments:
 547
 548 =cut
 549
 550 sub jsearch {
 551   my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
 552   my $cache = FS::SearchCache->new( $ptable, $pkey );
 553   my %saw;
 554   ( $cache,
 555     grep { !$saw{$_->getfield($pkey)}++ }
 556       qsearch($table, $record, $select, $extra_sql, $cache )
 557   );
 558 }
 559
 560 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 561
 562 Same as qsearch, except that if more than one record matches, it B<carp>s but
 563 returns the first.  If this happens, you either made a logic error in asking
 564 for a single item, or your data is corrupted.
 565
 566 =cut
 567
 568 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
 569   my $table = $_[0];
 570   my(@result) = qsearch(@_);
 571   cluck "warning: Multiple records in scalar search ($table)"
 572     if scalar(@result) > 1;
 573   #should warn more vehemently if the search was on a primary key?
 574   scalar(@result) ? ($result[0]) : ();
 575 }
 576
 577 =back
 578
 579 =head1 METHODS
 580
 581 =over 4
 582
 583 =item table
 584
 585 Returns the table name.
 586
 587 =cut
 588
 589 sub table {
 590 #  cluck "warning: FS::Record::table deprecated; supply one in subclass!";
 591   my $self = shift;
 592   $self -> {'Table'};
 593 }
 594
 595 =item dbdef_table
 596
 597 Returns the DBIx::DBSchema::Table object for the table.
 598
 599 =cut
 600
 601 sub dbdef_table {
 602   my($self)=@_;
 603   my($table)=$self->table;
 604   dbdef->table($table);
 605 }
 606
 607 =item primary_key
 608
 609 Returns the primary key for the table.
 610
 611 =cut
 612
 613 sub primary_key {
 614   my $self = shift;
 615   my $pkey = $self->dbdef_table->primary_key;
 616 }
 617
 618 =item get, getfield COLUMN
 619
 620 Returns the value of the column/field/key COLUMN.
 621
 622 =cut
 623
 624 sub get {
 625   my($self,$field) = @_;
 626   # to avoid "Use of unitialized value" errors
 627   if ( defined ( $self->{Hash}->{$field} ) ) {
 628     $self->{Hash}->{$field};
 629   } else {
 630     '';
 631   }
 632 }
 633 sub getfield {
 634   my $self = shift;
 635   $self->get(@_);
 636 }
 637
 638 =item set, setfield COLUMN, VALUE
 639
 640 Sets the value of the column/field/key COLUMN to VALUE.  Returns VALUE.
 641
 642 =cut
 643
 644 sub set {
 645   my($self,$field,$value) = @_;
 646   $self->{'modified'} = 1;
 647   $self->{'Hash'}->{$field} = $value;
 648 }
 649 sub setfield {
 650   my $self = shift;
 651   $self->set(@_);
 652 }
 653
 654 =item AUTLOADED METHODS
 655
 656 $record->column is a synonym for $record->get('column');
 657
 658 $record->column('value') is a synonym for $record->set('column','value');
 659
 660 =cut
 661
 662 # readable/safe
 663 sub AUTOLOAD {
 664   my($self,$value)=@_;
 665   my($field)=$AUTOLOAD;
 666   $field =~ s/.*://;
 667   if ( defined($value) ) {
 668     confess "errant AUTOLOAD $field for $self (arg $value)"
 669       unless blessed($self) && $self->can('setfield');
 670     $self->setfield($field,$value);
 671   } else {
 672     confess "errant AUTOLOAD $field for $self (no args)"
 673       unless blessed($self) && $self->can('getfield');
 674     $self->getfield($field);
 675   }
 676 }
 677
 678 # efficient
 679 #sub AUTOLOAD {
 680 #  my $field = $AUTOLOAD;
 681 #  $field =~ s/.*://;
 682 #  if ( defined($_[1]) ) {
 683 #    $_[0]->setfield($field, $_[1]);
 684 #  } else {
 685 #    $_[0]->getfield($field);
 686 #  }
 687 #}
 688
 689 =item hash
 690
 691 Returns a list of the column/value pairs, usually for assigning to a new hash.
 692
 693 To make a distinct duplicate of an FS::Record object, you can do:
 694
 695     $new = new FS::Record ( $old->table, { $old->hash } );
 696
 697 =cut
 698
 699 sub hash {
 700   my($self) = @_;
 701   confess $self. ' -> hash: Hash attribute is undefined'
 702     unless defined($self->{'Hash'});
 703   %{ $self->{'Hash'} };
 704 }
 705
 706 =item hashref
 707
 708 Returns a reference to the column/value hash.  This may be deprecated in the
 709 future; if there's a reason you can't just use the autoloaded or get/set
 710 methods, speak up.
 711
 712 =cut
 713
 714 sub hashref {
 715   my($self) = @_;
 716   $self->{'Hash'};
 717 }
 718
 719 =item modified
 720
 721 Returns true if any of this object's values have been modified with set (or via
 722 an autoloaded method).  Doesn't yet recognize when you retreive a hashref and
 723 modify that.
 724
 725 =cut
 726
 727 sub modified {
 728   my $self = shift;
 729   $self->{'modified'};
 730 }
 731
 732 =item select_for_update
 733
 734 Selects this record with the SQL "FOR UPDATE" command.  This can be useful as
 735 a mutex.
 736
 737 =cut
 738
 739 sub select_for_update {
 740   my $self = shift;
 741   my $primary_key = $self->primary_key;
 742   qsearchs( {
 743     'select'    => '*',
 744     'table'     => $self->table,
 745     'hashref'   => { $primary_key => $self->$primary_key() },
 746     'extra_sql' => 'FOR UPDATE',
 747   } );
 748 }
 749
 750 =item insert
 751
 752 Inserts this record to the database.  If there is an error, returns the error,
 753 otherwise returns false.
 754
 755 =cut
 756
 757 sub insert {
 758   my $self = shift;
 759   my $saved = {};
 760
 761   warn "$self -> insert" if $DEBUG;
 762
 763   my $error = $self->check;
 764   return $error if $error;
 765
 766   #single-field unique keys are given a value if false
 767   #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
 768   foreach ( $self->dbdef_table->unique_singles) {
 769     $self->unique($_) unless $self->getfield($_);
 770   }
 771
 772   #and also the primary key, if the database isn't going to
 773   my $primary_key = $self->dbdef_table->primary_key;
 774   my $db_seq = 0;
 775   if ( $primary_key ) {
 776     my $col = $self->dbdef_table->column($primary_key);
 777
 778     $db_seq =
 779       uc($col->type) =~ /^(BIG)?SERIAL\d?/
 780       || ( driver_name eq 'Pg'
 781              && defined($col->default)
 782              && $col->default =~ /^nextval\(/i
 783          )
 784       || ( driver_name eq 'mysql'
 785              && defined($col->local)
 786              && $col->local =~ /AUTO_INCREMENT/i
 787          );
 788     $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
 789   }
 790
 791   my $table = $self->table;
 792
 793
 794   # Encrypt before the database
 795   if ($conf->exists('encryption') && defined(eval '@FS::'. $table . '::encrypted_fields')) {
 796     foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 797       $self->{'saved'} = $self->getfield($field);
 798       $self->setfield($field, $self->encrypt($self->getfield($field)));
 799     }
 800   }
 801
 802
 803   #false laziness w/delete
 804   my @real_fields =
 805     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
 806     real_fields($table)
 807   ;
 808   my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
 809   #eslaf
 810
 811   my $statement = "INSERT INTO $table ";
 812   if ( @real_fields ) {
 813     $statement .=
 814       "( ".
 815         join( ', ', @real_fields ).
 816       ") VALUES (".
 817         join( ', ', @values ).
 818        ")"
 819     ;
 820   } else {
 821     $statement .= 'DEFAULT VALUES';
 822   }
 823   warn "[debug]$me $statement\n" if $DEBUG > 1;
 824   my $sth = dbh->prepare($statement) or return dbh->errstr;
 825
 826   local $SIG{HUP} = 'IGNORE';
 827   local $SIG{INT} = 'IGNORE';
 828   local $SIG{QUIT} = 'IGNORE';
 829   local $SIG{TERM} = 'IGNORE';
 830   local $SIG{TSTP} = 'IGNORE';
 831   local $SIG{PIPE} = 'IGNORE';
 832
 833   $sth->execute or return $sth->errstr;
 834
 835   # get inserted id from the database, if applicable & needed
 836   if ( $db_seq && ! $self->getfield($primary_key) ) {
 837     warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
 838
 839     my $insertid = '';
 840
 841     if ( driver_name eq 'Pg' ) {
 842
 843       #my $oid = $sth->{'pg_oid_status'};
 844       #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
 845
 846       my $default = $self->dbdef_table->column($primary_key)->default;
 847       unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
 848         dbh->rollback if $FS::UID::AutoCommit;
 849         return "can't parse $table.$primary_key default value".
 850                " for sequence name: $default";
 851       }
 852       my $sequence = $1;
 853
 854       my $i_sql = "SELECT currval('$sequence')";
 855       my $i_sth = dbh->prepare($i_sql) or do {
 856         dbh->rollback if $FS::UID::AutoCommit;
 857         return dbh->errstr;
 858       };
 859       $i_sth->execute() or do { #$i_sth->execute($oid)
 860         dbh->rollback if $FS::UID::AutoCommit;
 861         return $i_sth->errstr;
 862       };
 863       $insertid = $i_sth->fetchrow_arrayref->[0];
 864
 865     } elsif ( driver_name eq 'mysql' ) {
 866
 867       $insertid = dbh->{'mysql_insertid'};
 868       # work around mysql_insertid being null some of the time, ala RT :/
 869       unless ( $insertid ) {
 870         warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
 871              "using SELECT LAST_INSERT_ID();";
 872         my $i_sql = "SELECT LAST_INSERT_ID()";
 873         my $i_sth = dbh->prepare($i_sql) or do {
 874           dbh->rollback if $FS::UID::AutoCommit;
 875           return dbh->errstr;
 876         };
 877         $i_sth->execute or do {
 878           dbh->rollback if $FS::UID::AutoCommit;
 879           return $i_sth->errstr;
 880         };
 881         $insertid = $i_sth->fetchrow_arrayref->[0];
 882       }
 883
 884     } else {
 885
 886       dbh->rollback if $FS::UID::AutoCommit;
 887       return "don't know how to retreive inserted ids from ". driver_name.
 888              ", try using counterfiles (maybe run dbdef-create?)";
 889
 890     }
 891
 892     $self->setfield($primary_key, $insertid);
 893
 894   }
 895
 896   my @virtual_fields =
 897       grep defined($self->getfield($_)) && $self->getfield($_) ne "",
 898           $self->virtual_fields;
 899   if (@virtual_fields) {
 900     my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
 901
 902     my $vfieldpart = $self->vfieldpart_hashref;
 903
 904     my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
 905                     "VALUES (?, ?, ?)";
 906
 907     my $v_sth = dbh->prepare($v_statement) or do {
 908       dbh->rollback if $FS::UID::AutoCommit;
 909       return dbh->errstr;
 910     };
 911
 912     foreach (keys(%v_values)) {
 913       $v_sth->execute($self->getfield($primary_key),
 914                       $vfieldpart->{$_},
 915                       $v_values{$_})
 916       or do {
 917         dbh->rollback if $FS::UID::AutoCommit;
 918         return $v_sth->errstr;
 919       };
 920     }
 921   }
 922
 923
 924   my $h_sth;
 925   if ( defined dbdef->table('h_'. $table) ) {
 926     my $h_statement = $self->_h_statement('insert');
 927     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
 928     $h_sth = dbh->prepare($h_statement) or do {
 929       dbh->rollback if $FS::UID::AutoCommit;
 930       return dbh->errstr;
 931     };
 932   } else {
 933     $h_sth = '';
 934   }
 935   $h_sth->execute or return $h_sth->errstr if $h_sth;
 936
 937   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 938
 939   # Now that it has been saved, reset the encrypted fields so that $new
 940   # can still be used.
 941   foreach my $field (keys %{$saved}) {
 942     $self->setfield($field, $saved->{$field});
 943   }
 944
 945   '';
 946 }
 947
 948 =item add
 949
 950 Depriciated (use insert instead).
 951
 952 =cut
 953
 954 sub add {
 955   cluck "warning: FS::Record::add deprecated!";
 956   insert @_; #call method in this scope
 957 }
 958
 959 =item delete
 960
 961 Delete this record from the database.  If there is an error, returns the error,
 962 otherwise returns false.
 963
 964 =cut
 965
 966 sub delete {
 967   my $self = shift;
 968
 969   my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
 970     map {
 971       $self->getfield($_) eq ''
 972         #? "( $_ IS NULL OR $_ = \"\" )"
 973         ? ( driver_name eq 'Pg'
 974               ? "$_ IS NULL"
 975               : "( $_ IS NULL OR $_ = \"\" )"
 976           )
 977         : "$_ = ". _quote($self->getfield($_),$self->table,$_)
 978     } ( $self->dbdef_table->primary_key )
 979           ? ( $self->dbdef_table->primary_key)
 980           : real_fields($self->table)
 981   );
 982   warn "[debug]$me $statement\n" if $DEBUG > 1;
 983   my $sth = dbh->prepare($statement) or return dbh->errstr;
 984
 985   my $h_sth;
 986   if ( defined dbdef->table('h_'. $self->table) ) {
 987     my $h_statement = $self->_h_statement('delete');
 988     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
 989     $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
 990   } else {
 991     $h_sth = '';
 992   }
 993
 994   my $primary_key = $self->dbdef_table->primary_key;
 995   my $v_sth;
 996   my @del_vfields;
 997   my $vfp = $self->vfieldpart_hashref;
 998   foreach($self->virtual_fields) {
 999     next if $self->getfield($_) eq '';
1000     unless(@del_vfields) {
1001       my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
1002       $v_sth = dbh->prepare($st) or return dbh->errstr;
1003     }
1004     push @del_vfields, $_;
1005   }
1006
1007   local $SIG{HUP} = 'IGNORE';
1008   local $SIG{INT} = 'IGNORE';
1009   local $SIG{QUIT} = 'IGNORE';
1010   local $SIG{TERM} = 'IGNORE';
1011   local $SIG{TSTP} = 'IGNORE';
1012   local $SIG{PIPE} = 'IGNORE';
1013
1014   my $rc = $sth->execute or return $sth->errstr;
1015   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1016   $h_sth->execute or return $h_sth->errstr if $h_sth;
1017   $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
1018     or return $v_sth->errstr
1019         foreach (@del_vfields);
1020
1021   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1022
1023   #no need to needlessly destoy the data either (causes problems actually)
1024   #undef $self; #no need to keep object!
1025
1026   '';
1027 }
1028
1029 =item del
1030
1031 Depriciated (use delete instead).
1032
1033 =cut
1034
1035 sub del {
1036   cluck "warning: FS::Record::del deprecated!";
1037   &delete(@_); #call method in this scope
1038 }
1039
1040 =item replace OLD_RECORD
1041
1042 Replace the OLD_RECORD with this one in the database.  If there is an error,
1043 returns the error, otherwise returns false.
1044
1045 =cut
1046
1047 sub replace {
1048   my ($new, $old) = (shift, shift);
1049
1050   $old = $new->replace_old unless defined($old);
1051
1052   warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1053
1054   if ( $new->can('replace_check') ) {
1055     my $error = $new->replace_check($old);
1056     return $error if $error;
1057   }
1058
1059   return "Records not in same table!" unless $new->table eq $old->table;
1060
1061   my $primary_key = $old->dbdef_table->primary_key;
1062   return "Can't change primary key $primary_key ".
1063          'from '. $old->getfield($primary_key).
1064          ' to ' . $new->getfield($primary_key)
1065     if $primary_key
1066        && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1067
1068   my $error = $new->check;
1069   return $error if $error;
1070
1071   # Encrypt for replace
1072   my $saved = {};
1073   if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) {
1074     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1075       $saved->{$field} = $new->getfield($field);
1076       $new->setfield($field, $new->encrypt($new->getfield($field)));
1077     }
1078   }
1079
1080   #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1081   my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1082                    ? ($_, $new->getfield($_)) : () } $old->fields;
1083
1084   unless (keys(%diff) || $no_update_diff ) {
1085     carp "[warning]$me $new -> replace $old: records identical"
1086       unless $nowarn_identical;
1087     return '';
1088   }
1089
1090   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1091     map {
1092       "$_ = ". _quote($new->getfield($_),$old->table,$_)
1093     } real_fields($old->table)
1094   ). ' WHERE '.
1095     join(' AND ',
1096       map {
1097
1098         if ( $old->getfield($_) eq '' ) {
1099
1100          #false laziness w/qsearch
1101          if ( driver_name eq 'Pg' ) {
1102             my $type = $old->dbdef_table->column($_)->type;
1103             if ( $type =~ /(int|(big)?serial)/i ) {
1104               qq-( $_ IS NULL )-;
1105             } else {
1106               qq-( $_ IS NULL OR $_ = '' )-;
1107             }
1108           } else {
1109             qq-( $_ IS NULL OR $_ = "" )-;
1110           }
1111
1112         } else {
1113           "$_ = ". _quote($old->getfield($_),$old->table,$_);
1114         }
1115
1116       } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1117     )
1118   ;
1119   warn "[debug]$me $statement\n" if $DEBUG > 1;
1120   my $sth = dbh->prepare($statement) or return dbh->errstr;
1121
1122   my $h_old_sth;
1123   if ( defined dbdef->table('h_'. $old->table) ) {
1124     my $h_old_statement = $old->_h_statement('replace_old');
1125     warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1126     $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1127   } else {
1128     $h_old_sth = '';
1129   }
1130
1131   my $h_new_sth;
1132   if ( defined dbdef->table('h_'. $new->table) ) {
1133     my $h_new_statement = $new->_h_statement('replace_new');
1134     warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1135     $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1136   } else {
1137     $h_new_sth = '';
1138   }
1139
1140   # For virtual fields we have three cases with different SQL
1141   # statements: add, replace, delete
1142   my $v_add_sth;
1143   my $v_rep_sth;
1144   my $v_del_sth;
1145   my (@add_vfields, @rep_vfields, @del_vfields);
1146   my $vfp = $old->vfieldpart_hashref;
1147   foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
1148     if($diff{$_} eq '') {
1149       # Delete
1150       unless(@del_vfields) {
1151         my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
1152                  "AND vfieldpart = ?";
1153         warn "[debug]$me $st\n" if $DEBUG > 2;
1154         $v_del_sth = dbh->prepare($st) or return dbh->errstr;
1155       }
1156       push @del_vfields, $_;
1157     } elsif($old->getfield($_) eq '') {
1158       # Add
1159       unless(@add_vfields) {
1160         my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
1161                  "VALUES (?, ?, ?)";
1162         warn "[debug]$me $st\n" if $DEBUG > 2;
1163         $v_add_sth = dbh->prepare($st) or return dbh->errstr;
1164       }
1165       push @add_vfields, $_;
1166     } else {
1167       # Replace
1168       unless(@rep_vfields) {
1169         my $st = "UPDATE virtual_field SET value = ? ".
1170                  "WHERE recnum = ? AND vfieldpart = ?";
1171         warn "[debug]$me $st\n" if $DEBUG > 2;
1172         $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
1173       }
1174       push @rep_vfields, $_;
1175     }
1176   }
1177
1178   local $SIG{HUP} = 'IGNORE';
1179   local $SIG{INT} = 'IGNORE';
1180   local $SIG{QUIT} = 'IGNORE';
1181   local $SIG{TERM} = 'IGNORE';
1182   local $SIG{TSTP} = 'IGNORE';
1183   local $SIG{PIPE} = 'IGNORE';
1184
1185   my $rc = $sth->execute or return $sth->errstr;
1186   #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1187   $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1188   $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1189
1190   $v_del_sth->execute($old->getfield($primary_key),
1191                       $vfp->{$_})
1192         or return $v_del_sth->errstr
1193       foreach(@del_vfields);
1194
1195   $v_add_sth->execute($new->getfield($_),
1196                       $old->getfield($primary_key),
1197                       $vfp->{$_})
1198         or return $v_add_sth->errstr
1199       foreach(@add_vfields);
1200
1201   $v_rep_sth->execute($new->getfield($_),
1202                       $old->getfield($primary_key),
1203                       $vfp->{$_})
1204         or return $v_rep_sth->errstr
1205       foreach(@rep_vfields);
1206
1207   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1208
1209   # Now that it has been saved, reset the encrypted fields so that $new
1210   # can still be used.
1211   foreach my $field (keys %{$saved}) {
1212     $new->setfield($field, $saved->{$field});
1213   }
1214
1215   '';
1216
1217 }
1218
1219 sub replace_old {
1220   my( $self ) = shift;
1221   warn "[$me] replace called with no arguments; autoloading old record\n"
1222     if $DEBUG;
1223
1224   my $primary_key = $self->dbdef_table->primary_key;
1225   if ( $primary_key ) {
1226     $self->by_key( $self->$primary_key() ) #this is what's returned
1227       or croak "can't find ". $self->table. ".$primary_key ".
1228         $self->$primary_key();
1229   } else {
1230     croak $self->table. " has no primary key; pass old record as argument";
1231   }
1232
1233 }
1234
1235 =item rep
1236
1237 Depriciated (use replace instead).
1238
1239 =cut
1240
1241 sub rep {
1242   cluck "warning: FS::Record::rep deprecated!";
1243   replace @_; #call method in this scope
1244 }
1245
1246 =item check
1247
1248 Checks virtual fields (using check_blocks).  Subclasses should still provide
1249 a check method to validate real fields, foreign keys, etc., and call this
1250 method via $self->SUPER::check.
1251
1252 (FIXME: Should this method try to make sure that it I<is> being called from
1253 a subclass's check method, to keep the current semantics as far as possible?)
1254
1255 =cut
1256
1257 sub check {
1258   #confess "FS::Record::check not implemented; supply one in subclass!";
1259   my $self = shift;
1260
1261   foreach my $field ($self->virtual_fields) {
1262     for ($self->getfield($field)) {
1263       # See notes on check_block in FS::part_virtual_field.
1264       eval $self->pvf($field)->check_block;
1265       if ( $@ ) {
1266         #this is bad, probably want to follow the stack backtrace up and see
1267         #wtf happened
1268         my $err = "Fatal error checking $field for $self";
1269         cluck "$err: $@";
1270         return "$err (see log for backtrace): $@";
1271
1272       }
1273       $self->setfield($field, $_);
1274     }
1275   }
1276   '';
1277 }
1278
1279 sub _h_statement {
1280   my( $self, $action, $time ) = @_;
1281
1282   $time ||= time;
1283
1284   my @fields =
1285     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1286     real_fields($self->table);
1287   ;
1288
1289   # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1290   # You can see if it changed by the paymask...
1291   if ($conf->exists('encryption') ) {
1292     @fields = grep  $_ ne 'payinfo' && $_ ne 'cvv2', @fields;
1293   }
1294   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1295
1296   "INSERT INTO h_". $self->table. " ( ".
1297       join(', ', qw(history_date history_user history_action), @fields ).
1298     ") VALUES (".
1299       join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1300     ")"
1301   ;
1302 }
1303
1304 =item unique COLUMN
1305
1306 B<Warning>: External use is B<deprecated>.
1307
1308 Replaces COLUMN in record with a unique number, using counters in the
1309 filesystem.  Used by the B<insert> method on single-field unique columns
1310 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1311 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1312
1313 Returns the new value.
1314
1315 =cut
1316
1317 sub unique {
1318   my($self,$field) = @_;
1319   my($table)=$self->table;
1320
1321   croak "Unique called on field $field, but it is ",
1322         $self->getfield($field),
1323         ", not null!"
1324     if $self->getfield($field);
1325
1326   #warn "table $table is tainted" if is_tainted($table);
1327   #warn "field $field is tainted" if is_tainted($field);
1328
1329   my($counter) = new File::CounterFile "$table.$field",0;
1330 # hack for web demo
1331 #  getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1332 #  my($user)=$1;
1333 #  my($counter) = new File::CounterFile "$user/$table.$field",0;
1334 # endhack
1335
1336   my $index = $counter->inc;
1337   $index = $counter->inc while qsearchs($table, { $field=>$index } );
1338
1339   $index =~ /^(\d*)$/;
1340   $index=$1;
1341
1342   $self->setfield($field,$index);
1343
1344 }
1345
1346 =item ut_float COLUMN
1347
1348 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
1349 null.  If there is an error, returns the error, otherwise returns false.
1350
1351 =cut
1352
1353 sub ut_float {
1354   my($self,$field)=@_ ;
1355   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
1356    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
1357    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
1358    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
1359     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1360   $self->setfield($field,$1);
1361   '';
1362 }
1363 =item ut_floatn COLUMN
1364
1365 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1366 null.  If there is an error, returns the error, otherwise returns false.
1367
1368 =cut
1369
1370 #false laziness w/ut_ipn
1371 sub ut_floatn {
1372   my( $self, $field ) = @_;
1373   if ( $self->getfield($field) =~ /^()$/ ) {
1374     $self->setfield($field,'');
1375     '';
1376   } else {
1377     $self->ut_float($field);
1378   }
1379 }
1380
1381 =item ut_sfloat COLUMN
1382
1383 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1384 May not be null.  If there is an error, returns the error, otherwise returns
1385 false.
1386
1387 =cut
1388
1389 sub ut_sfloat {
1390   my($self,$field)=@_ ;
1391   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
1392    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
1393    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
1394    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
1395     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1396   $self->setfield($field,$1);
1397   '';
1398 }
1399 =item ut_sfloatn COLUMN
1400
1401 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1402 null.  If there is an error, returns the error, otherwise returns false.
1403
1404 =cut
1405
1406 sub ut_sfloatn {
1407   my( $self, $field ) = @_;
1408   if ( $self->getfield($field) =~ /^()$/ ) {
1409     $self->setfield($field,'');
1410     '';
1411   } else {
1412     $self->ut_sfloat($field);
1413   }
1414 }
1415
1416 =item ut_snumber COLUMN
1417
1418 Check/untaint signed numeric data (whole numbers).  If there is an error,
1419 returns the error, otherwise returns false.
1420
1421 =cut
1422
1423 sub ut_snumber {
1424   my($self, $field) = @_;
1425   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
1426     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1427   $self->setfield($field, "$1$2");
1428   '';
1429 }
1430
1431 =item ut_snumbern COLUMN
1432
1433 Check/untaint signed numeric data (whole numbers).  If there is an error,
1434 returns the error, otherwise returns false.
1435
1436 =cut
1437
1438 sub ut_snumbern {
1439   my($self, $field) = @_;
1440   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
1441     or return "Illegal (numeric) $field: ". $self->getfield($field);
1442   if ($1) {
1443     return "Illegal (numeric) $field: ". $self->getfield($field)
1444       unless $2;
1445   }
1446   $self->setfield($field, "$1$2");
1447   '';
1448 }
1449
1450 =item ut_number COLUMN
1451
1452 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
1453 is an error, returns the error, otherwise returns false.
1454
1455 =cut
1456
1457 sub ut_number {
1458   my($self,$field)=@_;
1459   $self->getfield($field) =~ /^\s*(\d+)\s*$/
1460     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1461   $self->setfield($field,$1);
1462   '';
1463 }
1464
1465 =item ut_numbern COLUMN
1466
1467 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
1468 an error, returns the error, otherwise returns false.
1469
1470 =cut
1471
1472 sub ut_numbern {
1473   my($self,$field)=@_;
1474   $self->getfield($field) =~ /^\s*(\d*)\s*$/
1475     or return "Illegal (numeric) $field: ". $self->getfield($field);
1476   $self->setfield($field,$1);
1477   '';
1478 }
1479
1480 =item ut_money COLUMN
1481
1482 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
1483 is an error, returns the error, otherwise returns false.
1484
1485 =cut
1486
1487 sub ut_money {
1488   my($self,$field)=@_;
1489   $self->setfield($field, 0) if $self->getfield($field) eq '';
1490   $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/
1491     or return "Illegal (money) $field: ". $self->getfield($field);
1492   #$self->setfield($field, "$1$2$3" || 0);
1493   $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
1494   '';
1495 }
1496
1497 =item ut_text COLUMN
1498
1499 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
1500 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ]
1501 May not be null.  If there is an error, returns the error, otherwise returns
1502 false.
1503
1504 =cut
1505
1506 sub ut_text {
1507   my($self,$field)=@_;
1508   #warn "msgcat ". \&msgcat. "\n";
1509   #warn "notexist ". \&notexist. "\n";
1510   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
1511   $self->getfield($field)
1512     =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/
1513       or return gettext('illegal_or_empty_text'). " $field: ".
1514                  $self->getfield($field);
1515   $self->setfield($field,$1);
1516   '';
1517 }
1518
1519 =item ut_textn COLUMN
1520
1521 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
1522 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
1523 May be null.  If there is an error, returns the error, otherwise returns false.
1524
1525 =cut
1526
1527 sub ut_textn {
1528   my($self,$field)=@_;
1529   $self->getfield($field)
1530     =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/
1531       or return gettext('illegal_text'). " $field: ". $self->getfield($field);
1532   $self->setfield($field,$1);
1533   '';
1534 }
1535
1536 =item ut_alpha COLUMN
1537
1538 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
1539 an error, returns the error, otherwise returns false.
1540
1541 =cut
1542
1543 sub ut_alpha {
1544   my($self,$field)=@_;
1545   $self->getfield($field) =~ /^(\w+)$/
1546     or return "Illegal or empty (alphanumeric) $field: ".
1547               $self->getfield($field);
1548   $self->setfield($field,$1);
1549   '';
1550 }
1551
1552 =item ut_alpha COLUMN
1553
1554 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
1555 error, returns the error, otherwise returns false.
1556
1557 =cut
1558
1559 sub ut_alphan {
1560   my($self,$field)=@_;
1561   $self->getfield($field) =~ /^(\w*)$/
1562     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
1563   $self->setfield($field,$1);
1564   '';
1565 }
1566
1567 =item ut_alpha_lower COLUMN
1568
1569 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
1570 there is an error, returns the error, otherwise returns false.
1571
1572 =cut
1573
1574 sub ut_alpha_lower {
1575   my($self,$field)=@_;
1576   $self->getfield($field) =~ /[[:upper:]]/
1577     and return "Uppercase characters are not permitted in $field";
1578   $self->ut_alpha($field);
1579 }
1580
1581 =item ut_phonen COLUMN [ COUNTRY ]
1582
1583 Check/untaint phone numbers.  May be null.  If there is an error, returns
1584 the error, otherwise returns false.
1585
1586 Takes an optional two-letter ISO country code; without it or with unsupported
1587 countries, ut_phonen simply calls ut_alphan.
1588
1589 =cut
1590
1591 sub ut_phonen {
1592   my( $self, $field, $country ) = @_;
1593   return $self->ut_alphan($field) unless defined $country;
1594   my $phonen = $self->getfield($field);
1595   if ( $phonen eq '' ) {
1596     $self->setfield($field,'');
1597   } elsif ( $country eq 'US' || $country eq 'CA' ) {
1598     $phonen =~ s/\D//g;
1599     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
1600       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
1601     $phonen = "$1-$2-$3";
1602     $phonen .= " x$4" if $4;
1603     $self->setfield($field,$phonen);
1604   } else {
1605     warn "warning: don't know how to check phone numbers for country $country";
1606     return $self->ut_textn($field);
1607   }
1608   '';
1609 }
1610
1611 =item ut_hex COLUMN
1612
1613 Check/untaint hexadecimal values.
1614
1615 =cut
1616
1617 sub ut_hex {
1618   my($self, $field) = @_;
1619   $self->getfield($field) =~ /^([\da-fA-F]+)$/
1620     or return "Illegal (hex) $field: ". $self->getfield($field);
1621   $self->setfield($field, uc($1));
1622   '';
1623 }
1624
1625 =item ut_hexn COLUMN
1626
1627 Check/untaint hexadecimal values.  May be null.
1628
1629 =cut
1630
1631 sub ut_hexn {
1632   my($self, $field) = @_;
1633   $self->getfield($field) =~ /^([\da-fA-F]*)$/
1634     or return "Illegal (hex) $field: ". $self->getfield($field);
1635   $self->setfield($field, uc($1));
1636   '';
1637 }
1638 =item ut_ip COLUMN
1639
1640 Check/untaint ip addresses.  IPv4 only for now.
1641
1642 =cut
1643
1644 sub ut_ip {
1645   my( $self, $field ) = @_;
1646   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
1647     or return "Illegal (IP address) $field: ". $self->getfield($field);
1648   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
1649   $self->setfield($field, "$1.$2.$3.$4");
1650   '';
1651 }
1652
1653 =item ut_ipn COLUMN
1654
1655 Check/untaint ip addresses.  IPv4 only for now.  May be null.
1656
1657 =cut
1658
1659 sub ut_ipn {
1660   my( $self, $field ) = @_;
1661   if ( $self->getfield($field) =~ /^()$/ ) {
1662     $self->setfield($field,'');
1663     '';
1664   } else {
1665     $self->ut_ip($field);
1666   }
1667 }
1668
1669 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
1670
1671 Check/untaint coordinates.
1672 Accepts the following forms:
1673 DDD.DDDDD
1674 -DDD.DDDDD
1675 DDD MM.MMM
1676 -DDD MM.MMM
1677 DDD MM SS
1678 -DDD MM SS
1679 DDD MM MMM
1680 -DDD MM MMM
1681
1682 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
1683 The latter form (that is, the MMM are thousands of minutes) is
1684 assumed if the "MMM" is exactly three digits or two digits > 59.
1685
1686 To be safe, just use the DDD.DDDDD form.
1687
1688 If LOWER or UPPER are specified, then the coordinate is checked
1689 for lower and upper bounds, respectively.
1690
1691 =cut
1692
1693 sub ut_coord {
1694
1695   my ($self, $field) = (shift, shift);
1696
1697   my $lower = shift if scalar(@_);
1698   my $upper = shift if scalar(@_);
1699   my $coord = $self->getfield($field);
1700   my $neg = $coord =~ s/^(-)//;
1701
1702   my ($d, $m, $s) = (0, 0, 0);
1703
1704   if (
1705     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
1706     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
1707     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
1708   ) {
1709     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
1710     $m = $m / 60;
1711     if ($m > 59) {
1712       return "Invalid (coordinate with minutes > 59) $field: "
1713              . $self->getfield($field);
1714     }
1715
1716     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
1717
1718     if (defined($lower) and ($coord < $lower)) {
1719       return "Invalid (coordinate < $lower) $field: "
1720              . $self->getfield($field);;
1721     }
1722
1723     if (defined($upper) and ($coord > $upper)) {
1724       return "Invalid (coordinate > $upper) $field: "
1725              . $self->getfield($field);;
1726     }
1727
1728     $self->setfield($field, $coord);
1729     return '';
1730   }
1731
1732   return "Invalid (coordinate) $field: " . $self->getfield($field);
1733
1734 }
1735
1736 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
1737
1738 Same as ut_coord, except optionally null.
1739
1740 =cut
1741
1742 sub ut_coordn {
1743
1744   my ($self, $field) = (shift, shift);
1745
1746   if ($self->getfield($field) =~ /^$/) {
1747     return '';
1748   } else {
1749     return $self->ut_coord($field, @_);
1750   }
1751
1752 }
1753
1754
1755 =item ut_domain COLUMN
1756
1757 Check/untaint host and domain names.
1758
1759 =cut
1760
1761 sub ut_domain {
1762   my( $self, $field ) = @_;
1763   #$self->getfield($field) =~/^(\w+\.)*\w+$/
1764   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
1765     or return "Illegal (domain) $field: ". $self->getfield($field);
1766   $self->setfield($field,$1);
1767   '';
1768 }
1769
1770 =item ut_name COLUMN
1771
1772 Check/untaint proper names; allows alphanumerics, spaces and the following
1773 punctuation: , . - '
1774
1775 May not be null.
1776
1777 =cut
1778
1779 sub ut_name {
1780   my( $self, $field ) = @_;
1781   $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
1782     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
1783   $self->setfield($field,$1);
1784   '';
1785 }
1786
1787 =item ut_zip COLUMN
1788
1789 Check/untaint zip codes.
1790
1791 =cut
1792
1793 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
1794
1795 sub ut_zip {
1796   my( $self, $field, $country ) = @_;
1797
1798   if ( $country eq 'US' ) {
1799
1800     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
1801       or return gettext('illegal_zip'). " $field for country $country: ".
1802                 $self->getfield($field);
1803     $self->setfield($field, $1);
1804
1805   } elsif ( $country eq 'CA' ) {
1806
1807     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
1808       or return gettext('illegal_zip'). " $field for country $country: ".
1809                 $self->getfield($field);
1810     $self->setfield($field, "$1 $2");
1811
1812   } else {
1813
1814     if ( $self->getfield($field) =~ /^\s*$/
1815          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
1816        )
1817     {
1818       $self->setfield($field,'');
1819     } else {
1820       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
1821         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
1822       $self->setfield($field,$1);
1823     }
1824
1825   }
1826
1827   '';
1828 }
1829
1830 =item ut_country COLUMN
1831
1832 Check/untaint country codes.  Country names are changed to codes, if possible -
1833 see L<Locale::Country>.
1834
1835 =cut
1836
1837 sub ut_country {
1838   my( $self, $field ) = @_;
1839   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
1840     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
1841          && country2code($1) ) {
1842       $self->setfield($field,uc(country2code($1)));
1843     }
1844   }
1845   $self->getfield($field) =~ /^(\w\w)$/
1846     or return "Illegal (country) $field: ". $self->getfield($field);
1847   $self->setfield($field,uc($1));
1848   '';
1849 }
1850
1851 =item ut_anything COLUMN
1852
1853 Untaints arbitrary data.  Be careful.
1854
1855 =cut
1856
1857 sub ut_anything {
1858   my( $self, $field ) = @_;
1859   $self->getfield($field) =~ /^(.*)$/s
1860     or return "Illegal $field: ". $self->getfield($field);
1861   $self->setfield($field,$1);
1862   '';
1863 }
1864
1865 =item ut_enum COLUMN CHOICES_ARRAYREF
1866
1867 Check/untaint a column, supplying all possible choices, like the "enum" type.
1868
1869 =cut
1870
1871 sub ut_enum {
1872   my( $self, $field, $choices ) = @_;
1873   foreach my $choice ( @$choices ) {
1874     if ( $self->getfield($field) eq $choice ) {
1875       $self->setfield($choice);
1876       return '';
1877     }
1878   }
1879   return "Illegal (enum) field $field: ". $self->getfield($field);
1880 }
1881
1882 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
1883
1884 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
1885 on the column first.
1886
1887 =cut
1888
1889 sub ut_foreign_key {
1890   my( $self, $field, $table, $foreign ) = @_;
1891   qsearchs($table, { $foreign => $self->getfield($field) })
1892     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
1893               " in $table.$foreign";
1894   '';
1895 }
1896
1897 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
1898
1899 Like ut_foreign_key, except the null value is also allowed.
1900
1901 =cut
1902
1903 sub ut_foreign_keyn {
1904   my( $self, $field, $table, $foreign ) = @_;
1905   $self->getfield($field)
1906     ? $self->ut_foreign_key($field, $table, $foreign)
1907     : '';
1908 }
1909
1910 =item ut_agentnum_acl
1911
1912 Checks this column as an agentnum, taking into account the current users's
1913 ACLs.
1914
1915 =cut
1916
1917 sub ut_agentnum_acl {
1918   my( $self, $field, $null_acl ) = @_;
1919
1920   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
1921   return "Illegal agentnum: $error" if $error;
1922
1923   my $curuser = $FS::CurrentUser::CurrentUser;
1924
1925   if ( $self->$field() ) {
1926
1927     return "Access denied"
1928       unless $curuser->agentnum($self->$field());
1929
1930   } else {
1931
1932     return "Access denied"
1933       unless $curuser->access_right($null_acl);
1934
1935   }
1936
1937   '';
1938
1939 }
1940
1941 =item virtual_fields [ TABLE ]
1942
1943 Returns a list of virtual fields defined for the table.  This should not
1944 be exported, and should only be called as an instance or class method.
1945
1946 =cut
1947
1948 sub virtual_fields {
1949   my $self = shift;
1950   my $table;
1951   $table = $self->table or confess "virtual_fields called on non-table";
1952
1953   confess "Unknown table $table" unless dbdef->table($table);
1954
1955   return () unless dbdef->table('part_virtual_field');
1956
1957   unless ( $virtual_fields_cache{$table} ) {
1958     my $query = 'SELECT name from part_virtual_field ' .
1959                 "WHERE dbtable = '$table'";
1960     my $dbh = dbh;
1961     my $result = $dbh->selectcol_arrayref($query);
1962     confess "Error executing virtual fields query: $query: ". $dbh->errstr
1963       if $dbh->err;
1964     $virtual_fields_cache{$table} = $result;
1965   }
1966
1967   @{$virtual_fields_cache{$table}};
1968
1969 }
1970
1971
1972 =item fields [ TABLE ]
1973
1974 This is a wrapper for real_fields and virtual_fields.  Code that called
1975 fields before should probably continue to call fields.
1976
1977 =cut
1978
1979 sub fields {
1980   my $something = shift;
1981   my $table;
1982   if($something->isa('FS::Record')) {
1983     $table = $something->table;
1984   } else {
1985     $table = $something;
1986     $something = "FS::$table";
1987   }
1988   return (real_fields($table), $something->virtual_fields());
1989 }
1990
1991 =item pvf FIELD_NAME
1992
1993 Returns the FS::part_virtual_field object corresponding to a field in the
1994 record (specified by FIELD_NAME).
1995
1996 =cut
1997
1998 sub pvf {
1999   my ($self, $name) = (shift, shift);
2000
2001   if(grep /^$name$/, $self->virtual_fields) {
2002     return qsearchs('part_virtual_field', { dbtable => $self->table,
2003                                             name    => $name } );
2004   }
2005   ''
2006 }
2007
2008 =item vfieldpart_hashref TABLE
2009
2010 Returns a hashref of virtual field names and vfieldparts applicable to the given
2011 TABLE.
2012
2013 =cut
2014
2015 sub vfieldpart_hashref {
2016   my $self = shift;
2017   my $table = $self->table;
2018
2019   return {} unless dbdef->table('part_virtual_field');
2020
2021   my $dbh = dbh;
2022   my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
2023                   "dbtable = '$table'";
2024   my $sth = $dbh->prepare($statement);
2025   $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
2026   return { map { $_->{name}, $_->{vfieldpart} }
2027     @{$sth->fetchall_arrayref({})} };
2028
2029 }
2030
2031 =item encrypt($value)
2032
2033 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2034
2035 Returns the encrypted string.
2036
2037 You should generally not have to worry about calling this, as the system handles this for you.
2038
2039 =cut
2040
2041 sub encrypt {
2042   my ($self, $value) = @_;
2043   my $encrypted;
2044
2045   if ($conf->exists('encryption')) {
2046     if ($self->is_encrypted($value)) {
2047       # Return the original value if it isn't plaintext.
2048       $encrypted = $value;
2049     } else {
2050       $self->loadRSA;
2051       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2052         # RSA doesn't like the empty string so let's pack it up
2053         # The database doesn't like the RSA data so uuencode it
2054         my $length = length($value)+1;
2055         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2056       } else {
2057         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2058       }
2059     }
2060   }
2061   return $encrypted;
2062 }
2063
2064 =item is_encrypted($value)
2065
2066 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2067
2068 =cut
2069
2070
2071 sub is_encrypted {
2072   my ($self, $value) = @_;
2073   # Possible Bug - Some work may be required here....
2074
2075   if ($value =~ /^M/ && length($value) > 80) {
2076     return 1;
2077   } else {
2078     return 0;
2079   }
2080 }
2081
2082 =item decrypt($value)
2083
2084 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2085
2086 You should generally not have to worry about calling this, as the system handles this for you.
2087
2088 =cut
2089
2090 sub decrypt {
2091   my ($self,$value) = @_;
2092   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2093   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2094     $self->loadRSA;
2095     if (ref($rsa_decrypt) =~ /::RSA/) {
2096       my $encrypted = unpack ("u*", $value);
2097       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2098       if ($@) {warn "Decryption Failed"};
2099     }
2100   }
2101   return $decrypted;
2102 }
2103
2104 sub loadRSA {
2105     my $self = shift;
2106     #Initialize the Module
2107     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2108
2109     if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') {
2110       $rsa_module = $conf->config('encryptionmodule');
2111     }
2112
2113     if (!$rsa_loaded) {
2114         eval ("require $rsa_module"); # No need to import the namespace
2115         $rsa_loaded++;
2116     }
2117     # Initialize Encryption
2118     if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') {
2119       my $public_key = join("\n",$conf->config('encryptionpublickey'));
2120       $rsa_encrypt = $rsa_module->new_public_key($public_key);
2121     }
2122
2123     # Intitalize Decryption
2124     if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') {
2125       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2126       $rsa_decrypt = $rsa_module->new_private_key($private_key);
2127     }
2128 }
2129
2130 =item h_search ACTION
2131
2132 Given an ACTION, either "insert", or "delete", returns the appropriate history
2133 record corresponding to this record, if any.
2134
2135 =cut
2136
2137 sub h_search {
2138   my( $self, $action ) = @_;
2139
2140   my $table = $self->table;
2141   $table =~ s/^h_//;
2142
2143   my $primary_key = dbdef->table($table)->primary_key;
2144
2145   qsearchs({
2146     'table'   => "h_$table",
2147     'hashref' => { $primary_key     => $self->$primary_key(),
2148                    'history_action' => $action,
2149                  },
2150   });
2151
2152 }
2153
2154 =item h_date ACTION
2155
2156 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2157 appropriate history record corresponding to this record, if any.
2158
2159 =cut
2160
2161 sub h_date {
2162   my($self, $action) = @_;
2163   my $h = $self->h_search($action);
2164   $h ? $h->history_date : '';
2165 }
2166
2167 =back
2168
2169 =head1 SUBROUTINES
2170
2171 =over 4
2172
2173 =item real_fields [ TABLE ]
2174
2175 Returns a list of the real columns in the specified table.  Called only by
2176 fields() and other subroutines elsewhere in FS::Record.
2177
2178 =cut
2179
2180 sub real_fields {
2181   my $table = shift;
2182
2183   my($table_obj) = dbdef->table($table);
2184   confess "Unknown table $table" unless $table_obj;
2185   $table_obj->columns;
2186 }
2187
2188 =item _quote VALUE, TABLE, COLUMN
2189
2190 This is an internal function used to construct SQL statements.  It returns
2191 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2192 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2193
2194 =cut
2195
2196 sub _quote {
2197   my($value, $table, $column) = @_;
2198   my $column_obj = dbdef->table($table)->column($column);
2199   my $column_type = $column_obj->type;
2200   my $nullable = $column_obj->null;
2201
2202   warn "  $table.$column: $value ($column_type".
2203        ( $nullable ? ' NULL' : ' NOT NULL' ).
2204        ")\n" if $DEBUG > 2;
2205
2206   if ( $value eq '' && $nullable ) {
2207     'NULL'
2208   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2209     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2210           "using 0 instead";
2211     0;
2212   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2213             ! $column_type =~ /(char|binary|text)$/i ) {
2214     $value;
2215   } else {
2216     dbh->quote($value);
2217   }
2218 }
2219
2220 =item hfields TABLE
2221
2222 This is deprecated.  Don't use it.
2223
2224 It returns a hash-type list with the fields of this record's table set true.
2225
2226 =cut
2227
2228 sub hfields {
2229   carp "warning: hfields is deprecated";
2230   my($table)=@_;
2231   my(%hash);
2232   foreach (fields($table)) {
2233     $hash{$_}=1;
2234   }
2235   \%hash;
2236 }
2237
2238 sub _dump {
2239   my($self)=@_;
2240   join("\n", map {
2241     "$_: ". $self->getfield($_). "|"
2242   } (fields($self->table)) );
2243 }
2244
2245 sub DESTROY { return; }
2246
2247 #sub DESTROY {
2248 #  my $self = shift;
2249 #  #use Carp qw(cluck);
2250 #  #cluck "DESTROYING $self";
2251 #  warn "DESTROYING $self";
2252 #}
2253
2254 #sub is_tainted {
2255 #             return ! eval { join('',@_), kill 0; 1; };
2256 #         }
2257
2258 =item str2time_sql [ DRIVER_NAME ]
2259
2260 Returns a function to convert to unix time based on database type, such as
2261 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
2262 the str2time_sql_closing method to return a closing string rather than just
2263 using a closing parenthesis as previously suggested.
2264
2265 You can pass an optional driver name such as "Pg", "mysql" or
2266 $dbh->{Driver}->{Name} to return a function for that database instead of
2267 the current database.
2268
2269 =cut
2270
2271 sub str2time_sql {
2272   my $driver = shift || driver_name;
2273
2274   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
2275   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
2276
2277   warn "warning: unknown database type $driver; guessing how to convert ".
2278        "dates to UNIX timestamps";
2279   return 'EXTRACT(EPOCH FROM ';
2280
2281 }
2282
2283 =item str2time_sql_closing [ DRIVER_NAME ]
2284
2285 Returns the closing suffix of a function to convert to unix time based on
2286 database type, such as ")::integer" for Pg or ")" for mysql.
2287
2288 You can pass an optional driver name such as "Pg", "mysql" or
2289 $dbh->{Driver}->{Name} to return a function for that database instead of
2290 the current database.
2291
2292 =cut
2293
2294 sub str2time_sql_closing {
2295   my $driver = shift || driver_name;
2296
2297   return ' )::INTEGER ' if $driver =~ /^Pg/i;
2298   return ' ) ';
2299 }
2300
2301 =back
2302
2303 =head1 BUGS
2304
2305 This module should probably be renamed, since much of the functionality is
2306 of general use.  It is not completely unlike Adapter::DBI (see below).
2307
2308 Exported qsearch and qsearchs should be deprecated in favor of method calls
2309 (against an FS::Record object like the old search and searchs that qsearch
2310 and qsearchs were on top of.)
2311
2312 The whole fields / hfields mess should be removed.
2313
2314 The various WHERE clauses should be subroutined.
2315
2316 table string should be deprecated in favor of DBIx::DBSchema::Table.
2317
2318 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
2319 true maps to the database (and WHERE clauses) would also help.
2320
2321 The ut_ methods should ask the dbdef for a default length.
2322
2323 ut_sqltype (like ut_varchar) should all be defined
2324
2325 A fallback check method should be provided which uses the dbdef.
2326
2327 The ut_money method assumes money has two decimal digits.
2328
2329 The Pg money kludge in the new method only strips `$'.
2330
2331 The ut_phonen method only checks US-style phone numbers.
2332
2333 The _quote function should probably use ut_float instead of a regex.
2334
2335 All the subroutines probably should be methods, here or elsewhere.
2336
2337 Probably should borrow/use some dbdef methods where appropriate (like sub
2338 fields)
2339
2340 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
2341 or allow it to be set.  Working around it is ugly any way around - DBI should
2342 be fixed.  (only affects RDBMS which return uppercase column names)
2343
2344 ut_zip should take an optional country like ut_phone.
2345
2346 =head1 SEE ALSO
2347
2348 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
2349
2350 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
2351
2352 http://poop.sf.net/
2353
2354 =cut
2355
2356 1;
2357