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