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