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