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   if ($conf->exists('encryption') && defined(eval '@FS::'. $table . '::encrypted_fields')) {
 761     foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 762       $self->{'saved'} = $self->getfield($field);
 763       $self->setfield($field, $self->encrypt($self->getfield($field)));
 764     }
 765   }
 766
 767
 768   #false laziness w/delete
 769   my @real_fields =
 770     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
 771     real_fields($table)
 772   ;
 773   my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
 774   #eslaf
 775
 776   my $statement = "INSERT INTO $table ";
 777   if ( @real_fields ) {
 778     $statement .=
 779       "( ".
 780         join( ', ', @real_fields ).
 781       ") VALUES (".
 782         join( ', ', @values ).
 783        ")"
 784     ;
 785   } else {
 786     $statement .= 'DEFAULT VALUES';
 787   }
 788   warn "[debug]$me $statement\n" if $DEBUG > 1;
 789   my $sth = dbh->prepare($statement) or return dbh->errstr;
 790
 791   local $SIG{HUP} = 'IGNORE';
 792   local $SIG{INT} = 'IGNORE';
 793   local $SIG{QUIT} = 'IGNORE';
 794   local $SIG{TERM} = 'IGNORE';
 795   local $SIG{TSTP} = 'IGNORE';
 796   local $SIG{PIPE} = 'IGNORE';
 797
 798   $sth->execute or return $sth->errstr;
 799
 800   # get inserted id from the database, if applicable & needed
 801   if ( $db_seq && ! $self->getfield($primary_key) ) {
 802     warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
 803
 804     my $insertid = '';
 805
 806     if ( driver_name eq 'Pg' ) {
 807
 808       #my $oid = $sth->{'pg_oid_status'};
 809       #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
 810
 811       my $default = $self->dbdef_table->column($primary_key)->default;
 812       unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
 813         dbh->rollback if $FS::UID::AutoCommit;
 814         return "can't parse $table.$primary_key default value".
 815                " for sequence name: $default";
 816       }
 817       my $sequence = $1;
 818
 819       my $i_sql = "SELECT currval('$sequence')";
 820       my $i_sth = dbh->prepare($i_sql) or do {
 821         dbh->rollback if $FS::UID::AutoCommit;
 822         return dbh->errstr;
 823       };
 824       $i_sth->execute() or do { #$i_sth->execute($oid)
 825         dbh->rollback if $FS::UID::AutoCommit;
 826         return $i_sth->errstr;
 827       };
 828       $insertid = $i_sth->fetchrow_arrayref->[0];
 829
 830     } elsif ( driver_name eq 'mysql' ) {
 831
 832       $insertid = dbh->{'mysql_insertid'};
 833       # work around mysql_insertid being null some of the time, ala RT :/
 834       unless ( $insertid ) {
 835         warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
 836              "using SELECT LAST_INSERT_ID();";
 837         my $i_sql = "SELECT LAST_INSERT_ID()";
 838         my $i_sth = dbh->prepare($i_sql) or do {
 839           dbh->rollback if $FS::UID::AutoCommit;
 840           return dbh->errstr;
 841         };
 842         $i_sth->execute or do {
 843           dbh->rollback if $FS::UID::AutoCommit;
 844           return $i_sth->errstr;
 845         };
 846         $insertid = $i_sth->fetchrow_arrayref->[0];
 847       }
 848
 849     } else {
 850
 851       dbh->rollback if $FS::UID::AutoCommit;
 852       return "don't know how to retreive inserted ids from ". driver_name.
 853              ", try using counterfiles (maybe run dbdef-create?)";
 854
 855     }
 856
 857     $self->setfield($primary_key, $insertid);
 858
 859   }
 860
 861   my @virtual_fields =
 862       grep defined($self->getfield($_)) && $self->getfield($_) ne "",
 863           $self->virtual_fields;
 864   if (@virtual_fields) {
 865     my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
 866
 867     my $vfieldpart = $self->vfieldpart_hashref;
 868
 869     my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
 870                     "VALUES (?, ?, ?)";
 871
 872     my $v_sth = dbh->prepare($v_statement) or do {
 873       dbh->rollback if $FS::UID::AutoCommit;
 874       return dbh->errstr;
 875     };
 876
 877     foreach (keys(%v_values)) {
 878       $v_sth->execute($self->getfield($primary_key),
 879                       $vfieldpart->{$_},
 880                       $v_values{$_})
 881       or do {
 882         dbh->rollback if $FS::UID::AutoCommit;
 883         return $v_sth->errstr;
 884       };
 885     }
 886   }
 887
 888
 889   my $h_sth;
 890   if ( defined dbdef->table('h_'. $table) ) {
 891     my $h_statement = $self->_h_statement('insert');
 892     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
 893     $h_sth = dbh->prepare($h_statement) or do {
 894       dbh->rollback if $FS::UID::AutoCommit;
 895       return dbh->errstr;
 896     };
 897   } else {
 898     $h_sth = '';
 899   }
 900   $h_sth->execute or return $h_sth->errstr if $h_sth;
 901
 902   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 903
 904   # Now that it has been saved, reset the encrypted fields so that $new
 905   # can still be used.
 906   foreach my $field (keys %{$saved}) {
 907     $self->setfield($field, $saved->{$field});
 908   }
 909
 910   '';
 911 }
 912
 913 =item add
 914
 915 Depriciated (use insert instead).
 916
 917 =cut
 918
 919 sub add {
 920   cluck "warning: FS::Record::add deprecated!";
 921   insert @_; #call method in this scope
 922 }
 923
 924 =item delete
 925
 926 Delete this record from the database.  If there is an error, returns the error,
 927 otherwise returns false.
 928
 929 =cut
 930
 931 sub delete {
 932   my $self = shift;
 933
 934   my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
 935     map {
 936       $self->getfield($_) eq ''
 937         #? "( $_ IS NULL OR $_ = \"\" )"
 938         ? ( driver_name eq 'Pg'
 939               ? "$_ IS NULL"
 940               : "( $_ IS NULL OR $_ = \"\" )"
 941           )
 942         : "$_ = ". _quote($self->getfield($_),$self->table,$_)
 943     } ( $self->dbdef_table->primary_key )
 944           ? ( $self->dbdef_table->primary_key)
 945           : real_fields($self->table)
 946   );
 947   warn "[debug]$me $statement\n" if $DEBUG > 1;
 948   my $sth = dbh->prepare($statement) or return dbh->errstr;
 949
 950   my $h_sth;
 951   if ( defined dbdef->table('h_'. $self->table) ) {
 952     my $h_statement = $self->_h_statement('delete');
 953     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
 954     $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
 955   } else {
 956     $h_sth = '';
 957   }
 958
 959   my $primary_key = $self->dbdef_table->primary_key;
 960   my $v_sth;
 961   my @del_vfields;
 962   my $vfp = $self->vfieldpart_hashref;
 963   foreach($self->virtual_fields) {
 964     next if $self->getfield($_) eq '';
 965     unless(@del_vfields) {
 966       my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
 967       $v_sth = dbh->prepare($st) or return dbh->errstr;
 968     }
 969     push @del_vfields, $_;
 970   }
 971
 972   local $SIG{HUP} = 'IGNORE';
 973   local $SIG{INT} = 'IGNORE';
 974   local $SIG{QUIT} = 'IGNORE';
 975   local $SIG{TERM} = 'IGNORE';
 976   local $SIG{TSTP} = 'IGNORE';
 977   local $SIG{PIPE} = 'IGNORE';
 978
 979   my $rc = $sth->execute or return $sth->errstr;
 980   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
 981   $h_sth->execute or return $h_sth->errstr if $h_sth;
 982   $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
 983     or return $v_sth->errstr
 984         foreach (@del_vfields);
 985
 986   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 987
 988   #no need to needlessly destoy the data either (causes problems actually)
 989   #undef $self; #no need to keep object!
 990
 991   '';
 992 }
 993
 994 =item del
 995
 996 Depriciated (use delete instead).
 997
 998 =cut
 999
