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