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