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