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