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.33;
  13 use FS::UID qw(dbh getotaker datasrc driver_name);
  14 use FS::CurrentUser;
  15 use FS::Schema qw(dbdef);
  16 use FS::SearchCache;
  17 use FS::Msgcat qw(gettext);
  18 use FS::Conf;
  19
  20 use FS::part_virtual_field;
  21
  22 use Tie::IxHash;
  23
  24 @ISA = qw(Exporter);
  25
  26 #export dbdef for now... everything else expects to find it here
  27 @EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch);
  28
  29 $DEBUG = 0;
  30 $me = '[FS::Record]';
  31
  32 $nowarn_identical = 0;
  33 $no_update_diff = 0;
  34
  35 my $rsa_module;
  36 my $rsa_loaded;
  37 my $rsa_encrypt;
  38 my $rsa_decrypt;
  39
  40 FS::UID->install_callback( sub {
  41   $conf = new FS::Conf;
  42   $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
  43 } );
  44
  45
  46 =head1 NAME
  47
  48 FS::Record - Database record objects
  49
  50 =head1 SYNOPSIS
  51
  52     use FS::Record;
  53     use FS::Record qw(dbh fields qsearch qsearchs);
  54
  55     $record = new FS::Record 'table', \%hash;
  56     $record = new FS::Record 'table', { 'column' => 'value', ... };
  57
  58     $record  = qsearchs FS::Record 'table', \%hash;
  59     $record  = qsearchs FS::Record 'table', { 'column' => 'value', ... };
  60     @records = qsearch  FS::Record 'table', \%hash;
  61     @records = qsearch  FS::Record 'table', { 'column' => 'value', ... };
  62
  63     $table = $record->table;
  64     $dbdef_table = $record->dbdef_table;
  65
  66     $value = $record->get('column');
  67     $value = $record->getfield('column');
  68     $value = $record->column;
  69
  70     $record->set( 'column' => 'value' );
  71     $record->setfield( 'column' => 'value' );
  72     $record->column('value');
  73
  74     %hash = $record->hash;
  75
  76     $hashref = $record->hashref;
  77
  78     $error = $record->insert;
  79
  80     $error = $record->delete;
  81
  82     $error = $new_record->replace($old_record);
  83
  84     # external use deprecated - handled by the database (at least for Pg, mysql)
  85     $value = $record->unique('column');
  86
  87     $error = $record->ut_float('column');
  88     $error = $record->ut_floatn('column');
  89     $error = $record->ut_number('column');
  90     $error = $record->ut_numbern('column');
  91     $error = $record->ut_snumber('column');
  92     $error = $record->ut_snumbern('column');
  93     $error = $record->ut_money('column');
  94     $error = $record->ut_text('column');
  95     $error = $record->ut_textn('column');
  96     $error = $record->ut_alpha('column');
  97     $error = $record->ut_alphan('column');
  98     $error = $record->ut_phonen('column');
  99     $error = $record->ut_anything('column');
 100     $error = $record->ut_name('column');
 101
 102     $quoted_value = _quote($value,'table','field');
 103
 104     #deprecated
 105     $fields = hfields('table');
 106     if ( $fields->{Field} ) { # etc.
 107
 108     @fields = fields 'table'; #as a subroutine
 109     @fields = $record->fields; #as a method call
 110
 111
 112 =head1 DESCRIPTION
 113
 114 (Mostly) object-oriented interface to database records.  Records are currently
 115 implemented on top of DBI.  FS::Record is intended as a base class for
 116 table-specific classes to inherit from, i.e. FS::cust_main.
 117
 118 =head1 CONSTRUCTORS
 119
 120 =over 4
 121
 122 =item new [ TABLE, ] HASHREF
 123
 124 Creates a new record.  It doesn't store it in the database, though.  See
 125 L<"insert"> for that.
 126
 127 Note that the object stores this hash reference, not a distinct copy of the
 128 hash it points to.  You can ask the object for a copy with the I<hash>
 129 method.
 130
 131 TABLE can only be omitted when a dervived class overrides the table method.
 132
 133 =cut
 134
 135 sub new {
 136   my $proto = shift;
 137   my $class = ref($proto) || $proto;
 138   my $self = {};
 139   bless ($self, $class);
 140
 141   unless ( defined ( $self->table ) ) {
 142     $self->{'Table'} = shift;
 143     carp "warning: FS::Record::new called with table name ". $self->{'Table'};
 144   }
 145
 146   $self->{'Hash'} = shift;
 147
 148   foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
 149     $self->{'Hash'}{$field}='';
 150   }
 151
 152   $self->_rebless if $self->can('_rebless');
 153
 154   $self->{'modified'} = 0;
 155
 156   $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
 157
 158   $self;
 159 }
 160
 161 sub new_or_cached {
 162   my $proto = shift;
 163   my $class = ref($proto) || $proto;
 164   my $self = {};
 165   bless ($self, $class);
 166
 167   $self->{'Table'} = shift unless defined ( $self->table );
 168
 169   my $hashref = $self->{'Hash'} = shift;
 170   my $cache = shift;
 171   if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
 172     my $obj = $cache->cache->{$hashref->{$cache->key}};
 173     $obj->_cache($hashref, $cache) if $obj->can('_cache');
 174     $obj;
 175   } else {
 176     $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
 177   }
 178
 179 }
 180
 181 sub create {
 182   my $proto = shift;
 183   my $class = ref($proto) || $proto;
 184   my $self = {};
 185   bless ($self, $class);
 186   if ( defined $self->table ) {
 187     cluck "create constructor is deprecated, use new!";
 188     $self->new(@_);
 189   } else {
 190     croak "FS::Record::create called (not from a subclass)!";
 191   }
 192 }
 193
 194 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 195
 196 Searches the database for all records matching (at least) the key/value pairs
 197 in HASHREF.  Returns all the records found as `FS::TABLE' objects if that
 198 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
 199 objects.
 200
 201 The preferred usage is to pass a hash reference of named parameters:
 202
 203   my @records = qsearch( {
 204                            'table'     => 'table_name',
 205                            'hashref'   => { 'field' => 'value'
 206                                             'field' => { 'op'    => '<',
 207                                                          'value' => '420',
 208                                                        },
 209                                           },
 210
 211                            #these are optional...
 212                            'select'    => '*',
 213                            'extra_sql' => 'AND field ',
 214                            'order_by'  => 'ORDER BY something',
 215                            #'cache_obj' => '', #optional
 216                            'addl_from' => 'LEFT JOIN othtable USING ( field )',
 217                          }
 218                        );
 219
 220 Much code still uses old-style positional parameters, this is also probably
 221 fine in the common case where there are only two parameters:
 222
 223   my @records = qsearch( 'table', { 'field' => 'value' } );
 224
 225 ###oops, argh, FS::Record::new only lets us create database fields.
 226 #Normal behaviour if SELECT is not specified is `*', as in
 227 #C<SELECT * FROM table WHERE ...>.  However, there is an experimental new
 228 #feature where you can specify SELECT - remember, the objects returned,
 229 #although blessed into the appropriate `FS::TABLE' package, will only have the
 230 #fields you specify.  This might have unwanted results if you then go calling
 231 #regular FS::TABLE methods
 232 #on it.
 233
 234 =cut
 235
 236 sub qsearch {
 237   my($stable, $record, $select, $extra_sql, $order_by, $cache, $addl_from );
 238   if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too
 239     my $opt = shift;
 240     $stable    = $opt->{'table'}     or die "table name is required";
 241     $record    = $opt->{'hashref'}   || {};
 242     $select    = $opt->{'select'}    || '*';
 243     $extra_sql = $opt->{'extra_sql'} || '';
 244     $order_by  = $opt->{'order_by'}  || '';
 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   $statement .= " $order_by"  if defined($order_by);
 366
 367   warn "[debug]$me $statement\n" if $DEBUG > 1;
 368   my $sth = $dbh->prepare($statement)
 369     or croak "$dbh->errstr doing $statement";
 370
 371   my $bind = 1;
 372
 373   foreach my $field (
 374     grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
 375   ) {
 376     if ( $record->{$field} =~ /^\d+(\.\d+)?$/
 377          && dbdef->table($table)->column($field)->type =~ /(int|(big)?serial)/i
 378     ) {
 379       $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } );
 380     } else {
 381       $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_VARCHAR } );
 382     }
 383   }
 384
 385 #  $sth->execute( map $record->{$_},
 386 #    grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
 387 #  ) or croak "Error executing \"$statement\": ". $sth->errstr;
 388
 389   $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
 390
 391   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
 392     @virtual_fields = "FS::$table"->virtual_fields;
 393   } else {
 394     cluck "warning: FS::$table not loaded; virtual fields not returned either";
 395     @virtual_fields = ();
 396   }
 397
 398   my %result;
 399   tie %result, "Tie::IxHash";
 400   my @stuff = @{ $sth->fetchall_arrayref( {} ) };
 401   if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
 402     %result = map { $_->{$pkey}, $_ } @stuff;
 403   } else {
 404     @result{@stuff} = @stuff;
 405   }
 406
 407   $sth->finish;
 408
 409   if ( keys(%result) and @virtual_fields ) {
 410     $statement =
 411       "SELECT virtual_field.recnum, part_virtual_field.name, ".
 412              "virtual_field.value ".
 413       "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ".
 414       "WHERE part_virtual_field.dbtable = '$table' AND ".
 415       "virtual_field.recnum IN (".
 416       join(',', keys(%result)). ") AND part_virtual_field.name IN ('".
 417       join(q!', '!, @virtual_fields) . "')";
 418     warn "[debug]$me $statement\n" if $DEBUG > 1;
 419     $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement";
 420     $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
 421
 422     foreach (@{ $sth->fetchall_arrayref({}) }) {
 423       my $recnum = $_->{recnum};
 424       my $name = $_->{name};
 425       my $value = $_->{value};
 426       if (exists($result{$recnum})) {
 427         $result{$recnum}->{$name} = $value;
 428       }
 429     }
 430   }
 431   my @return;
 432   if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
 433     if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
 434       #derivied class didn't override new method, so this optimization is safe
 435       if ( $cache ) {
 436         @return = map {
 437           new_or_cached( "FS::$table", { %{$_} }, $cache )
 438         } values(%result);
 439       } else {
 440         @return = map {
 441           new( "FS::$table", { %{$_} } )
 442         } values(%result);
 443       }
 444     } else {
 445       #okay, its been tested
 446       # warn "untested code (class FS::$table uses custom new method)";
 447       @return = map {
 448         eval 'FS::'. $table. '->new( { %{$_} } )';
 449       } values(%result);
 450     }
 451
 452     # Check for encrypted fields and decrypt them.
 453    ## only in the local copy, not the cached object
 454     if ( $conf && $conf->exists('encryption') # $conf doesn't exist when doing
 455                                               # the initial search for
 456                                               # access_user
 457          && eval 'defined(@FS::'. $table . '::encrypted_fields)') {
 458       foreach my $record (@return) {
 459         foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 460           # Set it directly... This may cause a problem in the future...
 461           $record->setfield($field, $record->decrypt($record->getfield($field)));
 462         }
 463       }
 464     }
 465   } else {
 466     cluck "warning: FS::$table not loaded; returning FS::Record objects";
 467     @return = map {
 468       FS::Record->new( $table, { %{$_} } );
 469     } values(%result);
 470   }
 471   return @return;
 472 }
 473
 474 =item by_key PRIMARY_KEY_VALUE
 475
 476 This is a class method that returns the record with the given primary key
 477 value.  This method is only useful in FS::Record subclasses.  For example:
 478
 479   my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
 480
 481 is equivalent to:
 482
 483   my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
 484
 485 =cut
 486
 487 sub by_key {
 488   my ($class, $pkey_value) = @_;
 489
 490   my $table = $class->table
 491     or croak "No table for $class found";
 492
 493   my $dbdef_table = dbdef->table($table)
 494     or die "No schema for table $table found - ".
 495            "do you need to create it or run dbdef-create?";
 496   my $pkey = $dbdef_table->primary_key
 497     or die "No primary key for table $table";
 498
 499   return qsearchs($table, { $pkey => $pkey_value });
 500 }
 501
 502 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
 503
 504 Experimental JOINed search method.  Using this method, you can execute a
 505 single SELECT spanning multiple tables, and cache the results for subsequent
 506 method calls.  Interface will almost definately change in an incompatible
 507 fashion.
 508
 509 Arguments:
 510
 511 =cut
 512
 513 sub jsearch {
 514   my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
 515   my $cache = FS::SearchCache->new( $ptable, $pkey );
 516   my %saw;
 517   ( $cache,
 518     grep { !$saw{$_->getfield($pkey)}++ }
 519       qsearch($table, $record, $select, $extra_sql, $cache )
 520   );
 521 }
 522
 523 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
 524
 525 Same as qsearch, except that if more than one record matches, it B<carp>s but
 526 returns the first.  If this happens, you either made a logic error in asking
 527 for a single item, or your data is corrupted.
 528
 529 =cut
 530
 531 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
 532   my $table = $_[0];
 533   my(@result) = qsearch(@_);
 534   cluck "warning: Multiple records in scalar search ($table)"
 535     if scalar(@result) > 1;
 536   #should warn more vehemently if the search was on a primary key?
 537   scalar(@result) ? ($result[0]) : ();
 538 }
 539
 540 =back
 541
 542 =head1 METHODS
 543
 544 =over 4
 545
 546 =item table
 547
 548 Returns the table name.
 549
 550 =cut
 551
 552 sub table {
 553 #  cluck "warning: FS::Record::table deprecated; supply one in subclass!";
 554   my $self = shift;
 555   $self -> {'Table'};
 556 }
 557
 558 =item dbdef_table
 559
 560 Returns the DBIx::DBSchema::Table object for the table.
 561
 562 =cut
 563
 564 sub dbdef_table {
 565   my($self)=@_;
 566   my($table)=$self->table;
 567   dbdef->table($table);
 568 }
 569
 570 =item primary_key
 571
 572 Returns the primary key for the table.
 573
 574 =cut
 575
 576 sub primary_key {
 577   my $self = shift;
 578   my $pkey = $self->dbdef_table->primary_key;
 579 }
 580
 581 =item get, getfield COLUMN
 582
 583 Returns the value of the column/field/key COLUMN.
 584
 585 =cut
 586
 587 sub get {
 588   my($self,$field) = @_;
 589   # to avoid "Use of unitialized value" errors
 590   if ( defined ( $self->{Hash}->{$field} ) ) {
 591     $self->{Hash}->{$field};
 592   } else {
 593     '';
 594   }
 595 }
 596 sub getfield {
 597   my $self = shift;
 598   $self->get(@_);
 599 }
 600
 601 =item set, setfield COLUMN, VALUE
 602
 603 Sets the value of the column/field/key COLUMN to VALUE.  Returns VALUE.
 604
 605 =cut
 606
 607 sub set {
 608   my($self,$field,$value) = @_;
 609   $self->{'modified'} = 1;
 610   $self->{'Hash'}->{$field} = $value;
 611 }
 612 sub setfield {
 613   my $self = shift;
 614   $self->set(@_);
 615 }
 616
 617 =item AUTLOADED METHODS
 618
 619 $record->column is a synonym for $record->get('column');
 620
 621 $record->column('value') is a synonym for $record->set('column','value');
 622
 623 =cut
 624
 625 # readable/safe
 626 sub AUTOLOAD {
 627   my($self,$value)=@_;
 628   my($field)=$AUTOLOAD;
 629   $field =~ s/.*://;
 630   if ( defined($value) ) {
 631     confess "errant AUTOLOAD $field for $self (arg $value)"
 632       unless ref($self) && $self->can('setfield');
 633     $self->setfield($field,$value);
 634   } else {
 635     confess "errant AUTOLOAD $field for $self (no args)"
 636       unless ref($self) && $self->can('getfield');
 637     $self->getfield($field);
 638   }
 639 }
 640
 641 # efficient
 642 #sub AUTOLOAD {
 643 #  my $field = $AUTOLOAD;
 644 #  $field =~ s/.*://;
 645 #  if ( defined($_[1]) ) {
 646 #    $_[0]->setfield($field, $_[1]);
 647 #  } else {
 648 #    $_[0]->getfield($field);
 649 #  }
 650 #}
 651
 652 =item hash
 653
 654 Returns a list of the column/value pairs, usually for assigning to a new hash.
 655
 656 To make a distinct duplicate of an FS::Record object, you can do:
 657
 658     $new = new FS::Record ( $old->table, { $old->hash } );
 659
 660 =cut
 661
 662 sub hash {
 663   my($self) = @_;
 664   confess $self. ' -> hash: Hash attribute is undefined'
 665     unless defined($self->{'Hash'});
 666   %{ $self->{'Hash'} };
 667 }
 668
 669 =item hashref
 670
 671 Returns a reference to the column/value hash.  This may be deprecated in the
 672 future; if there's a reason you can't just use the autoloaded or get/set
 673 methods, speak up.
 674
 675 =cut
 676
 677 sub hashref {
 678   my($self) = @_;
 679   $self->{'Hash'};
 680 }
 681
 682 =item modified
 683
 684 Returns true if any of this object's values have been modified with set (or via
 685 an autoloaded method).  Doesn't yet recognize when you retreive a hashref and
 686 modify that.
 687
 688 =cut
 689
 690 sub modified {
 691   my $self = shift;
 692   $self->{'modified'};
 693 }
 694
 695 =item select_for_update
 696
 697 Selects this record with the SQL "FOR UPDATE" command.  This can be useful as
 698 a mutex.
 699
 700 =cut
 701
 702 sub select_for_update {
 703   my $self = shift;
 704   my $primary_key = $self->primary_key;
 705   qsearchs( {
 706     'select'    => '*',
 707     'table'     => $self->table,
 708     'hashref'   => { $primary_key => $self->$primary_key() },
 709     'extra_sql' => 'FOR UPDATE',
 710   } );
 711 }
 712
 713 =item insert
 714
 715 Inserts this record to the database.  If there is an error, returns the error,
 716 otherwise returns false.
 717
 718 =cut
 719
 720 sub insert {
 721   my $self = shift;
 722   my $saved = {};
 723
 724   warn "$self -> insert" if $DEBUG;
 725
 726   my $error = $self->check;
 727   return $error if $error;
 728
 729   #single-field unique keys are given a value if false
 730   #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
 731   foreach ( $self->dbdef_table->unique_singles) {
 732     $self->unique($_) unless $self->getfield($_);
 733   }
 734
 735   #and also the primary key, if the database isn't going to
 736   my $primary_key = $self->dbdef_table->primary_key;
 737   my $db_seq = 0;
 738   if ( $primary_key ) {
 739     my $col = $self->dbdef_table->column($primary_key);
 740
 741     $db_seq =
 742       uc($col->type) =~ /^(BIG)?SERIAL\d?/
 743       || ( driver_name eq 'Pg'
 744              && defined($col->default)
 745              && $col->default =~ /^nextval\(/i
 746          )
 747       || ( driver_name eq 'mysql'
 748              && defined($col->local)
 749              && $col->local =~ /AUTO_INCREMENT/i
 750          );
 751     $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
 752   }
 753
 754   my $table = $self->table;
 755
 756
 757   # Encrypt before the database
 758   my $conf = new FS::Conf;
 759   if ($conf->exists('encryption') && defined(eval '@FS::'. $table . '::encrypted_fields')) {
 760     foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 761       $self->{'saved'} = $self->getfield($field);
 762       $self->setfield($field, $self->encrypt($self->getfield($field)));
 763     }
 764   }
 765
 766
 767   #false laziness w/delete
 768   my @real_fields =
 769     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
 770     real_fields($table)
 771   ;
 772   my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
 773   #eslaf
 774
 775   my $statement = "INSERT INTO $table ";
 776   if ( @real_fields ) {
 777     $statement .=
 778       "( ".
 779         join( ', ', @real_fields ).
 780       ") VALUES (".
 781         join( ', ', @values ).
 782        ")"
 783     ;
 784   } else {
 785     $statement .= 'DEFAULT VALUES';
 786   }
 787   warn "[debug]$me $statement\n" if $DEBUG > 1;
 788   my $sth = dbh->prepare($statement) or return dbh->errstr;
 789
 790   local $SIG{HUP} = 'IGNORE';
 791   local $SIG{INT} = 'IGNORE';
 792   local $SIG{QUIT} = 'IGNORE';
 793   local $SIG{TERM} = 'IGNORE';
 794   local $SIG{TSTP} = 'IGNORE';
 795   local $SIG{PIPE} = 'IGNORE';
 796
 797   $sth->execute or return $sth->errstr;
 798
 799   # get inserted id from the database, if applicable & needed
 800   if ( $db_seq && ! $self->getfield($primary_key) ) {
 801     warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
 802
 803     my $insertid = '';
 804
 805     if ( driver_name eq 'Pg' ) {
 806
 807       #my $oid = $sth->{'pg_oid_status'};
 808       #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
 809
 810       my $default = $self->dbdef_table->column($primary_key)->default;
 811       unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
 812         dbh->rollback if $FS::UID::AutoCommit;
 813         return "can't parse $table.$primary_key default value".
 814                " for sequence name: $default";
 815       }
 816       my $sequence = $1;
 817
 818       my $i_sql = "SELECT currval('$sequence')";
 819       my $i_sth = dbh->prepare($i_sql) or do {
 820         dbh->rollback if $FS::UID::AutoCommit;
 821         return dbh->errstr;
 822       };
 823       $i_sth->execute() or do { #$i_sth->execute($oid)
 824         dbh->rollback if $FS::UID::AutoCommit;
 825         return $i_sth->errstr;
 826       };
 827       $insertid = $i_sth->fetchrow_arrayref->[0];
 828
 829     } elsif ( driver_name eq 'mysql' ) {
 830
 831       $insertid = dbh->{'mysql_insertid'};
 832       # work around mysql_insertid being null some of the time, ala RT :/
 833       unless ( $insertid ) {
 834         warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
 835              "using SELECT LAST_INSERT_ID();";
 836         my $i_sql = "SELECT LAST_INSERT_ID()";
 837         my $i_sth = dbh->prepare($i_sql) or do {
 838           dbh->rollback if $FS::UID::AutoCommit;
 839           return dbh->errstr;
 840         };
 841         $i_sth->execute or do {
 842           dbh->rollback if $FS::UID::AutoCommit;
 843           return $i_sth->errstr;
 844         };
 845         $insertid = $i_sth->fetchrow_arrayref->[0];
 846       }
 847
 848     } else {
 849
 850       dbh->rollback if $FS::UID::AutoCommit;
 851       return "don't know how to retreive inserted ids from ". driver_name.
 852              ", try using counterfiles (maybe run dbdef-create?)";
 853
 854     }
 855
 856     $self->setfield($primary_key, $insertid);
 857
 858   }
 859
 860   my @virtual_fields =
 861       grep defined($self->getfield($_)) && $self->getfield($_) ne "",
 862           $self->virtual_fields;
 863   if (@virtual_fields) {
 864     my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
 865
 866     my $vfieldpart = $self->vfieldpart_hashref;
 867
 868     my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
 869                     "VALUES (?, ?, ?)";
 870
 871     my $v_sth = dbh->prepare($v_statement) or do {
 872       dbh->rollback if $FS::UID::AutoCommit;
 873       return dbh->errstr;
 874     };
 875
 876     foreach (keys(%v_values)) {
 877       $v_sth->execute($self->getfield($primary_key),
 878                       $vfieldpart->{$_},
 879                       $v_values{$_})
 880       or do {
 881         dbh->rollback if $FS::UID::AutoCommit;
 882         return $v_sth->errstr;
 883       };
 884     }
 885   }
 886
 887
 888   my $h_sth;
 889   if ( defined dbdef->table('h_'. $table) ) {
 890     my $h_statement = $self->_h_statement('insert');
 891     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
 892     $h_sth = dbh->prepare($h_statement) or do {
 893       dbh->rollback if $FS::UID::AutoCommit;
 894       return dbh->errstr;
 895     };
 896   } else {
 897     $h_sth = '';
 898   }
 899   $h_sth->execute or return $h_sth->errstr if $h_sth;
 900
 901   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 902
 903   # Now that it has been saved, reset the encrypted fields so that $new
 904   # can still be used.
 905   foreach my $field (keys %{$saved}) {
 906     $self->setfield($field, $saved->{$field});
 907   }
 908
 909   '';
 910 }
 911
 912 =item add
 913
 914 Depriciated (use insert instead).
 915
 916 =cut
 917
 918 sub add {
 919   cluck "warning: FS::Record::add deprecated!";
 920   insert @_; #call method in this scope
 921 }
 922
 923 =item delete
 924
 925 Delete this record from the database.  If there is an error, returns the error,
 926 otherwise returns false.
 927
 928 =cut
 929
 930 sub delete {
 931   my $self = shift;
 932
 933   my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
 934     map {
 935       $self->getfield($_) eq ''
 936         #? "( $_ IS NULL OR $_ = \"\" )"
 937         ? ( driver_name eq 'Pg'
 938               ? "$_ IS NULL"
 939               : "( $_ IS NULL OR $_ = \"\" )"
 940           )
 941         : "$_ = ". _quote($self->getfield($_),$self->table,$_)
 942     } ( $self->dbdef_table->primary_key )
 943           ? ( $self->dbdef_table->primary_key)
 944           : real_fields($self->table)
 945   );
 946   warn "[debug]$me $statement\n" if $DEBUG > 1;
 947   my $sth = dbh->prepare($statement) or return dbh->errstr;
 948
 949   my $h_sth;
 950   if ( defined dbdef->table('h_'. $self->table) ) {
 951     my $h_statement = $self->_h_statement('delete');
 952     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
 953     $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
 954   } else {
 955     $h_sth = '';
 956   }
 957
 958   my $primary_key = $self->dbdef_table->primary_key;
 959   my $v_sth;
 960   my @del_vfields;
 961   my $vfp = $self->vfieldpart_hashref;
 962   foreach($self->virtual_fields) {
 963     next if $self->getfield($_) eq '';
 964     unless(@del_vfields) {
 965       my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
 966       $v_sth = dbh->prepare($st) or return dbh->errstr;
 967     }
 968     push @del_vfields, $_;
 969   }
 970
 971   local $SIG{HUP} = 'IGNORE';
 972   local $SIG{INT} = 'IGNORE';
 973   local $SIG{QUIT} = 'IGNORE';
 974   local $SIG{TERM} = 'IGNORE';
 975   local $SIG{TSTP} = 'IGNORE';
 976   local $SIG{PIPE} = 'IGNORE';
 977
 978   my $rc = $sth->execute or return $sth->errstr;
 979   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
 980   $h_sth->execute or return $h_sth->errstr if $h_sth;
 981   $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
 982     or return $v_sth->errstr
 983         foreach (@del_vfields);
 984
 985   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
 986
 987   #no need to needlessly destoy the data either (causes problems actually)
 988   #undef $self; #no need to keep object!
 989
 990   '';
 991 }
 992
 993 =item del
 994
 995 Depriciated (use delete instead).
 996
 997 =cut
 998
 999 sub del {
1000   cluck "warning: FS::Record::del deprecated!";
1001   &delete(@_); #call method in this scope
1002 }
1003
1004 =item replace OLD_RECORD
1005
1006 Replace the OLD_RECORD with this one in the database.  If there is an error,
1007 returns the error, otherwise returns false.
1008
1009 =cut
1010
1011 sub replace {
1012   my ($new, $old) = (shift, shift);
1013
1014   $old = $new->replace_old unless defined($old);
1015
1016   warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1017
1018   if ( $new->can('replace_check') ) {
1019     my $error = $new->replace_check($old);
1020     return $error if $error;
1021   }
1022
1023   return "Records not in same table!" unless $new->table eq $old->table;
1024
1025   my $primary_key = $old->dbdef_table->primary_key;
1026   return "Can't change primary key $primary_key ".
1027          'from '. $old->getfield($primary_key).
1028          ' to ' . $new->getfield($primary_key)
1029     if $primary_key
1030        && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1031
1032   my $error = $new->check;
1033   return $error if $error;
1034
1035   # Encrypt for replace
1036   my $conf = new FS::Conf;
1037   my $saved = {};
1038   if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) {
1039     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1040       $saved->{$field} = $new->getfield($field);
1041       $new->setfield($field, $new->encrypt($new->getfield($field)));
1042     }
1043   }
1044
1045   #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1046   my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1047                    ? ($_, $new->getfield($_)) : () } $old->fields;
1048
1049   unless (keys(%diff) || $no_update_diff ) {
1050     carp "[warning]$me $new -> replace $old: records identical"
1051       unless $nowarn_identical;
1052     return '';
1053   }
1054
1055   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1056     map {
1057       "$_ = ". _quote($new->getfield($_),$old->table,$_)
1058     } real_fields($old->table)
1059   ). ' WHERE '.
1060     join(' AND ',
1061       map {
1062
1063         if ( $old->getfield($_) eq '' ) {
1064
1065          #false laziness w/qsearch
1066          if ( driver_name eq 'Pg' ) {
1067             my $type = $old->dbdef_table->column($_)->type;
1068             if ( $type =~ /(int|(big)?serial)/i ) {
1069               qq-( $_ IS NULL )-;
1070             } else {
1071               qq-( $_ IS NULL OR $_ = '' )-;
1072             }
1073           } else {
1074             qq-( $_ IS NULL OR $_ = "" )-;
1075           }
1076
1077         } else {
1078           "$_ = ". _quote($old->getfield($_),$old->table,$_);
1079         }
1080
1081       } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1082     )
1083   ;
1084   warn "[debug]$me $statement\n" if $DEBUG > 1;
1085   my $sth = dbh->prepare($statement) or return dbh->errstr;
1086
1087   my $h_old_sth;
1088   if ( defined dbdef->table('h_'. $old->table) ) {
1089     my $h_old_statement = $old->_h_statement('replace_old');
1090     warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1091     $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1092   } else {
1093     $h_old_sth = '';
1094   }
1095
1096   my $h_new_sth;
1097   if ( defined dbdef->table('h_'. $new->table) ) {
1098     my $h_new_statement = $new->_h_statement('replace_new');
1099     warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1100     $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1101   } else {
1102     $h_new_sth = '';
1103   }
1104
1105   # For virtual fields we have three cases with different SQL
1106   # statements: add, replace, delete
1107   my $v_add_sth;
1108   my $v_rep_sth;
1109   my $v_del_sth;
1110   my (@add_vfields, @rep_vfields, @del_vfields);
1111   my $vfp = $old->vfieldpart_hashref;
1112   foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
1113     if($diff{$_} eq '') {
1114       # Delete
1115       unless(@del_vfields) {
1116         my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
1117                  "AND vfieldpart = ?";
1118         warn "[debug]$me $st\n" if $DEBUG > 2;
1119         $v_del_sth = dbh->prepare($st) or return dbh->errstr;
1120       }
1121       push @del_vfields, $_;
1122     } elsif($old->getfield($_) eq '') {
1123       # Add
1124       unless(@add_vfields) {
1125         my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
1126                  "VALUES (?, ?, ?)";
1127         warn "[debug]$me $st\n" if $DEBUG > 2;
1128         $v_add_sth = dbh->prepare($st) or return dbh->errstr;
1129       }
1130       push @add_vfields, $_;
1131     } else {
1132       # Replace
1133       unless(@rep_vfields) {
1134         my $st = "UPDATE virtual_field SET value = ? ".
1135                  "WHERE recnum = ? AND vfieldpart = ?";
1136         warn "[debug]$me $st\n" if $DEBUG > 2;
1137         $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
1138       }
1139       push @rep_vfields, $_;
1140     }
1141   }
1142
1143   local $SIG{HUP} = 'IGNORE';
1144   local $SIG{INT} = 'IGNORE';
1145   local $SIG{QUIT} = 'IGNORE';
1146   local $SIG{TERM} = 'IGNORE';
1147   local $SIG{TSTP} = 'IGNORE';
1148   local $SIG{PIPE} = 'IGNORE';
1149
1150   my $rc = $sth->execute or return $sth->errstr;
1151   #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1152   $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1153   $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1154
1155   $v_del_sth->execute($old->getfield($primary_key),
1156                       $vfp->{$_})
1157         or return $v_del_sth->errstr
1158       foreach(@del_vfields);
1159
1160   $v_add_sth->execute($new->getfield($_),
1161                       $old->getfield($primary_key),
1162                       $vfp->{$_})
1163         or return $v_add_sth->errstr
1164       foreach(@add_vfields);
1165
1166   $v_rep_sth->execute($new->getfield($_),
1167                       $old->getfield($primary_key),
1168                       $vfp->{$_})
1169         or return $v_rep_sth->errstr
1170       foreach(@rep_vfields);
1171
1172   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1173
1174   # Now that it has been saved, reset the encrypted fields so that $new
1175   # can still be used.
1176   foreach my $field (keys %{$saved}) {
1177     $new->setfield($field, $saved->{$field});
1178   }
1179
1180   '';
1181
1182 }
1183
1184 sub replace_old {
1185   my( $self ) = shift;
1186   warn "[$me] replace called with no arguments; autoloading old record\n"
1187     if $DEBUG;
1188
1189   my $primary_key = $self->dbdef_table->primary_key;
1190   if ( $primary_key ) {
1191     $self->by_key( $self->$primary_key() ) #this is what's returned
1192       or croak "can't find ". $self->table. ".$primary_key ".
1193         $self->$primary_key();
1194   } else {
1195     croak $self->table. " has no primary key; pass old record as argument";
1196   }
1197
1198 }
1199
1200 =item rep
1201
1202 Depriciated (use replace instead).
1203
1204 =cut
1205
1206 sub rep {
1207   cluck "warning: FS::Record::rep deprecated!";
1208   replace @_; #call method in this scope
1209 }
1210
1211 =item check
1212
1213 Checks virtual fields (using check_blocks).  Subclasses should still provide
1214 a check method to validate real fields, foreign keys, etc., and call this
1215 method via $self->SUPER::check.
1216
1217 (FIXME: Should this method try to make sure that it I<is> being called from
1218 a subclass's check method, to keep the current semantics as far as possible?)
1219
1220 =cut
1221
1222 sub check {
1223   #confess "FS::Record::check not implemented; supply one in subclass!";
1224   my $self = shift;
1225
1226   foreach my $field ($self->virtual_fields) {
1227     for ($self->getfield($field)) {
1228       # See notes on check_block in FS::part_virtual_field.
1229       eval $self->pvf($field)->check_block;
1230       if ( $@ ) {
1231         #this is bad, probably want to follow the stack backtrace up and see
1232         #wtf happened
1233         my $err = "Fatal error checking $field for $self";
1234         cluck "$err: $@";
1235         return "$err (see log for backtrace): $@";
1236
1237       }
1238       $self->setfield($field, $_);
1239     }
1240   }
1241   '';
1242 }
1243
1244 sub _h_statement {
1245   my( $self, $action, $time ) = @_;
1246
1247   $time ||= time;
1248
1249   my @fields =
1250     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1251     real_fields($self->table);
1252   ;
1253
1254   # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1255   # You can see if it changed by the paymask...
1256   my $conf = new FS::Conf;
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_binary('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_binary('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_binary('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