FS/FS/Record.pm

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