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