1000 sub del {
1001   cluck "warning: FS::Record::del deprecated!";
1002   &delete(@_); #call method in this scope
1003 }
1004
1005 =item replace OLD_RECORD
1006
1007 Replace the OLD_RECORD with this one in the database.  If there is an error,
1008 returns the error, otherwise returns false.
1009
1010 =cut
1011
1012 sub replace {
1013   my ($new, $old) = (shift, shift);
1014
1015   $old = $new->replace_old unless defined($old);
1016
1017   warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1018
1019   if ( $new->can('replace_check') ) {
1020     my $error = $new->replace_check($old);
1021     return $error if $error;
1022   }
1023
1024   return "Records not in same table!" unless $new->table eq $old->table;
1025
1026   my $primary_key = $old->dbdef_table->primary_key;
1027   return "Can't change primary key $primary_key ".
1028          'from '. $old->getfield($primary_key).
1029          ' to ' . $new->getfield($primary_key)
1030     if $primary_key
1031        && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1032
1033   my $error = $new->check;
1034   return $error if $error;
1035
1036   # Encrypt for replace
1037   my $conf = new FS::Conf;
1038   my $saved = {};
1039   if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) {
1040     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1041       $saved->{$field} = $new->getfield($field);
1042       $new->setfield($field, $new->encrypt($new->getfield($field)));
1043     }
1044   }
1045
1046   #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1047   my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1048                    ? ($_, $new->getfield($_)) : () } $old->fields;
1049
1050   unless (keys(%diff) || $no_update_diff ) {
1051     carp "[warning]$me $new -> replace $old: records identical"
1052       unless $nowarn_identical;
1053     return '';
1054   }
1055
1056   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1057     map {
1058       "$_ = ". _quote($new->getfield($_),$old->table,$_)
1059     } real_fields($old->table)
1060   ). ' WHERE '.
1061     join(' AND ',
1062       map {
1063
1064         if ( $old->getfield($_) eq '' ) {
1065
1066          #false laziness w/qsearch
1067          if ( driver_name eq 'Pg' ) {
1068             my $type = $old->dbdef_table->column($_)->type;
1069             if ( $type =~ /(int|(big)?serial)/i ) {
1070               qq-( $_ IS NULL )-;
1071             } else {
1072               qq-( $_ IS NULL OR $_ = '' )-;
1073             }
1074           } else {
1075             qq-( $_ IS NULL OR $_ = "" )-;
1076           }
1077
1078         } else {
1079           "$_ = ". _quote($old->getfield($_),$old->table,$_);
1080         }
1081
1082       } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1083     )
1084   ;
1085   warn "[debug]$me $statement\n" if $DEBUG > 1;
1086   my $sth = dbh->prepare($statement) or return dbh->errstr;
1087
1088   my $h_old_sth;
1089   if ( defined dbdef->table('h_'. $old->table) ) {
1090     my $h_old_statement = $old->_h_statement('replace_old');
1091     warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1092     $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1093   } else {
1094     $h_old_sth = '';
1095   }
1096
1097   my $h_new_sth;
1098   if ( defined dbdef->table('h_'. $new->table) ) {
1099     my $h_new_statement = $new->_h_statement('replace_new');
1100     warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1101     $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1102   } else {
1103     $h_new_sth = '';
1104   }
1105
1106   # For virtual fields we have three cases with different SQL
1107   # statements: add, replace, delete
1108   my $v_add_sth;
1109   my $v_rep_sth;
1110   my $v_del_sth;
1111   my (@add_vfields, @rep_vfields, @del_vfields);
1112   my $vfp = $old->vfieldpart_hashref;
1113   foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
1114     if($diff{$_} eq '') {
1115       # Delete
1116       unless(@del_vfields) {
1117         my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
1118                  "AND vfieldpart = ?";
1119         warn "[debug]$me $st\n" if $DEBUG > 2;
1120         $v_del_sth = dbh->prepare($st) or return dbh->errstr;
1121       }
1122       push @del_vfields, $_;
1123     } elsif($old->getfield($_) eq '') {
1124       # Add
1125       unless(@add_vfields) {
1126         my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
1127                  "VALUES (?, ?, ?)";
1128         warn "[debug]$me $st\n" if $DEBUG > 2;
1129         $v_add_sth = dbh->prepare($st) or return dbh->errstr;
1130       }
1131       push @add_vfields, $_;
1132     } else {
1133       # Replace
1134       unless(@rep_vfields) {
1135         my $st = "UPDATE virtual_field SET value = ? ".
1136                  "WHERE recnum = ? AND vfieldpart = ?";
1137         warn "[debug]$me $st\n" if $DEBUG > 2;
1138         $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
1139       }
1140       push @rep_vfields, $_;
1141     }
1142   }
1143
1144   local $SIG{HUP} = 'IGNORE';
1145   local $SIG{INT} = 'IGNORE';
1146   local $SIG{QUIT} = 'IGNORE';
1147   local $SIG{TERM} = 'IGNORE';
1148   local $SIG{TSTP} = 'IGNORE';
1149   local $SIG{PIPE} = 'IGNORE';
1150
1151   my $rc = $sth->execute or return $sth->errstr;
1152   #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1153   $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1154   $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1155
1156   $v_del_sth->execute($old->getfield($primary_key),
1157                       $vfp->{$_})
1158         or return $v_del_sth->errstr
1159       foreach(@del_vfields);
1160
1161   $v_add_sth->execute($new->getfield($_),
1162                       $old->getfield($primary_key),
1163                       $vfp->{$_})
1164         or return $v_add_sth->errstr
1165       foreach(@add_vfields);
1166
1167   $v_rep_sth->execute($new->getfield($_),
1168                       $old->getfield($primary_key),
1169                       $vfp->{$_})
1170         or return $v_rep_sth->errstr
1171       foreach(@rep_vfields);
1172
1173   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1174
1175   # Now that it has been saved, reset the encrypted fields so that $new
1176   # can still be used.
1177   foreach my $field (keys %{$saved}) {
1178     $new->setfield($field, $saved->{$field});
1179   }
1180
1181   '';
1182
1183 }
1184
1185 sub replace_old {
1186   my( $self ) = shift;
1187   warn "[$me] replace called with no arguments; autoloading old record\n"
1188     if $DEBUG;
1189
1190   my $primary_key = $self->dbdef_table->primary_key;
1191   if ( $primary_key ) {
1192     $self->by_key( $self->$primary_key() ) #this is what's returned
1193       or croak "can't find ". $self->table. ".$primary_key ".
1194         $self->$primary_key();
1195   } else {
1196     croak $self->table. " has no primary key; pass old record as argument";
1197   }
1198
1199 }
1200
1201 =item rep
1202
1203 Depriciated (use replace instead).
1204
1205 =cut
1206
1207 sub rep {
1208   cluck "warning: FS::Record::rep deprecated!";
1209   replace @_; #call method in this scope
1210 }
1211
1212 =item check
1213
1214 Checks virtual fields (using check_blocks).  Subclasses should still provide
1215 a check method to validate real fields, foreign keys, etc., and call this
1216 method via $self->SUPER::check.
1217
1218 (FIXME: Should this method try to make sure that it I<is> being called from
1219 a subclass's check method, to keep the current semantics as far as possible?)
1220
1221 =cut
1222
1223 sub check {
1224   #confess "FS::Record::check not implemented; supply one in subclass!";
1225   my $self = shift;
1226
1227   foreach my $field ($self->virtual_fields) {
1228     for ($self->getfield($field)) {
1229       # See notes on check_block in FS::part_virtual_field.
1230       eval $self->pvf($field)->check_block;
1231       if ( $@ ) {
1232         #this is bad, probably want to follow the stack backtrace up and see
1233         #wtf happened
1234         my $err = "Fatal error checking $field for $self";
1235         cluck "$err: $@";
1236         return "$err (see log for backtrace): $@";
1237
1238       }
1239       $self->setfield($field, $_);
1240     }
1241   }
1242   '';
1243 }
1244
1245 sub _h_statement {
1246   my( $self, $action, $time ) = @_;
1247
1248   $time ||= time;
1249
1250   my @fields =
1251     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1252     real_fields($self->table);
1253   ;
1254
1255   # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1256   # You can see if it changed by the paymask...
1257   if ($conf->exists('encryption') ) {
1258     @fields = grep  $_ ne 'payinfo' && $_ ne 'cvv2', @fields;
1259   }
1260   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1261
1262   "INSERT INTO h_". $self->table. " ( ".
1263       join(', ', qw(history_date history_user history_action), @fields ).
1264     ") VALUES (".
1265       join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1266     ")"
1267   ;
1268 }
1269
1270 =item unique COLUMN
1271
1272 B<Warning>: External use is B<deprecated>.
1273
1274 Replaces COLUMN in record with a unique number, using counters in the
1275 filesystem.  Used by the B<insert> method on single-field unique columns
1276 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1277 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1278
1279 Returns the new value.
1280
1281 =cut
1282
1283 sub unique {
1284   my($self,$field) = @_;
1285   my($table)=$self->table;
1286
1287   croak "Unique called on field $field, but it is ",
1288         $self->getfield($field),
1289         ", not null!"
1290     if $self->getfield($field);
1291
1292   #warn "table $table is tainted" if is_tainted($table);
1293   #warn "field $field is tainted" if is_tainted($field);
1294
1295   my($counter) = new File::CounterFile "$table.$field",0;
1296 # hack for web demo
1297 #  getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1298 #  my($user)=$1;
1299 #  my($counter) = new File::CounterFile "$user/$table.$field",0;
1300 # endhack
1301
1302   my $index = $counter->inc;
1303   $index = $counter->inc while qsearchs($table, { $field=>$index } );
1304
1305   $index =~ /^(\d*)$/;
1306   $index=$1;
1307
1308   $self->setfield($field,$index);
1309
1310 }
1311
1312 =item ut_float COLUMN
1313
1314 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
1315 null.  If there is an error, returns the error, otherwise returns false.
1316
1317 =cut
1318
1319 sub ut_float {
1320   my($self,$field)=@_ ;
1321   ($self->getfield($field) =~ /^(\d+\.\d+)$/ ||
1322    $self->getfield($field) =~ /^(\d+)$/ ||
1323    $self->getfield($field) =~ /^(\d+\.\d+e\d+)$/ ||
1324    $self->getfield($field) =~ /^(\d+e\d+)$/)
1325     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1326   $self->setfield($field,$1);
1327   '';
1328 }
1329 =item ut_floatn COLUMN
1330
1331 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1332 null.  If there is an error, returns the error, otherwise returns false.
1333
1334 =cut
1335
1336 #false laziness w/ut_ipn
1337 sub ut_floatn {
1338   my( $self, $field ) = @_;
1339   if ( $self->getfield($field) =~ /^()$/ ) {
1340     $self->setfield($field,'');
1341     '';
1342   } else {
1343     $self->ut_float($field);
1344   }
1345 }
1346
1347 =item ut_sfloat COLUMN
1348
1349 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1350 May not be null.  If there is an error, returns the error, otherwise returns
1351 false.
1352
1353 =cut
1354
1355 sub ut_sfloat {
1356   my($self,$field)=@_ ;
1357   ($self->getfield($field) =~ /^(-?\d+\.\d+)$/ ||
1358    $self->getfield($field) =~ /^(-?\d+)$/ ||
1359    $self->getfield($field) =~ /^(-?\d+\.\d+[eE]-?\d+)$/ ||
1360    $self->getfield($field) =~ /^(-?\d+[eE]-?\d+)$/)
1361     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1362   $self->setfield($field,$1);
1363   '';
1364 }
1365 =item ut_sfloatn COLUMN
1366
1367 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1368 null.  If there is an error, returns the error, otherwise returns false.
1369
1370 =cut
1371
1372 sub ut_sfloatn {
1373   my( $self, $field ) = @_;
1374   if ( $self->getfield($field) =~ /^()$/ ) {
1375     $self->setfield($field,'');
1376     '';
1377   } else {
1378     $self->ut_sfloat($field);
1379   }
1380 }
1381
1382 =item ut_snumber COLUMN
1383
1384 Check/untaint signed numeric data (whole numbers).  If there is an error,
1385 returns the error, otherwise returns false.
1386
1387 =cut
1388
1389 sub ut_snumber {
1390   my($self, $field) = @_;
1391   $self->getfield($field) =~ /^(-?)\s*(\d+)$/
1392     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1393   $self->setfield($field, "$1$2");
1394   '';
1395 }
1396
1397 =item ut_snumbern COLUMN
1398
1399 Check/untaint signed numeric data (whole numbers).  If there is an error,
1400 returns the error, otherwise returns false.
1401
1402 =cut
1403
1404 sub ut_snumbern {
1405   my($self, $field) = @_;
1406   $self->getfield($field) =~ /^(-?)\s*(\d*)$/
1407     or return "Illegal (numeric) $field: ". $self->getfield($field);
1408   if ($1) {
1409     return "Illegal (numeric) $field: ". $self->getfield($field)
1410       unless $2;
1411   }
1412   $self->setfield($field, "$1$2");
1413   '';
1414 }
1415
1416 =item ut_number COLUMN
1417
1418 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
1419 is an error, returns the error, otherwise returns false.
1420
1421 =cut
1422
1423 sub ut_number {
1424   my($self,$field)=@_;
1425   $self->getfield($field) =~ /^(\d+)$/
1426     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1427   $self->setfield($field,$1);
1428   '';
1429 }
1430
1431 =item ut_numbern COLUMN
1432
1433 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
1434 an error, returns the error, otherwise returns false.
1435
1436 =cut
1437
1438 sub ut_numbern {
1439   my($self,$field)=@_;
1440   $self->getfield($field) =~ /^(\d*)$/
1441     or return "Illegal (numeric) $field: ". $self->getfield($field);
1442   $self->setfield($field,$1);
1443   '';
1444 }
1445
1446 =item ut_money COLUMN
1447
1448 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
1449 is an error, returns the error, otherwise returns false.
1450
1451 =cut
1452
1453 sub ut_money {
1454   my($self,$field)=@_;
1455   $self->setfield($field, 0) if $self->getfield($field) eq '';
1456   $self->getfield($field) =~ /^(\-)? ?(\d*)(\.\d{2})?$/
1457     or return "Illegal (money) $field: ". $self->getfield($field);
1458   #$self->setfield($field, "$1$2$3" || 0);
1459   $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
1460   '';
1461 }
1462
1463 =item ut_text COLUMN
1464
1465 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
1466 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ]
1467 May not be null.  If there is an error, returns the error, otherwise returns
1468 false.
1469
1470 =cut
1471
1472 sub ut_text {
1473   my($self,$field)=@_;
1474   #warn "msgcat ". \&msgcat. "\n";
1475   #warn "notexist ". \&notexist. "\n";
1476   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
1477   $self->getfield($field)
1478     =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/
1479       or return gettext('illegal_or_empty_text'). " $field: ".
1480                  $self->getfield($field);
1481   $self->setfield($field,$1);
1482   '';
1483 }
1484
1485 =item ut_textn COLUMN
1486
1487 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
1488 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
1489 May be null.  If there is an error, returns the error, otherwise returns false.
1490
1491 =cut
1492
1493 sub ut_textn {
1494   my($self,$field)=@_;
1495   $self->getfield($field)
1496     =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/
1497       or return gettext('illegal_text'). " $field: ". $self->getfield($field);
1498   $self->setfield($field,$1);
1499   '';
1500 }
1501
1502 =item ut_alpha COLUMN
1503
1504 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
1505 an error, returns the error, otherwise returns false.
1506
1507 =cut
1508
1509 sub ut_alpha {
1510   my($self,$field)=@_;
1511   $self->getfield($field) =~ /^(\w+)$/
1512     or return "Illegal or empty (alphanumeric) $field: ".
1513               $self->getfield($field);
1514   $self->setfield($field,$1);
1515   '';
1516 }
1517
1518 =item ut_alpha COLUMN
1519
1520 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
1521 error, returns the error, otherwise returns false.
1522
1523 =cut
1524
1525 sub ut_alphan {
1526   my($self,$field)=@_;
1527   $self->getfield($field) =~ /^(\w*)$/
1528     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
1529   $self->setfield($field,$1);
1530   '';
1531 }
1532
1533 =item ut_phonen COLUMN [ COUNTRY ]
1534
1535 Check/untaint phone numbers.  May be null.  If there is an error, returns
1536 the error, otherwise returns false.
1537
1538 Takes an optional two-letter ISO country code; without it or with unsupported
1539 countries, ut_phonen simply calls ut_alphan.
1540
1541 =cut
1542
1543 sub ut_phonen {
1544   my( $self, $field, $country ) = @_;
1545   return $self->ut_alphan($field) unless defined $country;
1546   my $phonen = $self->getfield($field);
1547   if ( $phonen eq '' ) {
1548     $self->setfield($field,'');
1549   } elsif ( $country eq 'US' || $country eq 'CA' ) {
1550     $phonen =~ s/\D//g;
1551     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
1552       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
1553     $phonen = "$1-$2-$3";
1554     $phonen .= " x$4" if $4;
1555     $self->setfield($field,$phonen);
1556   } else {
1557     warn "warning: don't know how to check phone numbers for country $country";
1558     return $self->ut_textn($field);
1559   }
1560   '';
1561 }
1562
1563 =item ut_hex COLUMN
1564
1565 Check/untaint hexadecimal values.
1566
1567 =cut
1568
1569 sub ut_hex {
1570   my($self, $field) = @_;
1571   $self->getfield($field) =~ /^([\da-fA-F]+)$/
1572     or return "Illegal (hex) $field: ". $self->getfield($field);
1573   $self->setfield($field, uc($1));
1574   '';
1575 }
1576
1577 =item ut_hexn COLUMN
1578
1579 Check/untaint hexadecimal values.  May be null.
1580
1581 =cut
1582
1583 sub ut_hexn {
1584   my($self, $field) = @_;
1585   $self->getfield($field) =~ /^([\da-fA-F]*)$/
1586     or return "Illegal (hex) $field: ". $self->getfield($field);
1587   $self->setfield($field, uc($1));
1588   '';
1589 }
1590 =item ut_ip COLUMN
1591
1592 Check/untaint ip addresses.  IPv4 only for now.
1593
1594 =cut
1595
1596 sub ut_ip {
1597   my( $self, $field ) = @_;
1598   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
1599     or return "Illegal (IP address) $field: ". $self->getfield($field);
1600   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
1601   $self->setfield($field, "$1.$2.$3.$4");
1602   '';
1603 }
1604
1605 =item ut_ipn COLUMN
1606
1607 Check/untaint ip addresses.  IPv4 only for now.  May be null.
1608
1609 =cut
1610
1611 sub ut_ipn {
1612   my( $self, $field ) = @_;
1613   if ( $self->getfield($field) =~ /^()$/ ) {
1614     $self->setfield($field,'');
1615     '';
1616   } else {
1617     $self->ut_ip($field);
1618   }
1619 }
1620
1621 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
1622
1623 Check/untaint coordinates.
1624 Accepts the following forms:
1625 DDD.DDDDD
1626 -DDD.DDDDD
1627 DDD MM.MMM
1628 -DDD MM.MMM
1629 DDD MM SS
1630 -DDD MM SS
1631 DDD MM MMM
1632 -DDD MM MMM
1633
1634 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
1635 The latter form (that is, the MMM are thousands of minutes) is
1636 assumed if the "MMM" is exactly three digits or two digits > 59.
1637
1638 To be safe, just use the DDD.DDDDD form.
1639
1640 If LOWER or UPPER are specified, then the coordinate is checked
1641 for lower and upper bounds, respectively.
1642
1643 =cut
1644
1645 sub ut_coord {
1646
1647   my ($self, $field) = (shift, shift);
1648
1649   my $lower = shift if scalar(@_);
1650   my $upper = shift if scalar(@_);
1651   my $coord = $self->getfield($field);
1652   my $neg = $coord =~ s/^(-)//;
1653
1654   my ($d, $m, $s) = (0, 0, 0);
1655
1656   if (
1657     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
1658     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
1659     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
1660   ) {
1661     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
1662     $m = $m / 60;
1663     if ($m > 59) {
1664       return "Invalid (coordinate with minutes > 59) $field: "
1665              . $self->getfield($field);
1666     }
1667
1668     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
1669
1670     if (defined($lower) and ($coord < $lower)) {
1671       return "Invalid (coordinate < $lower) $field: "
1672              . $self->getfield($field);;
1673     }
1674
1675     if (defined($upper) and ($coord > $upper)) {
1676       return "Invalid (coordinate > $upper) $field: "
1677              . $self->getfield($field);;
1678     }
1679
1680     $self->setfield($field, $coord);
1681     return '';
1682   }
1683
1684   return "Invalid (coordinate) $field: " . $self->getfield($field);
1685
1686 }
1687
1688 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
1689
1690 Same as ut_coord, except optionally null.
1691
1692 =cut
1693
1694 sub ut_coordn {
1695
1696   my ($self, $field) = (shift, shift);
1697
1698   if ($self->getfield($field) =~ /^$/) {
1699     return '';
1700   } else {
1701     return $self->ut_coord($field, @_);
1702   }
1703
1704 }
1705
1706
1707 =item ut_domain COLUMN
1708
1709 Check/untaint host and domain names.
1710
1711 =cut
1712
1713 sub ut_domain {
1714   my( $self, $field ) = @_;
1715   #$self->getfield($field) =~/^(\w+\.)*\w+$/
1716   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
1717     or return "Illegal (domain) $field: ". $self->getfield($field);
1718   $self->setfield($field,$1);
1719   '';
1720 }
1721
1722 =item ut_name COLUMN
1723
1724 Check/untaint proper names; allows alphanumerics, spaces and the following
1725 punctuation: , . - '
1726
1727 May not be null.
1728
1729 =cut
1730
1731 sub ut_name {
1732   my( $self, $field ) = @_;
1733   $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
1734     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
1735   $self->setfield($field,$1);
1736   '';
1737 }
1738
1739 =item ut_zip COLUMN
1740
1741 Check/untaint zip codes.
1742
1743 =cut
1744
1745 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
1746
1747 sub ut_zip {
1748   my( $self, $field, $country ) = @_;
1749
1750   if ( $country eq 'US' ) {
1751
1752     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
1753       or return gettext('illegal_zip'). " $field for country $country: ".
1754                 $self->getfield($field);
1755     $self->setfield($field, $1);
1756
1757   } elsif ( $country eq 'CA' ) {
1758
1759     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
1760       or return gettext('illegal_zip'). " $field for country $country: ".
1761                 $self->getfield($field);
1762     $self->setfield($field, "$1 $2");
1763
1764   } else {
1765
1766     if ( $self->getfield($field) =~ /^\s*$/
1767          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
1768        )
1769     {
1770       $self->setfield($field,'');
1771     } else {
1772       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
1773         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
1774       $self->setfield($field,$1);
1775     }
1776
1777   }
1778
1779   '';
1780 }
1781
1782 =item ut_country COLUMN
1783
1784 Check/untaint country codes.  Country names are changed to codes, if possible -
1785 see L<Locale::Country>.
1786
1787 =cut
1788
1789 sub ut_country {
1790   my( $self, $field ) = @_;
1791   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
1792     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
1793          && country2code($1) ) {
1794       $self->setfield($field,uc(country2code($1)));
1795     }
1796   }
1797   $self->getfield($field) =~ /^(\w\w)$/
1798     or return "Illegal (country) $field: ". $self->getfield($field);
1799   $self->setfield($field,uc($1));
1800   '';
1801 }
1802
1803 =item ut_anything COLUMN
1804
1805 Untaints arbitrary data.  Be careful.
1806
1807 =cut
1808
1809 sub ut_anything {
1810   my( $self, $field ) = @_;
1811   $self->getfield($field) =~ /^(.*)$/s
1812     or return "Illegal $field: ". $self->getfield($field);
1813   $self->setfield($field,$1);
1814   '';
1815 }
1816
1817 =item ut_enum COLUMN CHOICES_ARRAYREF
1818
1819 Check/untaint a column, supplying all possible choices, like the "enum" type.
1820
1821 =cut
1822
1823 sub ut_enum {
1824   my( $self, $field, $choices ) = @_;
1825   foreach my $choice ( @$choices ) {
1826     if ( $self->getfield($field) eq $choice ) {
1827       $self->setfield($choice);
1828       return '';
1829     }
1830   }
1831   return "Illegal (enum) field $field: ". $self->getfield($field);
1832 }
1833
1834 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
1835
1836 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
1837 on the column first.
1838
1839 =cut
1840
1841 sub ut_foreign_key {
1842   my( $self, $field, $table, $foreign ) = @_;
1843   qsearchs($table, { $foreign => $self->getfield($field) })
1844     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
1845               " in $table.$foreign";
1846   '';
1847 }
1848
1849 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
1850
1851 Like ut_foreign_key, except the null value is also allowed.
1852
1853 =cut
1854
1855 sub ut_foreign_keyn {
1856   my( $self, $field, $table, $foreign ) = @_;
1857   $self->getfield($field)
1858     ? $self->ut_foreign_key($field, $table, $foreign)
1859     : '';
1860 }
1861
1862 =item ut_agentnum_acl
1863
1864 Checks this column as an agentnum, taking into account the current users's
1865 ACLs.
1866
1867 =cut
1868
1869 sub ut_agentnum_acl {
1870   my( $self, $field, $null_acl ) = @_;
1871
1872   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
1873   return "Illegal agentnum: $error" if $error;
1874
1875   my $curuser = $FS::CurrentUser::CurrentUser;
1876
1877   if ( $self->$field() ) {
1878
1879     return "Access deined"
1880       unless $curuser->agentnum($self->$field());
1881
1882   } else {
1883
1884     return "Access denied"
1885       unless $curuser->access_right($null_acl);
1886
1887   }
1888
1889   '';
1890
1891 }
1892
1893 =item virtual_fields [ TABLE ]
1894
1895 Returns a list of virtual fields defined for the table.  This should not
1896 be exported, and should only be called as an instance or class method.
1897
1898 =cut
1899
1900 sub virtual_fields {
1901   my $self = shift;
1902   my $table;
1903   $table = $self->table or confess "virtual_fields called on non-table";
1904
1905   confess "Unknown table $table" unless dbdef->table($table);
1906
1907   return () unless dbdef->table('part_virtual_field');
1908
1909   unless ( $virtual_fields_cache{$table} ) {
1910     my $query = 'SELECT name from part_virtual_field ' .
1911                 "WHERE dbtable = '$table'";
1912     my $dbh = dbh;
1913     my $result = $dbh->selectcol_arrayref($query);
1914     confess "Error executing virtual fields query: $query: ". $dbh->errstr
1915       if $dbh->err;
1916     $virtual_fields_cache{$table} = $result;
1917   }
1918
1919   @{$virtual_fields_cache{$table}};
1920
1921 }
1922
1923
1924 =item fields [ TABLE ]
1925
1926 This is a wrapper for real_fields and virtual_fields.  Code that called
1927 fields before should probably continue to call fields.
1928
1929 =cut
1930
1931 sub fields {
1932   my $something = shift;
1933   my $table;
1934   if($something->isa('FS::Record')) {
1935     $table = $something->table;
1936   } else {
1937     $table = $something;
1938     $something = "FS::$table";
1939   }
1940   return (real_fields($table), $something->virtual_fields());
1941 }
1942
1943 =back
1944
1945 =item pvf FIELD_NAME
1946
1947 Returns the FS::part_virtual_field object corresponding to a field in the
1948 record (specified by FIELD_NAME).
1949
1950 =cut
1951
1952 sub pvf {
1953   my ($self, $name) = (shift, shift);
1954
1955   if(grep /^$name$/, $self->virtual_fields) {
1956     return qsearchs('part_virtual_field', { dbtable => $self->table,
1957                                             name    => $name } );
1958   }
1959   ''
1960 }
1961
1962 =head1 SUBROUTINES
1963
1964 =over 4
1965
1966 =item real_fields [ TABLE ]
1967
1968 Returns a list of the real columns in the specified table.  Called only by
1969 fields() and other subroutines elsewhere in FS::Record.
1970
1971 =cut
1972
1973 sub real_fields {
1974   my $table = shift;
1975
1976   my($table_obj) = dbdef->table($table);
1977   confess "Unknown table $table" unless $table_obj;
1978   $table_obj->columns;
1979 }
1980
1981 =item _quote VALUE, TABLE, COLUMN
1982
1983 This is an internal function used to construct SQL statements.  It returns
1984 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
1985 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
1986
1987 =cut
1988
1989 sub _quote {
1990   my($value, $table, $column) = @_;
1991   my $column_obj = dbdef->table($table)->column($column);
1992   my $column_type = $column_obj->type;
1993   my $nullable = $column_obj->null;
1994
1995   warn "  $table.$column: $value ($column_type".
1996        ( $nullable ? ' NULL' : ' NOT NULL' ).
1997        ")\n" if $DEBUG > 2;
1998
1999   if ( $value eq '' && $nullable ) {
2000     'NULL'
2001   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2002     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2003           "using 0 instead";
2004     0;
2005   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2006             ! $column_type =~ /(char|binary|text)$/i ) {
2007     $value;
2008   } else {
2009     dbh->quote($value);
2010   }
2011 }
2012
2013 =item vfieldpart_hashref TABLE
2014
2015 Returns a hashref of virtual field names and vfieldparts applicable to the given
2016 TABLE.
2017
2018 =cut
2019
2020 sub vfieldpart_hashref {
2021   my $self = shift;
2022   my $table = $self->table;
2023
2024   return {} unless dbdef->table('part_virtual_field');
2025
2026   my $dbh = dbh;
2027   my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
2028                   "dbtable = '$table'";
2029   my $sth = $dbh->prepare($statement);
2030   $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
2031   return { map { $_->{name}, $_->{vfieldpart} }
2032     @{$sth->fetchall_arrayref({})} };
2033
2034 }
2035
2036
2037 =item hfields TABLE
2038
2039 This is deprecated.  Don't use it.
2040
2041 It returns a hash-type list with the fields of this record's table set true.
2042
2043 =cut
2044
2045 sub hfields {
2046   carp "warning: hfields is deprecated";
2047   my($table)=@_;
2048   my(%hash);
2049   foreach (fields($table)) {
2050     $hash{$_}=1;
2051   }
2052   \%hash;
2053 }
2054
2055 sub _dump {
2056   my($self)=@_;
2057   join("\n", map {
2058     "$_: ". $self->getfield($_). "|"
2059   } (fields($self->table)) );
2060 }
2061
2062 =item encrypt($value)
2063
2064 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2065
2066 Returns the encrypted string.
2067
2068 You should generally not have to worry about calling this, as the system handles this for you.
2069
2070 =cut
2071
2072
2073 sub encrypt {
2074   my ($self, $value) = @_;
2075   my $encrypted;
2076
2077   my $conf = new FS::Conf;
2078   if ($conf->exists('encryption')) {
2079     if ($self->is_encrypted($value)) {
2080       # Return the original value if it isn't plaintext.
2081       $encrypted = $value;
2082     } else {
2083       $self->loadRSA;
2084       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2085         # RSA doesn't like the empty string so let's pack it up
2086         # The database doesn't like the RSA data so uuencode it
2087         my $length = length($value)+1;
2088         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2089       } else {
2090         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2091       }
2092     }
2093   }
2094   return $encrypted;
2095 }
2096
2097 =item is_encrypted($value)
2098
2099 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2100
2101 =cut
2102
2103
2104 sub is_encrypted {
2105   my ($self, $value) = @_;
2106   # Possible Bug - Some work may be required here....
2107
2108   if ($value =~ /^M/ && length($value) > 80) {
2109     return 1;
2110   } else {
2111     return 0;
2112   }
2113 }
2114
2115 =item decrypt($value)
2116
2117 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2118
2119 You should generally not have to worry about calling this, as the system handles this for you.
2120
2121 =cut
2122
2123 sub decrypt {
2124   my ($self,$value) = @_;
2125   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2126   my $conf = new FS::Conf;
2127   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2128     $self->loadRSA;
2129     if (ref($rsa_decrypt) =~ /::RSA/) {
2130       my $encrypted = unpack ("u*", $value);
2131       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2132       if ($@) {warn "Decryption Failed"};
2133     }
2134   }
2135   return $decrypted;
2136 }
2137
2138 sub loadRSA {
2139     my $self = shift;
2140     #Initialize the Module
2141     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2142
2143     my $conf = new FS::Conf;
2144     if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
2145       $rsa_module = $conf->config('encryptionmodule');
2146     }
2147
2148     if (!$rsa_loaded) {
2149         eval ("require $rsa_module"); # No need to import the namespace
2150         $rsa_loaded++;
2151     }
2152     # Initialize Encryption
2153     if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
2154       my $public_key = join("\n",$conf->config('encryptionpublickey'));
2155       $rsa_encrypt = $rsa_module->new_public_key($public_key);
2156     }
2157
2158     # Intitalize Decryption
2159     if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
2160       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2161       $rsa_decrypt = $rsa_module->new_private_key($private_key);
2162     }
2163 }
2164
2165 sub DESTROY { return; }
2166
2167 #sub DESTROY {
2168 #  my $self = shift;
2169 #  #use Carp qw(cluck);
2170 #  #cluck "DESTROYING $self";
2171 #  warn "DESTROYING $self";
2172 #}
2173
2174 #sub is_tainted {
2175 #             return ! eval { join('',@_), kill 0; 1; };
2176 #         }
2177
2178 =back
2179
2180 =head1 BUGS
2181
2182 This module should probably be renamed, since much of the functionality is
2183 of general use.  It is not completely unlike Adapter::DBI (see below).
2184
2185 Exported qsearch and qsearchs should be deprecated in favor of method calls
2186 (against an FS::Record object like the old search and searchs that qsearch
2187 and qsearchs were on top of.)
2188
2189 The whole fields / hfields mess should be removed.
2190
2191 The various WHERE clauses should be subroutined.
2192
2193 table string should be deprecated in favor of DBIx::DBSchema::Table.
2194
2195 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
2196 true maps to the database (and WHERE clauses) would also help.
2197
2198 The ut_ methods should ask the dbdef for a default length.
2199
2200 ut_sqltype (like ut_varchar) should all be defined
2201
2202 A fallback check method should be provided which uses the dbdef.
2203
2204 The ut_money method assumes money has two decimal digits.
2205
2206 The Pg money kludge in the new method only strips `$'.
2207
2208 The ut_phonen method only checks US-style phone numbers.
2209
2210 The _quote function should probably use ut_float instead of a regex.
2211
2212 All the subroutines probably should be methods, here or elsewhere.
2213
2214 Probably should borrow/use some dbdef methods where appropriate (like sub
2215 fields)
2216
2217 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
2218 or allow it to be set.  Working around it is ugly any way around - DBI should
2219 be fixed.  (only affects RDBMS which return uppercase column names)
2220
2221 ut_zip should take an optional country like ut_phone.
2222
2223 =head1 SEE ALSO
2224
2225 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
2226
2227 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
2228
2229 http://poop.sf.net/
2230
2231 =cut
2232
2233 1;
2234