FS/FS/Record.pm

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