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