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