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