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