FS/FS/Record.pm

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