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; #dependency loop bs, in install_callback below instead
  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                 str2time_sql str2time_sql_closing );
  29
  30 $DEBUG = 0;
  31 $me = '[FS::Record]';
  32
  33 $nowarn_identical = 0;
  34 $no_update_diff = 0;
  35
  36 my $rsa_module;
  37 my $rsa_loaded;
  38 my $rsa_encrypt;
  39 my $rsa_decrypt;
  40
  41 FS::UID->install_callback( sub {
  42   eval "use FS::Conf;";
  43   die $@ if $@;
  44   $conf = new FS::Conf;
  45   $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
  46 } );
  47
  48
  49 =head1 NAME
  50
  51 FS::Record - Database record objects
  52
  53 =head1 SYNOPSIS
  54
  55     use FS::Record;
  56     use FS::Record qw(dbh fields qsearch qsearchs);
  57
  58     $record = new FS::Record 'table', \%hash;
  59     $record = new FS::Record 'table', { 'column' => 'value', ... };
  60
  61     $record  = qsearchs FS::Record 'table', \%hash;
  62     $record  = qsearchs FS::Record 'table', { 'column' => 'value', ... };
  63     @records = qsearch  FS::Record 'table', \%hash;
  64     @records = qsearch  FS::Record 'table', { 'column' => 'value', ... };
  65
  66     $table = $record->table;
  67     $dbdef_table = $record->dbdef_table;
  68
  69     $value = $record->get('column');
  70     $value = $record->getfield('column');
  71     $value = $record->column;
  72
  73     $record->set( 'column' => 'value' );
  74     $record->setfield( 'column' => 'value' );
  75     $record->column('value');
  76
  77     %hash = $record->hash;
  78
  79     $hashref = $record->hashref;
  80
  81     $error = $record->insert;
  82
  83     $error = $record->delete;
  84
  85     $error = $new_record->replace($old_record);
  86
  87     # external use deprecated - handled by the database (at least for Pg, mysql)
  88     $value = $record->unique('column');
  89
  90     $error = $record->ut_float('column');
  91     $error = $record->ut_floatn('column');
  92     $error = $record->ut_number('column');
  93     $error = $record->ut_numbern('column');
  94     $error = $record->ut_snumber('column');
  95     $error = $record->ut_snumbern('column');
  96     $error = $record->ut_money('column');
  97     $error = $record->ut_text('column');
  98     $error = $record->ut_textn('column');
  99     $error = $record->ut_alpha('column');
 100     $error = $record->ut_alphan('column');
 101     $error = $record->ut_phonen('column');
 102     $error = $record->ut_anything('column');
 103     $error = $record->ut_name('column');
 104
 105     $quoted_value = _quote($value,'table','field');
 106
 107     #deprecated
 108     $fields = hfields('table');
 109     if ( $fields->{Field} ) { # etc.
 110
 111     @fields = fields 'table'; #as a subroutine
 112     @fields = $record->fields; #as a method call
 113
 114
 115 =head1 DESCRIPTION
 116
 117 (Mostly) object-oriented interface to database records.  Records are currently
 118 implemented on top of DBI.  FS::Record is intended as a base class for
 119 table-specific classes to inherit from, i.e. FS::cust_main.
 120
 121 =head1 CONSTRUCTORS
 122
 123 =over 4
 124
 125 =item new [ TABLE, ] HASHREF
 126
 127 Creates a new record.  It doesn't store it in the database, though.  See
 128 L<"insert"> for that.
 129
 130 Note that the object stores this hash reference, not a distinct copy of the
 131 hash it points to.  You can ask the object for a copy with the I<hash>
 132 method.
 133
 134 TABLE can only be omitted when a dervived class overrides the table method.
 135
 136 =cut
 137
 138 sub new {
 139   my $proto = shift;
 140   my $class = ref($proto) || $proto;
 141   my $self = {};
 142   bless ($self, $class);
 143
 144   unless ( defined ( $self->table ) ) {
 145     $self->{'Table'} = shift;
 146     carp "warning: FS::Record::new called with table name ". $self->{'Table'};
 147   }
 148
 149   $self->{'Hash'} = shift;
 150
 151   foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
 152     $self->{'Hash'}{$field}='';
 153   }
 154
 155   $self->_rebless if $self->can('_rebless');
 156
 157   $self->{'modified'} = 0;
 158
 159   $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
 160
 161   $self;
 162 }
 163
 164 sub new_or_cached {
 165   my $proto = shift;
 166   my $class = ref($proto) || $proto;
 167   my $self = {};
 168   bless ($self, $class);
 169
 170   $self->{'Table'} = shift unless defined ( $self->table );
 171
 172   my $hashref = $self->{'Hash'} = shift;
 173   my $cache = shift;
 174   if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
 175     my $obj = $cache->cache->{$hashref->{$cache->key}};
 176     $obj->_cache($hashref, $cache) if $obj->can('_cache');
 177     $obj;
 178   } else {
 179     $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
 180   }
 181
 182 }
 183
 184 sub create {
 185   my $proto = shift;
 186   my $class = ref($proto) || $proto;
 187   my $self = {};
 188   bless ($self, $class);
 189   if ( defined $self->table ) {
 190     cluck "create constructor is deprecated, use new!";
 191     $self->new(@_);
 192   } else {
 193     croak "FS::Record::create called (not from a subclass)!";
 194   }
 195 }
 196
 197 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 198
 199 Searches the database for all records matching (at least) the key/value pairs
 200 in HASHREF.  Returns all the records found as `FS::TABLE' objects if that
 201 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
 202 objects.
 203
 204 The preferred usage is to pass a hash reference of named parameters:
 205
 206   my @records = qsearch( {
 207                            'table'     => 'table_name',
 208                            'hashref'   => { 'field' => 'value'
 209                                             'field' => { 'op'    => '<',
 210                                                          'value' => '420',
 211                                                        },
 212                                           },
 213
 214                            #these are optional...
 215                            'select'    => '*',
 216                            'extra_sql' => 'AND field ',
 217                            'order_by'  => 'ORDER BY something',
 218                            #'cache_obj' => '', #optional
 219                            'addl_from' => 'LEFT JOIN othtable USING ( field )',
 220                            'debug'     => 1,
 221                          }
 222                        );
 223
 224 Much code still uses old-style positional parameters, this is also probably
 225 fine in the common case where there are only two parameters:
 226
 227   my @records = qsearch( 'table', { 'field' => 'value' } );
 228
 229 ###oops, argh, FS::Record::new only lets us create database fields.
 230 #Normal behaviour if SELECT is not specified is `*', as in
 231 #C<SELECT * FROM table WHERE ...>.  However, there is an experimental new
 232 #feature where you can specify SELECT - remember, the objects returned,
 233 #although blessed into the appropriate `FS::TABLE' package, will only have the
 234 #fields you specify.  This might have unwanted results if you then go calling
 235 #regular FS::TABLE methods
 236 #on it.
 237
 238 =cut
 239
 240 sub qsearch {
 241   my($stable, $record, $select, $extra_sql, $order_by, $cache, $addl_from );
 242   my $debug = '';
 243   if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too
 244     my $opt = shift;
 245     $stable    = $opt->{'table'}     or die "table name is required";
 246     $record    = $opt->{'hashref'}   || {};
 247     $select    = $opt->{'select'}    || '*';
 248     $extra_sql = $opt->{'extra_sql'} || '';
 249     $order_by  = $opt->{'order_by'}  || '';
 250     $cache     = $opt->{'cache_obj'} || '';
 251     $addl_from = $opt->{'addl_from'} || '';
 252     $debug     = $opt->{'debug'}     || '';
 253   } else {
 254     ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_;
 255     $select ||= '*';
 256   }
 257
 258   #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
 259   #for jsearch
 260   $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
 261   $stable = $1;
 262   my $dbh = dbh;
 263
 264   my $table = $cache ? $cache->table : $stable;
 265   my $dbdef_table = dbdef->table($table)
 266     or die "No schema for table $table found - ".
 267            "do you need to run freeside-upgrade?";
 268   my $pkey = $dbdef_table->primary_key;
 269
 270   my @real_fields = grep exists($record->{$_}), real_fields($table);
 271   my @virtual_fields;
 272   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
 273     @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
 274   } else {
 275     cluck "warning: FS::$table not loaded; virtual fields not searchable";
 276     @virtual_fields = ();
 277   }
 278
 279   my $statement = "SELECT $select FROM $stable";
 280   $statement .= " $addl_from" if $addl_from;
 281   if ( @real_fields or @virtual_fields ) {
 282     $statement .= ' WHERE '. join(' AND ',
 283       get_real_fields($table, $record, \@real_fields) ,
 284       get_virtual_fields($table, $pkey, $record, \@virtual_fields),
 285       );
 286   }
 287
 288   $statement .= " $extra_sql" if defined($extra_sql);
 289   $statement .= " $order_by"  if defined($order_by);
 290
 291   warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
 292   my $sth = $dbh->prepare($statement)
 293     or croak "$dbh->errstr doing $statement";
 294
 295   my $bind = 1;
 296
 297   foreach my $field (
 298     grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
 299   ) {
 300     if ( $record->{$field} =~ /^\d+(\.\d+)?$/
 301          && dbdef->table($table)->column($field)->type =~ /(int|(big)?serial)/i
 302     ) {
 303       $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } );
 304     }elsif ( $record->{$field} =~ /^[+-]?\d+(\.\d+)?$/
 305          && dbdef->table($table)->column($field)->type =~ /(numeric)/i
 306     ) {
 307       $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_FLOAT } );
 308     }elsif ( $record->{$field} =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/
 309          && dbdef->table($table)->column($field)->type =~ /(float4)/i
 310     ) {
 311       $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_FLOAT } );
 312     } else {
 313       $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_VARCHAR } );
 314     }
 315   }
 316
 317 #  $sth->execute( map $record->{$_},
 318 #    grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
 319 #  ) or croak "Error executing \"$statement\": ". $sth->errstr;
 320
 321   $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
 322
 323   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
 324     @virtual_fields = "FS::$table"->virtual_fields;
 325   } else {
 326     cluck "warning: FS::$table not loaded; virtual fields not returned either";
 327     @virtual_fields = ();
 328   }
 329
 330   my %result;
 331   tie %result, "Tie::IxHash";
 332   my @stuff = @{ $sth->fetchall_arrayref( {} ) };
 333   if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
 334     %result = map { $_->{$pkey}, $_ } @stuff;
 335   } else {
 336     @result{@stuff} = @stuff;
 337   }
 338
 339   $sth->finish;
 340
 341   if ( keys(%result) and @virtual_fields ) {
 342     $statement =
 343       "SELECT virtual_field.recnum, part_virtual_field.name, ".
 344              "virtual_field.value ".
 345       "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ".
 346       "WHERE part_virtual_field.dbtable = '$table' AND ".
 347       "virtual_field.recnum IN (".
 348       join(',', keys(%result)). ") AND part_virtual_field.name IN ('".
 349       join(q!', '!, @virtual_fields) . "')";
 350     warn "[debug]$me $statement\n" if $DEBUG > 1;
 351     $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement";
 352     $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
 353
 354     foreach (@{ $sth->fetchall_arrayref({}) }) {
 355       my $recnum = $_->{recnum};
 356       my $name = $_->{name};
 357       my $value = $_->{value};
 358       if (exists($result{$recnum})) {
 359         $result{$recnum}->{$name} = $value;
 360       }
 361     }
 362   }
 363   my @return;
 364   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
 365     if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
 366       #derivied class didn't override new method, so this optimization is safe
 367       if ( $cache ) {
 368         @return = map {
 369           new_or_cached( "FS::$table", { %{$_} }, $cache )
 370         } values(%result);
 371       } else {
 372         @return = map {
 373           new( "FS::$table", { %{$_} } )
 374         } values(%result);
 375       }
 376     } else {
 377       #okay, its been tested
 378       # warn "untested code (class FS::$table uses custom new method)";
 379       @return = map {
 380         eval 'FS::'. $table. '->new( { %{$_} } )';
 381       } values(%result);
 382     }
 383
 384     # Check for encrypted fields and decrypt them.
 385    ## only in the local copy, not the cached object
 386     if ( $conf && $conf->exists('encryption') # $conf doesn't exist when doing
 387                                               # the initial search for
 388                                               # access_user
 389          && eval 'defined(@FS::'. $table . '::encrypted_fields)') {
 390       foreach my $record (@return) {
 391         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 392           # Set it directly... This may cause a problem in the future...
 393           $record->setfield($field, $record->decrypt($record->getfield($field)));
 394         }
 395       }
 396     }
 397   } else {
 398     cluck "warning: FS::$table not loaded; returning FS::Record objects";
 399     @return = map {
 400       FS::Record->new( $table, { %{$_} } );
 401     } values(%result);
 402   }
 403   return @return;
 404 }
 405
 406 ## makes this easier to read
 407
 408 sub get_virtual_fields {
 409    my $table = shift;
 410    my $pkey = shift;
 411    my $record = shift;
 412    my $virtual_fields = shift;
 413
 414    return
 415     ( map {
 416       my $op = '=';
 417       my $column = $_;
 418       if ( ref($record->{$_}) ) {
 419         $op = $record->{$_}{'op'} if $record->{$_}{'op'};
 420         if ( uc($op) eq 'ILIKE' ) {
 421           $op = 'LIKE';
 422           $record->{$_}{'value'} = lc($record->{$_}{'value'});
 423           $column = "LOWER($_)";
 424         }
 425         $record->{$_} = $record->{$_}{'value'};
 426       }
 427
 428       # ... EXISTS ( SELECT name, value FROM part_virtual_field
 429       #              JOIN virtual_field
 430       #              ON part_virtual_field.vfieldpart = virtual_field.vfieldpart
 431       #              WHERE recnum = svc_acct.svcnum
 432       #              AND (name, value) = ('egad', 'brain') )
 433
 434       my $value = $record->{$_};
 435
 436       my $subq;
 437
 438       $subq = ($value ? 'EXISTS ' : 'NOT EXISTS ') .
 439       "( SELECT part_virtual_field.name, virtual_field.value ".
 440       "FROM part_virtual_field JOIN virtual_field ".
 441       "ON part_virtual_field.vfieldpart = virtual_field.vfieldpart ".
 442       "WHERE virtual_field.recnum = ${table}.${pkey} ".
 443       "AND part_virtual_field.name = '${column}'".
 444       ($value ?
 445         " AND virtual_field.value ${op} '${value}'"
 446       : "") . ")";
 447       $subq;
 448
 449     } @{ $virtual_fields } ) ;
 450 }
 451
 452 sub get_real_fields {
 453   my $table = shift;
 454   my $record = shift;
 455   my $real_fields = shift;
 456
 457    ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability
 458       return (
 459       map {
 460
 461       my $op = '=';
 462       my $column = $_;
 463       if ( ref($record->{$_}) ) {
 464         $op = $record->{$_}{'op'} if $record->{$_}{'op'};
 465         #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
 466         if ( uc($op) eq 'ILIKE' ) {
 467           $op = 'LIKE';
 468           $record->{$_}{'value'} = lc($record->{$_}{'value'});
 469           $column = "LOWER($_)";
 470         }
 471         $record->{$_} = $record->{$_}{'value'}
 472       }
 473
 474       if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
 475         if ( $op eq '=' ) {
 476           if ( driver_name eq 'Pg' ) {
 477             my $type = dbdef->table($table)->column($column)->type;
 478             if ( $type =~ /(int|(big)?serial)/i ) {
 479               qq-( $column IS NULL )-;
 480             } else {
 481               qq-( $column IS NULL OR $column = '' )-;
 482             }
 483           } else {
 484             qq-( $column IS NULL OR $column = "" )-;
 485           }
 486         } elsif ( $op eq '!=' ) {
 487           if ( driver_name eq 'Pg' ) {
 488             my $type = dbdef->table($table)->column($column)->type;
 489             if ( $type =~ /(int|(big)?serial)/i ) {
 490               qq-( $column IS NOT NULL )-;
 491             } else {
 492               qq-( $column IS NOT NULL AND $column != '' )-;
 493             }
 494           } else {
 495             qq-( $column IS NOT NULL AND $column != "" )-;
 496           }
 497         } else {
 498           if ( driver_name eq 'Pg' ) {
 499             qq-( $column $op '' )-;
 500           } else {
 501             qq-( $column $op "" )-;
 502           }
 503         }
 504       } else {
 505         "$column $op ?";
 506       }
 507     } @{ $real_fields } );
 508 }
 509
 510 =item by_key PRIMARY_KEY_VALUE
 511
 512 This is a class method that returns the record with the given primary key
 513 value.  This method is only useful in FS::Record subclasses.  For example:
 514
 515   my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
 516
 517 is equivalent to:
 518
 519   my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
 520
 521 =cut
 522
 523 sub by_key {
 524   my ($class, $pkey_value) = @_;
 525
 526   my $table = $class->table
 527     or croak "No table for $class found";
 528
 529   my $dbdef_table = dbdef->table($table)
 530     or die "No schema for table $table found - ".
 531            "do you need to create it or run dbdef-create?";
 532   my $pkey = $dbdef_table->primary_key
 533     or die "No primary key for table $table";
 534
 535   return qsearchs($table, { $pkey => $pkey_value });
 536 }
 537
 538 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
 539
 540 Experimental JOINed search method.  Using this method, you can execute a
 541 single SELECT spanning multiple tables, and cache the results for subsequent
 542 method calls.  Interface will almost definately change in an incompatible
 543 fashion.
 544
 545 Arguments:
 546
 547 =cut
 548
 549 sub jsearch {
 550   my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
 551   my $cache = FS::SearchCache->new( $ptable, $pkey );
 552   my %saw;
 553   ( $cache,
 554     grep { !$saw{$_->getfield($pkey)}++ }
 555       qsearch($table, $record, $select, $extra_sql, $cache )
 556   );
 557 }
 558
 559 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 560
 561 Same as qsearch, except that if more than one record matches, it B<carp>s but
 562 returns the first.  If this happens, you either made a logic error in asking
 563 for a single item, or your data is corrupted.
 564
 565 =cut
 566
 567 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
 568   my $table = $_[0];
 569   my(@result) = qsearch(@_);
 570   cluck "warning: Multiple records in scalar search ($table)"
 571     if scalar(@result) > 1;
 572   #should warn more vehemently if the search was on a primary key?
 573   scalar(@result) ? ($result[0]) : ();
 574 }
 575
 576 =back
 577
 578 =head1 METHODS
 579
 580 =over 4
 581
 582 =item table
 583
 584 Returns the table name.
 585
 586 =cut
 587
 588 sub table {
 589 #  cluck "warning: FS::Record::table deprecated; supply one in subclass!";
 590   my $self = shift;
 591   $self -> {'Table'};
 592 }
 593
 594 =item dbdef_table
 595
 596 Returns the DBIx::DBSchema::Table object for the table.
 597
 598 =cut
 599
 600 sub dbdef_table {
 601   my($self)=@_;
 602   my($table)=$self->table;
 603   dbdef->table($table);
 604 }
 605
 606 =item primary_key
 607
 608 Returns the primary key for the table.
 609
 610 =cut
 611
 612 sub primary_key {
 613   my $self = shift;
 614   my $pkey = $self->dbdef_table->primary_key;
 615 }
 616
 617 =item get, getfield COLUMN
 618
 619 Returns the value of the column/field/key COLUMN.
 620
 621 =cut
 622
 623 sub get {
 624   my($self,$field) = @_;
 625   # to avoid "Use of unitialized value" errors
 626   if ( defined ( $self->{Hash}->{$field} ) ) {
 627     $self->{Hash}->{$field};
 628   } else {
 629     '';
 630   }
 631 }
 632 sub getfield {
 633   my $self = shift;
 634   $self->get(@_);
 635 }
 636
 637 =item set, setfield COLUMN, VALUE
 638
 639 Sets the value of the column/field/key COLUMN to VALUE.  Returns VALUE.
 640
 641 =cut
 642
 643 sub set {
 644   my($self,$field,$value) = @_;
 645   $self->{'modified'} = 1;
 646   $self->{'Hash'}->{$field} = $value;
 647 }
 648 sub setfield {
 649   my $self = shift;
 650   $self->set(@_);
 651 }
 652
 653 =item AUTLOADED METHODS
 654
 655 $record->column is a synonym for $record->get('column');
 656
 657 $record->column('value') is a synonym for $record->set('column','value');
 658
 659 =cut
 660
 661 # readable/safe
 662 sub AUTOLOAD {
 663   my($self,$value)=@_;
 664   my($field)=$AUTOLOAD;
 665   $field =~ s/.*://;
 666   if ( defined($value) ) {
 667     confess "errant AUTOLOAD $field for $self (arg $value)"
 668       unless ref($self) && $self->can('setfield');
 669     $self->setfield($field,$value);
 670   } else {
 671     confess "errant AUTOLOAD $field for $self (no args)"
 672       unless ref($self) && $self->can('getfield');
 673     $self->getfield($field);
 674   }
 675 }
 676
 677 # efficient
 678 #sub AUTOLOAD {
 679 #  my $field = $AUTOLOAD;
 680 #  $field =~ s/.*://;
 681 #  if ( defined($_[1]) ) {
 682 #    $_[0]->setfield($field, $_[1]);
 683 #  } else {
 684 #    $_[0]->getfield($field);
 685 #  }
 686 #}
 687
 688 =item hash
 689
 690 Returns a list of the column/value pairs, usually for assigning to a new hash.
 691
 692 To make a distinct duplicate of an FS::Record object, you can do:
 693
 694     $new = new FS::Record ( $old->table, { $old->hash } );
 695
 696 =cut
 697
 698 sub hash {
 699   my($self) = @_;
 700   confess $self. ' -> hash: Hash attribute is undefined'
 701     unless defined($self->{'Hash'});
 702   %{ $self->{'Hash'} };
 703 }
 704
 705 =item hashref
 706
 707 Returns a reference to the column/value hash.  This may be deprecated in the
 708 future; if there's a reason you can't just use the autoloaded or get/set
 709 methods, speak up.
 710
 711 =cut
 712
 713 sub hashref {
 714   my($self) = @_;
 715   $self->{'Hash'};
 716 }
 717
 718 =item modified
 719
 720 Returns true if any of this object's values have been modified with set (or via
 721 an autoloaded method).  Doesn't yet recognize when you retreive a hashref and
 722 modify that.
 723
 724 =cut
 725
 726 sub modified {
 727   my $self = shift;
 728   $self->{'modified'};
 729 }
 730
 731 =item select_for_update
 732
 733 Selects this record with the SQL "FOR UPDATE" command.  This can be useful as
 734 a mutex.
 735
 736 =cut
 737
 738 sub select_for_update {
 739   my $self = shift;
 740   my $primary_key = $self->primary_key;
 741   qsearchs( {
 742     'select'    => '*',
 743     'table'     => $self->table,
 744     'hashref'   => { $primary_key => $self->$primary_key() },
 745     'extra_sql' => 'FOR UPDATE',
 746   } );
 747 }
 748
 749 =item insert
 750
 751 Inserts this record to the database.  If there is an error, returns the error,
 752 otherwise returns false.
 753
 754 =cut
 755
 756 sub insert {
 757   my $self = shift;
 758   my $saved = {};
 759
 760   warn "$self -> insert" if $DEBUG;
 761
 762   my $error = $self->check;
 763   return $error if $error;
 764
 765   #single-field unique keys are given a value if false
 766   #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
 767   foreach ( $self->dbdef_table->unique_singles) {
 768     $self->unique($_) unless $self->getfield($_);
 769   }
 770
 771   #and also the primary key, if the database isn't going to
 772   my $primary_key = $self->dbdef_table->primary_key;
 773   my $db_seq = 0;
 774   if ( $primary_key ) {
 775     my $col = $self->dbdef_table->column($primary_key);
 776
 777     $db_seq =
 778       uc($col->type) =~ /^(BIG)?SERIAL\d?/
 779       || ( driver_name eq 'Pg'
 780              && defined($col->default)
 781              && $col->default =~ /^nextval\(/i
 782          )
 783       || ( driver_name eq 'mysql'
 784              && defined($col->local)
 785              && $col->local =~ /AUTO_INCREMENT/i
 786          );
 787     $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
 788   }
 789
 790   my $table = $self->table;
 791
 792
 793   # Encrypt before the database
 794   if ($conf->exists('encryption') && defined(eval '@FS::'. $table . '::encrypted_fields')) {
 795     foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 796       $self->{'saved'} = $self->getfield($field);
 797       $self->setfield($field, $self->encrypt($self->getfield($field)));
 798     }
 799   }
 800
 801
 802   #false laziness w/delete
 803   my @real_fields =
 804     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
 805     real_fields($table)
 806   ;
 807   my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
 808   #eslaf
 809
 810   my $statement = "INSERT INTO $table ";
 811   if ( @real_fields ) {
 812     $statement .=
 813       "( ".
 814         join( ', ', @real_fields ).
 815       ") VALUES (".
 816         join( ', ', @values ).
 817        ")"
 818     ;
 819   } else {
 820     $statement .= 'DEFAULT VALUES';
 821   }
 822   warn "[debug]$me $statement\n" if $DEBUG > 1;
 823   my $sth = dbh->prepare($statement) or return dbh->errstr;
 824
 825   local $SIG{HUP} = 'IGNORE';
 826   local $SIG{INT} = 'IGNORE';
 827   local $SIG{QUIT} = 'IGNORE';
 828   local $SIG{TERM} = 'IGNORE';
 829   local $SIG{TSTP} = 'IGNORE';
 830   local $SIG{PIPE} = 'IGNORE';
 831
 832   $sth->execute or return $sth->errstr;
 833
 834   # get inserted id from the database, if applicable & needed
 835   if ( $db_seq && ! $self->getfield($primary_key) ) {
 836     warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
 837
 838     my $insertid = '';
 839
 840     if ( driver_name eq 'Pg' ) {
 841
 842       #my $oid = $sth->{'pg_oid_status'};
 843       #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
 844
 845       my $default = $self->dbdef_table->column($primary_key)->default;
 846       unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
 847         dbh->rollback if $FS::UID::AutoCommit;
 848         return "can't parse $table.$primary_key default value".
 849                " for sequence name: $default";
 850       }
 851       my $sequence = $1;
 852
 853       my $i_sql = "SELECT currval('$sequence')";
 854       my $i_sth = dbh->prepare($i_sql) or do {
 855         dbh->rollback if $FS::UID::AutoCommit;
 856         return dbh->errstr;
 857       };
 858       $i_sth->execute() or do { #$i_sth->execute($oid)
 859         dbh->rollback if $FS::UID::AutoCommit;
 860         return $i_sth->errstr;
 861       };
 862       $insertid = $i_sth->fetchrow_arrayref->[0];
 863
 864     } elsif ( driver_name eq 'mysql' ) {
 865
 866       $insertid = dbh->{'mysql_insertid'};
 867       # work around mysql_insertid being null some of the time, ala RT :/
 868       unless ( $insertid ) {
 869         warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
 870              "using SELECT LAST_INSERT_ID();";
 871         my $i_sql = "SELECT LAST_INSERT_ID()";
 872         my $i_sth = dbh->prepare($i_sql) or do {
 873           dbh->rollback if $FS::UID::AutoCommit;
 874           return dbh->errstr;
 875         };
 876         $i_sth->execute or do {
 877           dbh->rollback if $FS::UID::AutoCommit;
 878           return $i_sth->errstr;
 879         };
 880         $insertid = $i_sth->fetchrow_arrayref->[0];
 881       }
 882
 883     } else {
 884
 885       dbh->rollback if $FS::UID::AutoCommit;
 886       return "don't know how to retreive inserted ids from ". driver_name.
 887              ", try using counterfiles (maybe run dbdef-create?)";
 888
 889     }
 890
 891     $self->setfield($primary_key, $insertid);
 892
 893   }
 894
 895   my @virtual_fields =
 896       grep defined($self->getfield($_)) && $self->getfield($_) ne "",
 897           $self->virtual_fields;
 898   if (@virtual_fields) {
 899     my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
 900
 901     my $vfieldpart = $self->vfieldpart_hashref;
 902
 903     my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
 904                     "VALUES (?, ?, ?)";
 905
 906     my $v_sth = dbh->prepare($v_statement) or do {
 907       dbh->rollback if $FS::UID::AutoCommit;
 908       return dbh->errstr;
 909     };
 910
 911     foreach (keys(%v_values)) {
 912       $v_sth->execute($self->getfield($primary_key),
 913                       $vfieldpart->{$_},
 914                       $v_values{$_})
 915       or do {
 916         dbh->rollback if $FS::UID::AutoCommit;
 917         return $v_sth->errstr;
 918       };
 919     }
 920   }
 921
 922
 923   my $h_sth;
 924   if ( defined dbdef->table('h_'. $table) ) {
 925     my $h_statement = $self->_h_statement('insert');
 926     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
 927     $h_sth = dbh->prepare($h_statement) or do {
 928       dbh->rollback if $FS::UID::AutoCommit;
 929       return dbh->errstr;
 930     };
 931   } else {
 932     $h_sth = '';
 933   }
 934   $h_sth->execute or return $h_sth->errstr if $h_sth;
 935
 936   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 937
 938   # Now that it has been saved, reset the encrypted fields so that $new
 939   # can still be used.
 940   foreach my $field (keys %{$saved}) {
 941     $self->setfield($field, $saved->{$field});
 942   }
 943
 944   '';
 945 }
 946
 947 =item add
 948
 949 Depriciated (use insert instead).
 950
 951 =cut
 952
 953 sub add {
 954   cluck "warning: FS::Record::add deprecated!";
 955   insert @_; #call method in this scope
 956 }
 957
 958 =item delete
 959
 960 Delete this record from the database.  If there is an error, returns the error,
 961 otherwise returns false.
 962
 963 =cut
 964
 965 sub delete {
 966   my $self = shift;
 967
 968   my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
 969     map {
 970       $self->getfield($_) eq ''
 971         #? "( $_ IS NULL OR $_ = \"\" )"
 972         ? ( driver_name eq 'Pg'
 973               ? "$_ IS NULL"
 974               : "( $_ IS NULL OR $_ = \"\" )"
 975           )
 976         : "$_ = ". _quote($self->getfield($_),$self->table,$_)
 977     } ( $self->dbdef_table->primary_key )
 978           ? ( $self->dbdef_table->primary_key)
 979           : real_fields($self->table)
 980   );
 981   warn "[debug]$me $statement\n" if $DEBUG > 1;
 982   my $sth = dbh->prepare($statement) or return dbh->errstr;
 983
 984   my $h_sth;
 985   if ( defined dbdef->table('h_'. $self->table) ) {
 986     my $h_statement = $self->_h_statement('delete');
 987     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
 988     $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
 989   } else {
 990     $h_sth = '';
 991   }
 992
 993   my $primary_key = $self->dbdef_table->primary_key;
 994   my $v_sth;
 995   my @del_vfields;
 996   my $vfp = $self->vfieldpart_hashref;
 997   foreach($self->virtual_fields) {
 998     next if $self->getfield($_) eq '';
 999     unless(@del_vfields) {
1000       my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
1001       $v_sth = dbh->prepare($st) or return dbh->errstr;
1002     }
1003     push @del_vfields, $_;
1004   }
1005
1006   local $SIG{HUP} = 'IGNORE';
1007   local $SIG{INT} = 'IGNORE';
1008   local $SIG{QUIT} = 'IGNORE';
1009   local $SIG{TERM} = 'IGNORE';
1010   local $SIG{TSTP} = 'IGNORE';
1011   local $SIG{PIPE} = 'IGNORE';
1012
1013   my $rc = $sth->execute or return $sth->errstr;
1014   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1015   $h_sth->execute or return $h_sth->errstr if $h_sth;
1016   $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
1017     or return $v_sth->errstr
1018         foreach (@del_vfields);
1019
1020   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1021
1022   #no need to needlessly destoy the data either (causes problems actually)
1023   #undef $self; #no need to keep object!
1024
1025   '';
1026 }
1027
1028 =item del
1029
1030 Depriciated (use delete instead).
1031
1032 =cut
1033
1034 sub del {
1035   cluck "warning: FS::Record::del deprecated!";
1036   &delete(@_); #call method in this scope
1037 }
1038
1039 =item replace OLD_RECORD
1040
1041 Replace the OLD_RECORD with this one in the database.  If there is an error,
1042 returns the error, otherwise returns false.
1043
1044 =cut
1045
1046 sub replace {
1047   my ($new, $old) = (shift, shift);
1048
1049   $old = $new->replace_old unless defined($old);
1050
1051   warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1052
1053   if ( $new->can('replace_check') ) {
1054     my $error = $new->replace_check($old);
1055     return $error if $error;
1056   }
1057
1058   return "Records not in same table!" unless $new->table eq $old->table;
1059
1060   my $primary_key = $old->dbdef_table->primary_key;
1061   return "Can't change primary key $primary_key ".
1062          'from '. $old->getfield($primary_key).
1063          ' to ' . $new->getfield($primary_key)
1064     if $primary_key
1065        && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1066
1067   my $error = $new->check;
1068   return $error if $error;
1069
1070   # Encrypt for replace
1071   my $saved = {};
1072   if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) {
1073     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1074       $saved->{$field} = $new->getfield($field);
1075       $new->setfield($field, $new->encrypt($new->getfield($field)));
1076     }
1077   }
1078
1079   #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1080   my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1081                    ? ($_, $new->getfield($_)) : () } $old->fields;
1082
1083   unless (keys(%diff) || $no_update_diff ) {
1084     carp "[warning]$me $new -> replace $old: records identical"
1085       unless $nowarn_identical;
1086     return '';
1087   }
1088
1089   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1090     map {
1091       "$_ = ". _quote($new->getfield($_),$old->table,$_)
1092     } real_fields($old->table)
1093   ). ' WHERE '.
1094     join(' AND ',
1095       map {
1096
1097         if ( $old->getfield($_) eq '' ) {
1098
1099          #false laziness w/qsearch
1100          if ( driver_name eq 'Pg' ) {
1101             my $type = $old->dbdef_table->column($_)->type;
1102             if ( $type =~ /(int|(big)?serial)/i ) {
1103               qq-( $_ IS NULL )-;
1104             } else {
1105               qq-( $_ IS NULL OR $_ = '' )-;
1106             }
1107           } else {
1108             qq-( $_ IS NULL OR $_ = "" )-;
1109           }
1110
1111         } else {
1112           "$_ = ". _quote($old->getfield($_),$old->table,$_);
1113         }
1114
1115       } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1116     )
1117   ;
1118   warn "[debug]$me $statement\n" if $DEBUG > 1;
1119   my $sth = dbh->prepare($statement) or return dbh->errstr;
1120
1121   my $h_old_sth;
1122   if ( defined dbdef->table('h_'. $old->table) ) {
1123     my $h_old_statement = $old->_h_statement('replace_old');
1124     warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1125     $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1126   } else {
1127     $h_old_sth = '';
1128   }
1129
1130   my $h_new_sth;
1131   if ( defined dbdef->table('h_'. $new->table) ) {
1132     my $h_new_statement = $new->_h_statement('replace_new');
1133     warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1134     $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1135   } else {
1136     $h_new_sth = '';
1137   }
1138
1139   # For virtual fields we have three cases with different SQL
1140   # statements: add, replace, delete
1141   my $v_add_sth;
1142   my $v_rep_sth;
1143   my $v_del_sth;
1144   my (@add_vfields, @rep_vfields, @del_vfields);
1145   my $vfp = $old->vfieldpart_hashref;
1146   foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
1147     if($diff{$_} eq '') {
1148       # Delete
1149       unless(@del_vfields) {
1150         my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
1151                  "AND vfieldpart = ?";
1152         warn "[debug]$me $st\n" if $DEBUG > 2;
1153         $v_del_sth = dbh->prepare($st) or return dbh->errstr;
1154       }
1155       push @del_vfields, $_;
1156     } elsif($old->getfield($_) eq '') {
1157       # Add
1158       unless(@add_vfields) {
1159         my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
1160                  "VALUES (?, ?, ?)";
1161         warn "[debug]$me $st\n" if $DEBUG > 2;
1162         $v_add_sth = dbh->prepare($st) or return dbh->errstr;
1163       }
1164       push @add_vfields, $_;
1165     } else {
1166       # Replace
1167       unless(@rep_vfields) {
1168         my $st = "UPDATE virtual_field SET value = ? ".
1169                  "WHERE recnum = ? AND vfieldpart = ?";
1170         warn "[debug]$me $st\n" if $DEBUG > 2;
1171         $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
1172       }
1173       push @rep_vfields, $_;
1174     }
1175   }
1176
1177   local $SIG{HUP} = 'IGNORE';
1178   local $SIG{INT} = 'IGNORE';
1179   local $SIG{QUIT} = 'IGNORE';
1180   local $SIG{TERM} = 'IGNORE';
1181   local $SIG{TSTP} = 'IGNORE';
1182   local $SIG{PIPE} = 'IGNORE';
1183
1184   my $rc = $sth->execute or return $sth->errstr;
1185   #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1186   $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1187   $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1188
1189   $v_del_sth->execute($old->getfield($primary_key),
1190                       $vfp->{$_})
1191         or return $v_del_sth->errstr
1192       foreach(@del_vfields);
1193
1194   $v_add_sth->execute($new->getfield($_),
1195                       $old->getfield($primary_key),
1196                       $vfp->{$_})
1197         or return $v_add_sth->errstr
1198       foreach(@add_vfields);
1199
1200   $v_rep_sth->execute($new->getfield($_),
1201                       $old->getfield($primary_key),
1202                       $vfp->{$_})
1203         or return $v_rep_sth->errstr
1204       foreach(@rep_vfields);
1205
1206   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1207
1208   # Now that it has been saved, reset the encrypted fields so that $new
1209   # can still be used.
1210   foreach my $field (keys %{$saved}) {
1211     $new->setfield($field, $saved->{$field});
1212   }
1213
1214   '';
1215
1216 }
1217
1218 sub replace_old {
1219   my( $self ) = shift;
1220   warn "[$me] replace called with no arguments; autoloading old record\n"
1221     if $DEBUG;
1222
1223   my $primary_key = $self->dbdef_table->primary_key;
1224   if ( $primary_key ) {
1225     $self->by_key( $self->$primary_key() ) #this is what's returned
1226       or croak "can't find ". $self->table. ".$primary_key ".
1227         $self->$primary_key();
1228   } else {
1229     croak $self->table. " has no primary key; pass old record as argument";
1230   }
1231
1232 }
1233
1234 =item rep
1235
1236 Depriciated (use replace instead).
1237
1238 =cut
1239
1240 sub rep {
1241   cluck "warning: FS::Record::rep deprecated!";
1242   replace @_; #call method in this scope
1243 }
1244
1245 =item check
1246
1247 Checks virtual fields (using check_blocks).  Subclasses should still provide
1248 a check method to validate real fields, foreign keys, etc., and call this
1249 method via $self->SUPER::check.
1250
1251 (FIXME: Should this method try to make sure that it I<is> being called from
1252 a subclass's check method, to keep the current semantics as far as possible?)
1253
1254 =cut
1255
1256 sub check {
1257   #confess "FS::Record::check not implemented; supply one in subclass!";
1258   my $self = shift;
1259
1260   foreach my $field ($self->virtual_fields) {
1261     for ($self->getfield($field)) {
1262       # See notes on check_block in FS::part_virtual_field.
1263       eval $self->pvf($field)->check_block;
1264       if ( $@ ) {
1265         #this is bad, probably want to follow the stack backtrace up and see
1266         #wtf happened
1267         my $err = "Fatal error checking $field for $self";
1268         cluck "$err: $@";
1269         return "$err (see log for backtrace): $@";
1270
1271       }
1272       $self->setfield($field, $_);
1273     }
1274   }
1275   '';
1276 }
1277
1278 sub _h_statement {
1279   my( $self, $action, $time ) = @_;
1280
1281   $time ||= time;
1282
1283   my @fields =
1284     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1285     real_fields($self->table);
1286   ;
1287
1288   # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1289   # You can see if it changed by the paymask...
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   if ($conf->exists('encryption')) {
2045     if ($self->is_encrypted($value)) {
2046       # Return the original value if it isn't plaintext.
2047       $encrypted = $value;
2048     } else {
2049       $self->loadRSA;
2050       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2051         # RSA doesn't like the empty string so let's pack it up
2052         # The database doesn't like the RSA data so uuencode it
2053         my $length = length($value)+1;
2054         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2055       } else {
2056         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2057       }
2058     }
2059   }
2060   return $encrypted;
2061 }
2062
2063 =item is_encrypted($value)
2064
2065 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2066
2067 =cut
2068
2069
2070 sub is_encrypted {
2071   my ($self, $value) = @_;
2072   # Possible Bug - Some work may be required here....
2073
2074   if ($value =~ /^M/ && length($value) > 80) {
2075     return 1;
2076   } else {
2077     return 0;
2078   }
2079 }
2080
2081 =item decrypt($value)
2082
2083 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2084
2085 You should generally not have to worry about calling this, as the system handles this for you.
2086
2087 =cut
2088
2089 sub decrypt {
2090   my ($self,$value) = @_;
2091   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2092   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2093     $self->loadRSA;
2094     if (ref($rsa_decrypt) =~ /::RSA/) {
2095       my $encrypted = unpack ("u*", $value);
2096       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2097       if ($@) {warn "Decryption Failed"};
2098     }
2099   }
2100   return $decrypted;
2101 }
2102
2103 sub loadRSA {
2104     my $self = shift;
2105     #Initialize the Module
2106     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2107
2108     if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') {
2109       $rsa_module = $conf->config('encryptionmodule');
2110     }
2111
2112     if (!$rsa_loaded) {
2113         eval ("require $rsa_module"); # No need to import the namespace
2114         $rsa_loaded++;
2115     }
2116     # Initialize Encryption
2117     if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') {
2118       my $public_key = join("\n",$conf->config('encryptionpublickey'));
2119       $rsa_encrypt = $rsa_module->new_public_key($public_key);
2120     }
2121
2122     # Intitalize Decryption
2123     if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') {
2124       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2125       $rsa_decrypt = $rsa_module->new_private_key($private_key);
2126     }
2127 }
2128
2129 =item h_search ACTION
2130
2131 Given an ACTION, either "insert", or "delete", returns the appropriate history
2132 record corresponding to this record, if any.
2133
2134 =cut
2135
2136 sub h_search {
2137   my( $self, $action ) = @_;
2138
2139   my $table = $self->table;
2140   $table =~ s/^h_//;
2141
2142   my $primary_key = dbdef->table($table)->primary_key;
2143
2144   qsearchs({
2145     'table'   => "h_$table",
2146     'hashref' => { $primary_key     => $self->$primary_key(),
2147                    'history_action' => $action,
2148                  },
2149   });
2150
2151 }
2152
2153 =item h_date ACTION
2154
2155 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2156 appropriate history record corresponding to this record, if any.
2157
2158 =cut
2159
2160 sub h_date {
2161   my($self, $action) = @_;
2162   my $h = $self->h_search($action);
2163   $h ? $h->history_date : '';
2164 }
2165
2166 =back
2167
2168 =head1 SUBROUTINES
2169
2170 =over 4
2171
2172 =item real_fields [ TABLE ]
2173
2174 Returns a list of the real columns in the specified table.  Called only by
2175 fields() and other subroutines elsewhere in FS::Record.
2176
2177 =cut
2178
2179 sub real_fields {
2180   my $table = shift;
2181
2182   my($table_obj) = dbdef->table($table);
2183   confess "Unknown table $table" unless $table_obj;
2184   $table_obj->columns;
2185 }
2186
2187 =item _quote VALUE, TABLE, COLUMN
2188
2189 This is an internal function used to construct SQL statements.  It returns
2190 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2191 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2192
2193 =cut
2194
2195 sub _quote {
2196   my($value, $table, $column) = @_;
2197   my $column_obj = dbdef->table($table)->column($column);
2198   my $column_type = $column_obj->type;
2199   my $nullable = $column_obj->null;
2200
2201   warn "  $table.$column: $value ($column_type".
2202        ( $nullable ? ' NULL' : ' NOT NULL' ).
2203        ")\n" if $DEBUG > 2;
2204
2205   if ( $value eq '' && $nullable ) {
2206     'NULL'
2207   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2208     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2209           "using 0 instead";
2210     0;
2211   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2212             ! $column_type =~ /(char|binary|text)$/i ) {
2213     $value;
2214   } else {
2215     dbh->quote($value);
2216   }
2217 }
2218
2219 =item hfields TABLE
2220
2221 This is deprecated.  Don't use it.
2222
2223 It returns a hash-type list with the fields of this record's table set true.
2224
2225 =cut
2226
2227 sub hfields {
2228   carp "warning: hfields is deprecated";
2229   my($table)=@_;
2230   my(%hash);
2231   foreach (fields($table)) {
2232     $hash{$_}=1;
2233   }
2234   \%hash;
2235 }
2236
2237 sub _dump {
2238   my($self)=@_;
2239   join("\n", map {
2240     "$_: ". $self->getfield($_). "|"
2241   } (fields($self->table)) );
2242 }
2243
2244 sub DESTROY { return; }
2245
2246 #sub DESTROY {
2247 #  my $self = shift;
2248 #  #use Carp qw(cluck);
2249 #  #cluck "DESTROYING $self";
2250 #  warn "DESTROYING $self";
2251 #}
2252
2253 #sub is_tainted {
2254 #             return ! eval { join('',@_), kill 0; 1; };
2255 #         }
2256
2257 =item str2time_sql [ DRIVER_NAME ]
2258
2259 Returns a function to convert to unix time based on database type, such as
2260 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
2261 the str2time_sql_closing method to return a closing string rather than just
2262 using a closing parenthesis as previously suggested.
2263
2264 You can pass an optional driver name such as "Pg", "mysql" or
2265 $dbh->{Driver}->{Name} to return a function for that database instead of
2266 the current database.
2267
2268 =cut
2269
2270 sub str2time_sql {
2271   my $driver = shift || driver_name;
2272
2273   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
2274   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
2275
2276   warn "warning: unknown database type $driver; guessing how to convert ".
2277        "dates to UNIX timestamps";
2278   return 'EXTRACT(EPOCH FROM ';
2279
2280 }
2281
2282 =item str2time_sql_closing [ DRIVER_NAME ]
2283
2284 Returns the closing suffix of a function to convert to unix time based on
2285 database type, such as ")::integer" for Pg or ")" for mysql.
2286
2287 You can pass an optional driver name such as "Pg", "mysql" or
2288 $dbh->{Driver}->{Name} to return a function for that database instead of
2289 the current database.
2290
2291 =cut
2292
2293 sub str2time_sql_closing {
2294   my $driver = shift || driver_name;
2295
2296   return ' )::INTEGER ' if $driver =~ /^Pg/i;
2297   return ' ) ';
2298 }
2299
2300 =back
2301
2302 =head1 BUGS
2303
2304 This module should probably be renamed, since much of the functionality is
2305 of general use.  It is not completely unlike Adapter::DBI (see below).
2306
2307 Exported qsearch and qsearchs should be deprecated in favor of method calls
2308 (against an FS::Record object like the old search and searchs that qsearch
2309 and qsearchs were on top of.)
2310
2311 The whole fields / hfields mess should be removed.
2312
2313 The various WHERE clauses should be subroutined.
2314
2315 table string should be deprecated in favor of DBIx::DBSchema::Table.
2316
2317 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
2318 true maps to the database (and WHERE clauses) would also help.
2319
2320 The ut_ methods should ask the dbdef for a default length.
2321
2322 ut_sqltype (like ut_varchar) should all be defined
2323
2324 A fallback check method should be provided which uses the dbdef.
2325
2326 The ut_money method assumes money has two decimal digits.
2327
2328 The Pg money kludge in the new method only strips `$'.
2329
2330 The ut_phonen method only checks US-style phone numbers.
2331
2332 The _quote function should probably use ut_float instead of a regex.
2333
2334 All the subroutines probably should be methods, here or elsewhere.
2335
2336 Probably should borrow/use some dbdef methods where appropriate (like sub
2337 fields)
2338
2339 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
2340 or allow it to be set.  Working around it is ugly any way around - DBI should
2341 be fixed.  (only affects RDBMS which return uppercase column names)
2342
2343 ut_zip should take an optional country like ut_phone.
2344
2345 =head1 SEE ALSO
2346
2347 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
2348
2349 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
2350
2351 http://poop.sf.net/
2352
2353 =cut
2354
2355 1;
2356