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