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