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