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
1343   my $error =
1344     FS::Record::batch_import( {
1345       table     => $table,
1346       formats   => \%formats,
1347       job       => $job,
1348       file      => $file,
1349       type      => $type,
1350       format    => $param->{format},
1351       params    => { map { $_ => $param->{$_} } @pass_params },
1352     } );
1353
1354   unlink $file;
1355
1356   die "$error\n" if $error;
1357 }
1358
1359 sub batch_import {
1360   my $param = shift;
1361
1362   my $table     = $param->{table};
1363   my $formats   = $param->{formats};
1364   my $params    = $param->{params};
1365
1366   my $job       = $param->{job};
1367
1368   my $filename  = $param->{file};
1369   my $type      = $param->{type} || 'csv';
1370
1371   my $format = $param->{'format'};
1372
1373   die "unknown format $format" unless exists $formats->{ $format };
1374   my @fields    = @{ $formats->{ $format } };
1375
1376   my $count;
1377   my $parser;
1378   my @buffer = ();
1379   if ( $type eq 'csv' ) {
1380
1381     $parser = new Text::CSV_XS;
1382
1383     @buffer = split(/\r?\n/, slurp($filename) );
1384     $count = scalar(@buffer);
1385
1386   } elsif ( $type eq 'xls' ) {
1387
1388     eval "use Spreadsheet::ParseExcel;";
1389     die $@ if $@;
1390
1391     my $excel = new Spreadsheet::ParseExcel::Workbook->Parse($filename);
1392     $parser = $excel->{Worksheet}[0]; #first sheet
1393
1394     $count = $parser->{MaxRow} || $parser->{MinRow};
1395     $count++;
1396
1397   } else {
1398     die "Unknown file type $type\n";
1399   }
1400
1401   #my $columns;
1402
1403   local $SIG{HUP} = 'IGNORE';
1404   local $SIG{INT} = 'IGNORE';
1405   local $SIG{QUIT} = 'IGNORE';
1406   local $SIG{TERM} = 'IGNORE';
1407   local $SIG{TSTP} = 'IGNORE';
1408   local $SIG{PIPE} = 'IGNORE';
1409
1410   my $oldAutoCommit = $FS::UID::AutoCommit;
1411   local $FS::UID::AutoCommit = 0;
1412   my $dbh = dbh;
1413
1414   my $line;
1415   my $row = 0;
1416   my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
1417   while (1) {
1418
1419     my @columns = ();
1420     if ( $type eq 'csv' ) {
1421
1422       last unless scalar(@buffer);
1423       $line = shift(@buffer);
1424
1425       $parser->parse($line) or do {
1426         $dbh->rollback if $oldAutoCommit;
1427         return "can't parse: ". $parser->error_input();
1428       };
1429       @columns = $parser->fields();
1430
1431     } elsif ( $type eq 'xls' ) {
1432
1433       last if $row > ($parser->{MaxRow} || $parser->{MinRow});
1434
1435       my @row = @{ $parser->{Cells}[$row] };
1436       @columns = map $_->{Val}, @row;
1437
1438       #my $z = 'A';
1439       #warn $z++. ": $_\n" for @columns;
1440
1441     } else {
1442       die "Unknown file type $type\n";
1443     }
1444
1445     my %hash = %$params;
1446
1447     foreach my $field ( @fields ) {
1448
1449       my $value = shift @columns;
1450
1451       if ( ref($field) eq 'CODE' ) {
1452         &{$field}(\%hash, $value);
1453       } else {
1454         $hash{$field} = $value if length($value);
1455       }
1456
1457     }
1458
1459     my $class = "FS::$table";
1460
1461     my $record = $class->new( \%hash );
1462
1463     my $error = $record->insert;
1464
1465     if ( $error ) {
1466       $dbh->rollback if $oldAutoCommit;
1467       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
1468     }
1469
1470     $row++;
1471
1472     if ( $job && time - $min_sec > $last ) { #progress bar
1473       $job->update_statustext( int(100 * $row / $count) );
1474       $last = time;
1475     }
1476
1477   }
1478
1479   $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
1480
1481   return "Empty file!" unless $row;
1482
1483   ''; #no error
1484
1485 }
1486
1487 sub _h_statement {
1488   my( $self, $action, $time ) = @_;
1489
1490   $time ||= time;
1491
1492   my @fields =
1493     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1494     real_fields($self->table);
1495   ;
1496
1497   # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1498   # You can see if it changed by the paymask...
1499   if ($conf && $conf->exists('encryption') ) {
1500     @fields = grep  $_ ne 'payinfo' && $_ ne 'cvv2', @fields;
1501   }
1502   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1503
1504   "INSERT INTO h_". $self->table. " ( ".
1505       join(', ', qw(history_date history_user history_action), @fields ).
1506     ") VALUES (".
1507       join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1508     ")"
1509   ;
1510 }
1511
1512 =item unique COLUMN
1513
1514 B<Warning>: External use is B<deprecated>.
1515
1516 Replaces COLUMN in record with a unique number, using counters in the
1517 filesystem.  Used by the B<insert> method on single-field unique columns
1518 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1519 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1520
1521 Returns the new value.
1522
1523 =cut
1524
1525 sub unique {
1526   my($self,$field) = @_;
1527   my($table)=$self->table;
1528
1529   croak "Unique called on field $field, but it is ",
1530         $self->getfield($field),
1531         ", not null!"
1532     if $self->getfield($field);
1533
1534   #warn "table $table is tainted" if is_tainted($table);
1535   #warn "field $field is tainted" if is_tainted($field);
1536
1537   my($counter) = new File::CounterFile "$table.$field",0;
1538 # hack for web demo
1539 #  getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1540 #  my($user)=$1;
1541 #  my($counter) = new File::CounterFile "$user/$table.$field",0;
1542 # endhack
1543
1544   my $index = $counter->inc;
1545   $index = $counter->inc while qsearchs($table, { $field=>$index } );
1546
1547   $index =~ /^(\d*)$/;
1548   $index=$1;
1549
1550   $self->setfield($field,$index);
1551
1552 }
1553
1554 =item ut_float COLUMN
1555
1556 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
1557 null.  If there is an error, returns the error, otherwise returns false.
1558
1559 =cut
1560
1561 sub ut_float {
1562   my($self,$field)=@_ ;
1563   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
1564    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
1565    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
1566    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
1567     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1568   $self->setfield($field,$1);
1569   '';
1570 }
1571 =item ut_floatn COLUMN
1572
1573 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1574 null.  If there is an error, returns the error, otherwise returns false.
1575
1576 =cut
1577
1578 #false laziness w/ut_ipn
1579 sub ut_floatn {
1580   my( $self, $field ) = @_;
1581   if ( $self->getfield($field) =~ /^()$/ ) {
1582     $self->setfield($field,'');
1583     '';
1584   } else {
1585     $self->ut_float($field);
1586   }
1587 }
1588
1589 =item ut_sfloat COLUMN
1590
1591 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1592 May not be null.  If there is an error, returns the error, otherwise returns
1593 false.
1594
1595 =cut
1596
1597 sub ut_sfloat {
1598   my($self,$field)=@_ ;
1599   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
1600    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
1601    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
1602    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
1603     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1604   $self->setfield($field,$1);
1605   '';
1606 }
1607 =item ut_sfloatn COLUMN
1608
1609 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1610 null.  If there is an error, returns the error, otherwise returns false.
1611
1612 =cut
1613
1614 sub ut_sfloatn {
1615   my( $self, $field ) = @_;
1616   if ( $self->getfield($field) =~ /^()$/ ) {
1617     $self->setfield($field,'');
1618     '';
1619   } else {
1620     $self->ut_sfloat($field);
1621   }
1622 }
1623
1624 =item ut_snumber COLUMN
1625
1626 Check/untaint signed numeric data (whole numbers).  If there is an error,
1627 returns the error, otherwise returns false.
1628
1629 =cut
1630
1631 sub ut_snumber {
1632   my($self, $field) = @_;
1633   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
1634     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1635   $self->setfield($field, "$1$2");
1636   '';
1637 }
1638
1639 =item ut_snumbern COLUMN
1640
1641 Check/untaint signed numeric data (whole numbers).  If there is an error,
1642 returns the error, otherwise returns false.
1643
1644 =cut
1645
1646 sub ut_snumbern {
1647   my($self, $field) = @_;
1648   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
1649     or return "Illegal (numeric) $field: ". $self->getfield($field);
1650   if ($1) {
1651     return "Illegal (numeric) $field: ". $self->getfield($field)
1652       unless $2;
1653   }
1654   $self->setfield($field, "$1$2");
1655   '';
1656 }
1657
1658 =item ut_number COLUMN
1659
1660 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
1661 is an error, returns the error, otherwise returns false.
1662
1663 =cut
1664
1665 sub ut_number {
1666   my($self,$field)=@_;
1667   $self->getfield($field) =~ /^\s*(\d+)\s*$/
1668     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1669   $self->setfield($field,$1);
1670   '';
1671 }
1672
1673 =item ut_numbern COLUMN
1674
1675 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
1676 an error, returns the error, otherwise returns false.
1677
1678 =cut
1679
1680 sub ut_numbern {
1681   my($self,$field)=@_;
1682   $self->getfield($field) =~ /^\s*(\d*)\s*$/
1683     or return "Illegal (numeric) $field: ". $self->getfield($field);
1684   $self->setfield($field,$1);
1685   '';
1686 }
1687
1688 =item ut_money COLUMN
1689
1690 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
1691 is an error, returns the error, otherwise returns false.
1692
1693 =cut
1694
1695 sub ut_money {
1696   my($self,$field)=@_;
1697   $self->setfield($field, 0) if $self->getfield($field) eq '';
1698   $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/
1699     or return "Illegal (money) $field: ". $self->getfield($field);
1700   #$self->setfield($field, "$1$2$3" || 0);
1701   $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
1702   '';
1703 }
1704
1705 =item ut_text COLUMN
1706
1707 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
1708 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ]
1709 May not be null.  If there is an error, returns the error, otherwise returns
1710 false.
1711
1712 =cut
1713
1714 sub ut_text {
1715   my($self,$field)=@_;
1716   #warn "msgcat ". \&msgcat. "\n";
1717   #warn "notexist ". \&notexist. "\n";
1718   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
1719   $self->getfield($field)
1720     =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/
1721       or return gettext('illegal_or_empty_text'). " $field: ".
1722                  $self->getfield($field);
1723   $self->setfield($field,$1);
1724   '';
1725 }
1726
1727 =item ut_textn COLUMN
1728
1729 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
1730 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
1731 May be null.  If there is an error, returns the error, otherwise returns false.
1732
1733 =cut
1734
1735 sub ut_textn {
1736   my($self,$field)=@_;
1737   $self->getfield($field)
1738     =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/
1739       or return gettext('illegal_text'). " $field: ". $self->getfield($field);
1740   $self->setfield($field,$1);
1741   '';
1742 }
1743
1744 =item ut_alpha COLUMN
1745
1746 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
1747 an error, returns the error, otherwise returns false.
1748
1749 =cut
1750
1751 sub ut_alpha {
1752   my($self,$field)=@_;
1753   $self->getfield($field) =~ /^(\w+)$/
1754     or return "Illegal or empty (alphanumeric) $field: ".
1755               $self->getfield($field);
1756   $self->setfield($field,$1);
1757   '';
1758 }
1759
1760 =item ut_alpha COLUMN
1761
1762 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
1763 error, returns the error, otherwise returns false.
1764
1765 =cut
1766
1767 sub ut_alphan {
1768   my($self,$field)=@_;
1769   $self->getfield($field) =~ /^(\w*)$/
1770     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
1771   $self->setfield($field,$1);
1772   '';
1773 }
1774
1775 =item ut_alpha_lower COLUMN
1776
1777 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
1778 there is an error, returns the error, otherwise returns false.
1779
1780 =cut
1781
1782 sub ut_alpha_lower {
1783   my($self,$field)=@_;
1784   $self->getfield($field) =~ /[[:upper:]]/
1785     and return "Uppercase characters are not permitted in $field";
1786   $self->ut_alpha($field);
1787 }
1788
1789 =item ut_phonen COLUMN [ COUNTRY ]
1790
1791 Check/untaint phone numbers.  May be null.  If there is an error, returns
1792 the error, otherwise returns false.
1793
1794 Takes an optional two-letter ISO country code; without it or with unsupported
1795 countries, ut_phonen simply calls ut_alphan.
1796
1797 =cut
1798
1799 sub ut_phonen {
1800   my( $self, $field, $country ) = @_;
1801   return $self->ut_alphan($field) unless defined $country;
1802   my $phonen = $self->getfield($field);
1803   if ( $phonen eq '' ) {
1804     $self->setfield($field,'');
1805   } elsif ( $country eq 'US' || $country eq 'CA' ) {
1806     $phonen =~ s/\D//g;
1807     $phonen = $conf->config('cust_main-default_areacode').$phonen
1808       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
1809     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
1810       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
1811     $phonen = "$1-$2-$3";
1812     $phonen .= " x$4" if $4;
1813     $self->setfield($field,$phonen);
1814   } else {
1815     warn "warning: don't know how to check phone numbers for country $country";
1816     return $self->ut_textn($field);
1817   }
1818   '';
1819 }
1820
1821 =item ut_hex COLUMN
1822
1823 Check/untaint hexadecimal values.
1824
1825 =cut
1826
1827 sub ut_hex {
1828   my($self, $field) = @_;
1829   $self->getfield($field) =~ /^([\da-fA-F]+)$/
1830     or return "Illegal (hex) $field: ". $self->getfield($field);
1831   $self->setfield($field, uc($1));
1832   '';
1833 }
1834
1835 =item ut_hexn COLUMN
1836
1837 Check/untaint hexadecimal values.  May be null.
1838
1839 =cut
1840
1841 sub ut_hexn {
1842   my($self, $field) = @_;
1843   $self->getfield($field) =~ /^([\da-fA-F]*)$/
1844     or return "Illegal (hex) $field: ". $self->getfield($field);
1845   $self->setfield($field, uc($1));
1846   '';
1847 }
1848 =item ut_ip COLUMN
1849
1850 Check/untaint ip addresses.  IPv4 only for now.
1851
1852 =cut
1853
1854 sub ut_ip {
1855   my( $self, $field ) = @_;
1856   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
1857     or return "Illegal (IP address) $field: ". $self->getfield($field);
1858   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
1859   $self->setfield($field, "$1.$2.$3.$4");
1860   '';
1861 }
1862
1863 =item ut_ipn COLUMN
1864
1865 Check/untaint ip addresses.  IPv4 only for now.  May be null.
1866
1867 =cut
1868
1869 sub ut_ipn {
1870   my( $self, $field ) = @_;
1871   if ( $self->getfield($field) =~ /^()$/ ) {
1872     $self->setfield($field,'');
1873     '';
1874   } else {
1875     $self->ut_ip($field);
1876   }
1877 }
1878
1879 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
1880
1881 Check/untaint coordinates.
1882 Accepts the following forms:
1883 DDD.DDDDD
1884 -DDD.DDDDD
1885 DDD MM.MMM
1886 -DDD MM.MMM
1887 DDD MM SS
1888 -DDD MM SS
1889 DDD MM MMM
1890 -DDD MM MMM
1891
1892 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
1893 The latter form (that is, the MMM are thousands of minutes) is
1894 assumed if the "MMM" is exactly three digits or two digits > 59.
1895
1896 To be safe, just use the DDD.DDDDD form.
1897
1898 If LOWER or UPPER are specified, then the coordinate is checked
1899 for lower and upper bounds, respectively.
1900
1901 =cut
1902
1903 sub ut_coord {
1904
1905   my ($self, $field) = (shift, shift);
1906
1907   my $lower = shift if scalar(@_);
1908   my $upper = shift if scalar(@_);
1909   my $coord = $self->getfield($field);
1910   my $neg = $coord =~ s/^(-)//;
1911
1912   my ($d, $m, $s) = (0, 0, 0);
1913
1914   if (
1915     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
1916     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
1917     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
1918   ) {
1919     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
1920     $m = $m / 60;
1921     if ($m > 59) {
1922       return "Invalid (coordinate with minutes > 59) $field: "
1923              . $self->getfield($field);
1924     }
1925
1926     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
1927
1928     if (defined($lower) and ($coord < $lower)) {
1929       return "Invalid (coordinate < $lower) $field: "
1930              . $self->getfield($field);;
1931     }
1932
1933     if (defined($upper) and ($coord > $upper)) {
1934       return "Invalid (coordinate > $upper) $field: "
1935              . $self->getfield($field);;
1936     }
1937
1938     $self->setfield($field, $coord);
1939     return '';
1940   }
1941
1942   return "Invalid (coordinate) $field: " . $self->getfield($field);
1943
1944 }
1945
1946 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
1947
1948 Same as ut_coord, except optionally null.
1949
1950 =cut
1951
1952 sub ut_coordn {
1953
1954   my ($self, $field) = (shift, shift);
1955
1956   if ($self->getfield($field) =~ /^$/) {
1957     return '';
1958   } else {
1959     return $self->ut_coord($field, @_);
1960   }
1961
1962 }
1963
1964
1965 =item ut_domain COLUMN
1966
1967 Check/untaint host and domain names.
1968
1969 =cut
1970
1971 sub ut_domain {
1972   my( $self, $field ) = @_;
1973   #$self->getfield($field) =~/^(\w+\.)*\w+$/
1974   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
1975     or return "Illegal (domain) $field: ". $self->getfield($field);
1976   $self->setfield($field,$1);
1977   '';
1978 }
1979
1980 =item ut_name COLUMN
1981
1982 Check/untaint proper names; allows alphanumerics, spaces and the following
1983 punctuation: , . - '
1984
1985 May not be null.
1986
1987 =cut
1988
1989 sub ut_name {
1990   my( $self, $field ) = @_;
1991   $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
1992     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
1993   $self->setfield($field,$1);
1994   '';
1995 }
1996
1997 =item ut_zip COLUMN
1998
1999 Check/untaint zip codes.
2000
2001 =cut
2002
2003 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2004
2005 sub ut_zip {
2006   my( $self, $field, $country ) = @_;
2007
2008   if ( $country eq 'US' ) {
2009
2010     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2011       or return gettext('illegal_zip'). " $field for country $country: ".
2012                 $self->getfield($field);
2013     $self->setfield($field, $1);
2014
2015   } elsif ( $country eq 'CA' ) {
2016
2017     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2018       or return gettext('illegal_zip'). " $field for country $country: ".
2019                 $self->getfield($field);
2020     $self->setfield($field, "$1 $2");
2021
2022   } else {
2023
2024     if ( $self->getfield($field) =~ /^\s*$/
2025          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2026        )
2027     {
2028       $self->setfield($field,'');
2029     } else {
2030       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
2031         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2032       $self->setfield($field,$1);
2033     }
2034
2035   }
2036
2037   '';
2038 }
2039
2040 =item ut_country COLUMN
2041
2042 Check/untaint country codes.  Country names are changed to codes, if possible -
2043 see L<Locale::Country>.
2044
2045 =cut
2046
2047 sub ut_country {
2048   my( $self, $field ) = @_;
2049   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2050     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2051          && country2code($1) ) {
2052       $self->setfield($field,uc(country2code($1)));
2053     }
2054   }
2055   $self->getfield($field) =~ /^(\w\w)$/
2056     or return "Illegal (country) $field: ". $self->getfield($field);
2057   $self->setfield($field,uc($1));
2058   '';
2059 }
2060
2061 =item ut_anything COLUMN
2062
2063 Untaints arbitrary data.  Be careful.
2064
2065 =cut
2066
2067 sub ut_anything {
2068   my( $self, $field ) = @_;
2069   $self->getfield($field) =~ /^(.*)$/s
2070     or return "Illegal $field: ". $self->getfield($field);
2071   $self->setfield($field,$1);
2072   '';
2073 }
2074
2075 =item ut_enum COLUMN CHOICES_ARRAYREF
2076
2077 Check/untaint a column, supplying all possible choices, like the "enum" type.
2078
2079 =cut
2080
2081 sub ut_enum {
2082   my( $self, $field, $choices ) = @_;
2083   foreach my $choice ( @$choices ) {
2084     if ( $self->getfield($field) eq $choice ) {
2085       $self->setfield($choice);
2086       return '';
2087     }
2088   }
2089   return "Illegal (enum) field $field: ". $self->getfield($field);
2090 }
2091
2092 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2093
2094 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
2095 on the column first.
2096
2097 =cut
2098
2099 sub ut_foreign_key {
2100   my( $self, $field, $table, $foreign ) = @_;
2101   return '' if $no_check_foreign;
2102   qsearchs($table, { $foreign => $self->getfield($field) })
2103     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
2104               " in $table.$foreign";
2105   '';
2106 }
2107
2108 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2109
2110 Like ut_foreign_key, except the null value is also allowed.
2111
2112 =cut
2113
2114 sub ut_foreign_keyn {
2115   my( $self, $field, $table, $foreign ) = @_;
2116   $self->getfield($field)
2117     ? $self->ut_foreign_key($field, $table, $foreign)
2118     : '';
2119 }
2120
2121 =item ut_agentnum_acl
2122
2123 Checks this column as an agentnum, taking into account the current users's
2124 ACLs.
2125
2126 =cut
2127
2128 sub ut_agentnum_acl {
2129   my( $self, $field, $null_acl ) = @_;
2130
2131   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
2132   return "Illegal agentnum: $error" if $error;
2133
2134   my $curuser = $FS::CurrentUser::CurrentUser;
2135
2136   if ( $self->$field() ) {
2137
2138     return "Access denied"
2139       unless $curuser->agentnum($self->$field());
2140
2141   } else {
2142
2143     return "Access denied"
2144       unless $curuser->access_right($null_acl);
2145
2146   }
2147
2148   '';
2149
2150 }
2151
2152 =item virtual_fields [ TABLE ]
2153
2154 Returns a list of virtual fields defined for the table.  This should not
2155 be exported, and should only be called as an instance or class method.
2156
2157 =cut
2158
2159 sub virtual_fields {
2160   my $self = shift;
2161   my $table;
2162   $table = $self->table or confess "virtual_fields called on non-table";
2163
2164   confess "Unknown table $table" unless dbdef->table($table);
2165
2166   return () unless dbdef->table('part_virtual_field');
2167
2168   unless ( $virtual_fields_cache{$table} ) {
2169     my $query = 'SELECT name from part_virtual_field ' .
2170                 "WHERE dbtable = '$table'";
2171     my $dbh = dbh;
2172     my $result = $dbh->selectcol_arrayref($query);
2173     confess "Error executing virtual fields query: $query: ". $dbh->errstr
2174       if $dbh->err;
2175     $virtual_fields_cache{$table} = $result;
2176   }
2177
2178   @{$virtual_fields_cache{$table}};
2179
2180 }
2181
2182
2183 =item fields [ TABLE ]
2184
2185 This is a wrapper for real_fields and virtual_fields.  Code that called
2186 fields before should probably continue to call fields.
2187
2188 =cut
2189
2190 sub fields {
2191   my $something = shift;
2192   my $table;
2193   if($something->isa('FS::Record')) {
2194     $table = $something->table;
2195   } else {
2196     $table = $something;
2197     $something = "FS::$table";
2198   }
2199   return (real_fields($table), $something->virtual_fields());
2200 }
2201
2202 =item pvf FIELD_NAME
2203
2204 Returns the FS::part_virtual_field object corresponding to a field in the
2205 record (specified by FIELD_NAME).
2206
2207 =cut
2208
2209 sub pvf {
2210   my ($self, $name) = (shift, shift);
2211
2212   if(grep /^$name$/, $self->virtual_fields) {
2213     return qsearchs('part_virtual_field', { dbtable => $self->table,
2214                                             name    => $name } );
2215   }
2216   ''
2217 }
2218
2219 =item vfieldpart_hashref TABLE
2220
2221 Returns a hashref of virtual field names and vfieldparts applicable to the given
2222 TABLE.
2223
2224 =cut
2225
2226 sub vfieldpart_hashref {
2227   my $self = shift;
2228   my $table = $self->table;
2229
2230   return {} unless dbdef->table('part_virtual_field');
2231
2232   my $dbh = dbh;
2233   my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
2234                   "dbtable = '$table'";
2235   my $sth = $dbh->prepare($statement);
2236   $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
2237   return { map { $_->{name}, $_->{vfieldpart} }
2238     @{$sth->fetchall_arrayref({})} };
2239
2240 }
2241
2242 =item encrypt($value)
2243
2244 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2245
2246 Returns the encrypted string.
2247
2248 You should generally not have to worry about calling this, as the system handles this for you.
2249
2250 =cut
2251
2252 sub encrypt {
2253   my ($self, $value) = @_;
2254   my $encrypted;
2255
2256   if ($conf->exists('encryption')) {
2257     if ($self->is_encrypted($value)) {
2258       # Return the original value if it isn't plaintext.
2259       $encrypted = $value;
2260     } else {
2261       $self->loadRSA;
2262       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2263         # RSA doesn't like the empty string so let's pack it up
2264         # The database doesn't like the RSA data so uuencode it
2265         my $length = length($value)+1;
2266         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2267       } else {
2268         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2269       }
2270     }
2271   }
2272   return $encrypted;
2273 }
2274
2275 =item is_encrypted($value)
2276
2277 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2278
2279 =cut
2280
2281
2282 sub is_encrypted {
2283   my ($self, $value) = @_;
2284   # Possible Bug - Some work may be required here....
2285
2286   if ($value =~ /^M/ && length($value) > 80) {
2287     return 1;
2288   } else {
2289     return 0;
2290   }
2291 }
2292
2293 =item decrypt($value)
2294
2295 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2296
2297 You should generally not have to worry about calling this, as the system handles this for you.
2298
2299 =cut
2300
2301 sub decrypt {
2302   my ($self,$value) = @_;
2303   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2304   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2305     $self->loadRSA;
2306     if (ref($rsa_decrypt) =~ /::RSA/) {
2307       my $encrypted = unpack ("u*", $value);
2308       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2309       if ($@) {warn "Decryption Failed"};
2310     }
2311   }
2312   return $decrypted;
2313 }
2314
2315 sub loadRSA {
2316     my $self = shift;
2317     #Initialize the Module
2318     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2319
2320     if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') {
2321       $rsa_module = $conf->config('encryptionmodule');
2322     }
2323
2324     if (!$rsa_loaded) {
2325         eval ("require $rsa_module"); # No need to import the namespace
2326         $rsa_loaded++;
2327     }
2328     # Initialize Encryption
2329     if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') {
2330       my $public_key = join("\n",$conf->config('encryptionpublickey'));
2331       $rsa_encrypt = $rsa_module->new_public_key($public_key);
2332     }
2333
2334     # Intitalize Decryption
2335     if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') {
2336       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2337       $rsa_decrypt = $rsa_module->new_private_key($private_key);
2338     }
2339 }
2340
2341 =item h_search ACTION
2342
2343 Given an ACTION, either "insert", or "delete", returns the appropriate history
2344 record corresponding to this record, if any.
2345
2346 =cut
2347
2348 sub h_search {
2349   my( $self, $action ) = @_;
2350
2351   my $table = $self->table;
2352   $table =~ s/^h_//;
2353
2354   my $primary_key = dbdef->table($table)->primary_key;
2355
2356   qsearchs({
2357     'table'   => "h_$table",
2358     'hashref' => { $primary_key     => $self->$primary_key(),
2359                    'history_action' => $action,
2360                  },
2361   });
2362
2363 }
2364
2365 =item h_date ACTION
2366
2367 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2368 appropriate history record corresponding to this record, if any.
2369
2370 =cut
2371
2372 sub h_date {
2373   my($self, $action) = @_;
2374   my $h = $self->h_search($action);
2375   $h ? $h->history_date : '';
2376 }
2377
2378 =back
2379
2380 =head1 SUBROUTINES
2381
2382 =over 4
2383
2384 =item real_fields [ TABLE ]
2385
2386 Returns a list of the real columns in the specified table.  Called only by
2387 fields() and other subroutines elsewhere in FS::Record.
2388
2389 =cut
2390
2391 sub real_fields {
2392   my $table = shift;
2393
2394   my($table_obj) = dbdef->table($table);
2395   confess "Unknown table $table" unless $table_obj;
2396   $table_obj->columns;
2397 }
2398
2399 =item _quote VALUE, TABLE, COLUMN
2400
2401 This is an internal function used to construct SQL statements.  It returns
2402 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2403 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2404
2405 =cut
2406
2407 sub _quote {
2408   my($value, $table, $column) = @_;
2409   my $column_obj = dbdef->table($table)->column($column);
2410   my $column_type = $column_obj->type;
2411   my $nullable = $column_obj->null;
2412
2413   warn "  $table.$column: $value ($column_type".
2414        ( $nullable ? ' NULL' : ' NOT NULL' ).
2415        ")\n" if $DEBUG > 2;
2416
2417   if ( $value eq '' && $nullable ) {
2418     'NULL'
2419   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2420     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2421           "using 0 instead";
2422     0;
2423   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2424             ! $column_type =~ /(char|binary|text)$/i ) {
2425     $value;
2426   } else {
2427     dbh->quote($value);
2428   }
2429 }
2430
2431 =item hfields TABLE
2432
2433 This is deprecated.  Don't use it.
2434
2435 It returns a hash-type list with the fields of this record's table set true.
2436
2437 =cut
2438
2439 sub hfields {
2440   carp "warning: hfields is deprecated";
2441   my($table)=@_;
2442   my(%hash);
2443   foreach (fields($table)) {
2444     $hash{$_}=1;
2445   }
2446   \%hash;
2447 }
2448
2449 sub _dump {
2450   my($self)=@_;
2451   join("\n", map {
2452     "$_: ". $self->getfield($_). "|"
2453   } (fields($self->table)) );
2454 }
2455
2456 sub DESTROY { return; }
2457
2458 #sub DESTROY {
2459 #  my $self = shift;
2460 #  #use Carp qw(cluck);
2461 #  #cluck "DESTROYING $self";
2462 #  warn "DESTROYING $self";
2463 #}
2464
2465 #sub is_tainted {
2466 #             return ! eval { join('',@_), kill 0; 1; };
2467 #         }
2468
2469 =item str2time_sql [ DRIVER_NAME ]
2470
2471 Returns a function to convert to unix time based on database type, such as
2472 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
2473 the str2time_sql_closing method to return a closing string rather than just
2474 using a closing parenthesis as previously suggested.
2475
2476 You can pass an optional driver name such as "Pg", "mysql" or
2477 $dbh->{Driver}->{Name} to return a function for that database instead of
2478 the current database.
2479
2480 =cut
2481
2482 sub str2time_sql {
2483   my $driver = shift || driver_name;
2484
2485   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
2486   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
2487
2488   warn "warning: unknown database type $driver; guessing how to convert ".
2489        "dates to UNIX timestamps";
2490   return 'EXTRACT(EPOCH FROM ';
2491
2492 }
2493
2494 =item str2time_sql_closing [ DRIVER_NAME ]
2495
2496 Returns the closing suffix of a function to convert to unix time based on
2497 database type, such as ")::integer" for Pg or ")" for mysql.
2498
2499 You can pass an optional driver name such as "Pg", "mysql" or
2500 $dbh->{Driver}->{Name} to return a function for that database instead of
2501 the current database.
2502
2503 =cut
2504
2505 sub str2time_sql_closing {
2506   my $driver = shift || driver_name;
2507
2508   return ' )::INTEGER ' if $driver =~ /^Pg/i;
2509   return ' ) ';
2510 }
2511
2512 =back
2513
2514 =head1 BUGS
2515
2516 This module should probably be renamed, since much of the functionality is
2517 of general use.  It is not completely unlike Adapter::DBI (see below).
2518
2519 Exported qsearch and qsearchs should be deprecated in favor of method calls
2520 (against an FS::Record object like the old search and searchs that qsearch
2521 and qsearchs were on top of.)
2522
2523 The whole fields / hfields mess should be removed.
2524
2525 The various WHERE clauses should be subroutined.
2526
2527 table string should be deprecated in favor of DBIx::DBSchema::Table.
2528
2529 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
2530 true maps to the database (and WHERE clauses) would also help.
2531
2532 The ut_ methods should ask the dbdef for a default length.
2533
2534 ut_sqltype (like ut_varchar) should all be defined
2535
2536 A fallback check method should be provided which uses the dbdef.
2537
2538 The ut_money method assumes money has two decimal digits.
2539
2540 The Pg money kludge in the new method only strips `$'.
2541
2542 The ut_phonen method only checks US-style phone numbers.
2543
2544 The _quote function should probably use ut_float instead of a regex.
2545
2546 All the subroutines probably should be methods, here or elsewhere.
2547
2548 Probably should borrow/use some dbdef methods where appropriate (like sub
2549 fields)
2550
2551 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
2552 or allow it to be set.  Working around it is ugly any way around - DBI should
2553 be fixed.  (only affects RDBMS which return uppercase column names)
2554
2555 ut_zip should take an optional country like ut_phone.
2556
2557 =head1 SEE ALSO
2558
2559 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
2560
2561 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
2562
2563 http://poop.sf.net/
2564
2565 =cut
2566
2567 1;
2568