FS/FS/Record.pm

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