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 lock_table
 770
 771 Locks this table with a database-driver specific lock method.  This is used
 772 as a mutex in order to do a duplicate search.
 773
 774 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
 775
 776 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
 777
 778 Errors are fatal; no useful return value.
 779
 780 Note: To use this method for new tables other than svc_acct and svc_phone,
 781 edit freeside-upgrade and add those tables to the duplicate_lock list.
 782
 783 =cut
 784
 785 sub lock_table {
 786   my $self = shift;
 787   my $table = $self->table;
 788
 789   warn "$me locking $table table\n" if $DEBUG;
 790
 791   if ( driver_name =~ /^Pg/i ) {
 792
 793     dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
 794       or die dbh->errstr;
 795
 796   } elsif ( driver_name =~ /^mysql/i ) {
 797
 798     dbh->do("SELECT * FROM duplicate_lock
 799                WHERE lockname = '$table'
 800                FOR UPDATE"
 801            ) or die dbh->errstr;
 802
 803   } else {
 804
 805     die "unknown database ". driver_name. "; don't know how to lock table";
 806
 807   }
 808
 809   warn "$me acquired $table table lock\n" if $DEBUG;
 810
 811 }
 812
 813 =item insert
 814
 815 Inserts this record to the database.  If there is an error, returns the error,
 816 otherwise returns false.
 817
 818 =cut
 819
 820 sub insert {
 821   my $self = shift;
 822   my $saved = {};
 823
 824   warn "$self -> insert" if $DEBUG;
 825
 826   my $error = $self->check;
 827   return $error if $error;
 828
 829   #single-field unique keys are given a value if false
 830   #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
 831   foreach ( $self->dbdef_table->unique_singles) {
 832     $self->unique($_) unless $self->getfield($_);
 833   }
 834
 835   #and also the primary key, if the database isn't going to
 836   my $primary_key = $self->dbdef_table->primary_key;
 837   my $db_seq = 0;
 838   if ( $primary_key ) {
 839     my $col = $self->dbdef_table->column($primary_key);
 840
 841     $db_seq =
 842       uc($col->type) =~ /^(BIG)?SERIAL\d?/
 843       || ( driver_name eq 'Pg'
 844              && defined($col->default)
 845              && $col->default =~ /^nextval\(/i
 846          )
 847       || ( driver_name eq 'mysql'
 848              && defined($col->local)
 849              && $col->local =~ /AUTO_INCREMENT/i
 850          );
 851     $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
 852   }
 853
 854   my $table = $self->table;
 855
 856   # Encrypt before the database
 857   if (    defined(eval '@FS::'. $table . '::encrypted_fields')
 858        && scalar( eval '@FS::'. $table . '::encrypted_fields')
 859        && $conf->exists('encryption')
 860   ) {
 861     foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 862       $self->{'saved'} = $self->getfield($field);
 863       $self->setfield($field, $self->encrypt($self->getfield($field)));
 864     }
 865   }
 866
 867   #false laziness w/delete
 868   my @real_fields =
 869     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
 870     real_fields($table)
 871   ;
 872   my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
 873   #eslaf
 874
 875   my $statement = "INSERT INTO $table ";
 876   if ( @real_fields ) {
 877     $statement .=
 878       "( ".
 879         join( ', ', @real_fields ).
 880       ") VALUES (".
 881         join( ', ', @values ).
 882        ")"
 883     ;
 884   } else {
 885     $statement .= 'DEFAULT VALUES';
 886   }
 887   warn "[debug]$me $statement\n" if $DEBUG > 1;
 888   my $sth = dbh->prepare($statement) or return dbh->errstr;
 889
 890   local $SIG{HUP} = 'IGNORE';
 891   local $SIG{INT} = 'IGNORE';
 892   local $SIG{QUIT} = 'IGNORE';
 893   local $SIG{TERM} = 'IGNORE';
 894   local $SIG{TSTP} = 'IGNORE';
 895   local $SIG{PIPE} = 'IGNORE';
 896
 897   $sth->execute or return $sth->errstr;
 898
 899   # get inserted id from the database, if applicable & needed
 900   if ( $db_seq && ! $self->getfield($primary_key) ) {
 901     warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
 902
 903     my $insertid = '';
 904
 905     if ( driver_name eq 'Pg' ) {
 906
 907       #my $oid = $sth->{'pg_oid_status'};
 908       #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
 909
 910       my $default = $self->dbdef_table->column($primary_key)->default;
 911       unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
 912         dbh->rollback if $FS::UID::AutoCommit;
 913         return "can't parse $table.$primary_key default value".
 914                " for sequence name: $default";
 915       }
 916       my $sequence = $1;
 917
 918       my $i_sql = "SELECT currval('$sequence')";
 919       my $i_sth = dbh->prepare($i_sql) or do {
 920         dbh->rollback if $FS::UID::AutoCommit;
 921         return dbh->errstr;
 922       };
 923       $i_sth->execute() or do { #$i_sth->execute($oid)
 924         dbh->rollback if $FS::UID::AutoCommit;
 925         return $i_sth->errstr;
 926       };
 927       $insertid = $i_sth->fetchrow_arrayref->[0];
 928
 929     } elsif ( driver_name eq 'mysql' ) {
 930
 931       $insertid = dbh->{'mysql_insertid'};
 932       # work around mysql_insertid being null some of the time, ala RT :/
 933       unless ( $insertid ) {
 934         warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
 935              "using SELECT LAST_INSERT_ID();";
 936         my $i_sql = "SELECT LAST_INSERT_ID()";
 937         my $i_sth = dbh->prepare($i_sql) or do {
 938           dbh->rollback if $FS::UID::AutoCommit;
 939           return dbh->errstr;
 940         };
 941         $i_sth->execute or do {
 942           dbh->rollback if $FS::UID::AutoCommit;
 943           return $i_sth->errstr;
 944         };
 945         $insertid = $i_sth->fetchrow_arrayref->[0];
 946       }
 947
 948     } else {
 949
 950       dbh->rollback if $FS::UID::AutoCommit;
 951       return "don't know how to retreive inserted ids from ". driver_name.
 952              ", try using counterfiles (maybe run dbdef-create?)";
 953
 954     }
 955
 956     $self->setfield($primary_key, $insertid);
 957
 958   }
 959
 960   my @virtual_fields =
 961       grep defined($self->getfield($_)) && $self->getfield($_) ne "",
 962           $self->virtual_fields;
 963   if (@virtual_fields) {
 964     my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
 965
 966     my $vfieldpart = $self->vfieldpart_hashref;
 967
 968     my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
 969                     "VALUES (?, ?, ?)";
 970
 971     my $v_sth = dbh->prepare($v_statement) or do {
 972       dbh->rollback if $FS::UID::AutoCommit;
 973       return dbh->errstr;
 974     };
 975
 976     foreach (keys(%v_values)) {
 977       $v_sth->execute($self->getfield($primary_key),
 978                       $vfieldpart->{$_},
 979                       $v_values{$_})
 980       or do {
 981         dbh->rollback if $FS::UID::AutoCommit;
 982         return $v_sth->errstr;
 983       };
 984     }
 985   }
 986
 987
 988   my $h_sth;
 989   if ( defined dbdef->table('h_'. $table) ) {
 990     my $h_statement = $self->_h_statement('insert');
 991     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
 992     $h_sth = dbh->prepare($h_statement) or do {
 993       dbh->rollback if $FS::UID::AutoCommit;
 994       return dbh->errstr;
 995     };
 996   } else {
 997     $h_sth = '';
 998   }
 999   $h_sth->execute or return $h_sth->errstr if $h_sth;
1000
1001   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1002
1003   # Now that it has been saved, reset the encrypted fields so that $new
1004   # can still be used.
1005   foreach my $field (keys %{$saved}) {
1006     $self->setfield($field, $saved->{$field});
1007   }
1008
1009   '';
1010 }
1011
1012 =item add
1013
1014 Depriciated (use insert instead).
1015
1016 =cut
1017
1018 sub add {
1019   cluck "warning: FS::Record::add deprecated!";
1020   insert @_; #call method in this scope
1021 }
1022
1023 =item delete
1024
1025 Delete this record from the database.  If there is an error, returns the error,
1026 otherwise returns false.
1027
1028 =cut
1029
1030 sub delete {
1031   my $self = shift;
1032
1033   my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1034     map {
1035       $self->getfield($_) eq ''
1036         #? "( $_ IS NULL OR $_ = \"\" )"
1037         ? ( driver_name eq 'Pg'
1038               ? "$_ IS NULL"
1039               : "( $_ IS NULL OR $_ = \"\" )"
1040           )
1041         : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1042     } ( $self->dbdef_table->primary_key )
1043           ? ( $self->dbdef_table->primary_key)
1044           : real_fields($self->table)
1045   );
1046   warn "[debug]$me $statement\n" if $DEBUG > 1;
1047   my $sth = dbh->prepare($statement) or return dbh->errstr;
1048
1049   my $h_sth;
1050   if ( defined dbdef->table('h_'. $self->table) ) {
1051     my $h_statement = $self->_h_statement('delete');
1052     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1053     $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1054   } else {
1055     $h_sth = '';
1056   }
1057
1058   my $primary_key = $self->dbdef_table->primary_key;
1059   my $v_sth;
1060   my @del_vfields;
1061   my $vfp = $self->vfieldpart_hashref;
1062   foreach($self->virtual_fields) {
1063     next if $self->getfield($_) eq '';
1064     unless(@del_vfields) {
1065       my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
1066       $v_sth = dbh->prepare($st) or return dbh->errstr;
1067     }
1068     push @del_vfields, $_;
1069   }
1070
1071   local $SIG{HUP} = 'IGNORE';
1072   local $SIG{INT} = 'IGNORE';
1073   local $SIG{QUIT} = 'IGNORE';
1074   local $SIG{TERM} = 'IGNORE';
1075   local $SIG{TSTP} = 'IGNORE';
1076   local $SIG{PIPE} = 'IGNORE';
1077
1078   my $rc = $sth->execute or return $sth->errstr;
1079   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1080   $h_sth->execute or return $h_sth->errstr if $h_sth;
1081   $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
1082     or return $v_sth->errstr
1083         foreach (@del_vfields);
1084
1085   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1086
1087   #no need to needlessly destoy the data either (causes problems actually)
1088   #undef $self; #no need to keep object!
1089
1090   '';
1091 }
1092
1093 =item del
1094
1095 Depriciated (use delete instead).
1096
1097 =cut
1098
1099 sub del {
1100   cluck "warning: FS::Record::del deprecated!";
1101   &delete(@_); #call method in this scope
1102 }
1103
1104 =item replace OLD_RECORD
1105
1106 Replace the OLD_RECORD with this one in the database.  If there is an error,
1107 returns the error, otherwise returns false.
1108
1109 =cut
1110
1111 sub replace {
1112   my ($new, $old) = (shift, shift);
1113
1114   $old = $new->replace_old unless defined($old);
1115
1116   warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1117
1118   if ( $new->can('replace_check') ) {
1119     my $error = $new->replace_check($old);
1120     return $error if $error;
1121   }
1122
1123   return "Records not in same table!" unless $new->table eq $old->table;
1124
1125   my $primary_key = $old->dbdef_table->primary_key;
1126   return "Can't change primary key $primary_key ".
1127          'from '. $old->getfield($primary_key).
1128          ' to ' . $new->getfield($primary_key)
1129     if $primary_key
1130        && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1131
1132   my $error = $new->check;
1133   return $error if $error;
1134
1135   # Encrypt for replace
1136   my $saved = {};
1137   if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) {
1138     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1139       $saved->{$field} = $new->getfield($field);
1140       $new->setfield($field, $new->encrypt($new->getfield($field)));
1141     }
1142   }
1143
1144   #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1145   my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1146                    ? ($_, $new->getfield($_)) : () } $old->fields;
1147
1148   unless (keys(%diff) || $no_update_diff ) {
1149     carp "[warning]$me $new -> replace $old: records identical"
1150       unless $nowarn_identical;
1151     return '';
1152   }
1153
1154   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1155     map {
1156       "$_ = ". _quote($new->getfield($_),$old->table,$_)
1157     } real_fields($old->table)
1158   ). ' WHERE '.
1159     join(' AND ',
1160       map {
1161
1162         if ( $old->getfield($_) eq '' ) {
1163
1164          #false laziness w/qsearch
1165          if ( driver_name eq 'Pg' ) {
1166             my $type = $old->dbdef_table->column($_)->type;
1167             if ( $type =~ /(int|(big)?serial)/i ) {
1168               qq-( $_ IS NULL )-;
1169             } else {
1170               qq-( $_ IS NULL OR $_ = '' )-;
1171             }
1172           } else {
1173             qq-( $_ IS NULL OR $_ = "" )-;
1174           }
1175
1176         } else {
1177           "$_ = ". _quote($old->getfield($_),$old->table,$_);
1178         }
1179
1180       } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1181     )
1182   ;
1183   warn "[debug]$me $statement\n" if $DEBUG > 1;
1184   my $sth = dbh->prepare($statement) or return dbh->errstr;
1185
1186   my $h_old_sth;
1187   if ( defined dbdef->table('h_'. $old->table) ) {
1188     my $h_old_statement = $old->_h_statement('replace_old');
1189     warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1190     $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1191   } else {
1192     $h_old_sth = '';
1193   }
1194
1195   my $h_new_sth;
1196   if ( defined dbdef->table('h_'. $new->table) ) {
1197     my $h_new_statement = $new->_h_statement('replace_new');
1198     warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1199     $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1200   } else {
1201     $h_new_sth = '';
1202   }
1203
1204   # For virtual fields we have three cases with different SQL
1205   # statements: add, replace, delete
1206   my $v_add_sth;
1207   my $v_rep_sth;
1208   my $v_del_sth;
1209   my (@add_vfields, @rep_vfields, @del_vfields);
1210   my $vfp = $old->vfieldpart_hashref;
1211   foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
1212     if($diff{$_} eq '') {
1213       # Delete
1214       unless(@del_vfields) {
1215         my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
1216                  "AND vfieldpart = ?";
1217         warn "[debug]$me $st\n" if $DEBUG > 2;
1218         $v_del_sth = dbh->prepare($st) or return dbh->errstr;
1219       }
1220       push @del_vfields, $_;
1221     } elsif($old->getfield($_) eq '') {
1222       # Add
1223       unless(@add_vfields) {
1224         my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
1225                  "VALUES (?, ?, ?)";
1226         warn "[debug]$me $st\n" if $DEBUG > 2;
1227         $v_add_sth = dbh->prepare($st) or return dbh->errstr;
1228       }
1229       push @add_vfields, $_;
1230     } else {
1231       # Replace
1232       unless(@rep_vfields) {
1233         my $st = "UPDATE virtual_field SET value = ? ".
1234                  "WHERE recnum = ? AND vfieldpart = ?";
1235         warn "[debug]$me $st\n" if $DEBUG > 2;
1236         $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
1237       }
1238       push @rep_vfields, $_;
1239     }
1240   }
1241
1242   local $SIG{HUP} = 'IGNORE';
1243   local $SIG{INT} = 'IGNORE';
1244   local $SIG{QUIT} = 'IGNORE';
1245   local $SIG{TERM} = 'IGNORE';
1246   local $SIG{TSTP} = 'IGNORE';
1247   local $SIG{PIPE} = 'IGNORE';
1248
1249   my $rc = $sth->execute or return $sth->errstr;
1250   #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1251   $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1252   $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1253
1254   $v_del_sth->execute($old->getfield($primary_key),
1255                       $vfp->{$_})
1256         or return $v_del_sth->errstr
1257       foreach(@del_vfields);
1258
1259   $v_add_sth->execute($new->getfield($_),
1260                       $old->getfield($primary_key),
1261                       $vfp->{$_})
1262         or return $v_add_sth->errstr
1263       foreach(@add_vfields);
1264
1265   $v_rep_sth->execute($new->getfield($_),
1266                       $old->getfield($primary_key),
1267                       $vfp->{$_})
1268         or return $v_rep_sth->errstr
1269       foreach(@rep_vfields);
1270
1271   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1272
1273   # Now that it has been saved, reset the encrypted fields so that $new
1274   # can still be used.
1275   foreach my $field (keys %{$saved}) {
1276     $new->setfield($field, $saved->{$field});
1277   }
1278
1279   '';
1280
1281 }
1282
1283 sub replace_old {
1284   my( $self ) = shift;
1285   warn "[$me] replace called with no arguments; autoloading old record\n"
1286     if $DEBUG;
1287
1288   my $primary_key = $self->dbdef_table->primary_key;
1289   if ( $primary_key ) {
1290     $self->by_key( $self->$primary_key() ) #this is what's returned
1291       or croak "can't find ". $self->table. ".$primary_key ".
1292         $self->$primary_key();
1293   } else {
1294     croak $self->table. " has no primary key; pass old record as argument";
1295   }
1296
1297 }
1298
1299 =item rep
1300
1301 Depriciated (use replace instead).
1302
1303 =cut
1304
1305 sub rep {
1306   cluck "warning: FS::Record::rep deprecated!";
1307   replace @_; #call method in this scope
1308 }
1309
1310 =item check
1311
1312 Checks virtual fields (using check_blocks).  Subclasses should still provide
1313 a check method to validate real fields, foreign keys, etc., and call this
1314 method via $self->SUPER::check.
1315
1316 (FIXME: Should this method try to make sure that it I<is> being called from
1317 a subclass's check method, to keep the current semantics as far as possible?)
1318
1319 =cut
1320
1321 sub check {
1322   #confess "FS::Record::check not implemented; supply one in subclass!";
1323   my $self = shift;
1324
1325   foreach my $field ($self->virtual_fields) {
1326     for ($self->getfield($field)) {
1327       # See notes on check_block in FS::part_virtual_field.
1328       eval $self->pvf($field)->check_block;
1329       if ( $@ ) {
1330         #this is bad, probably want to follow the stack backtrace up and see
1331         #wtf happened
1332         my $err = "Fatal error checking $field for $self";
1333         cluck "$err: $@";
1334         return "$err (see log for backtrace): $@";
1335
1336       }
1337       $self->setfield($field, $_);
1338     }
1339   }
1340   '';
1341 }
1342
1343 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1344
1345 Processes a batch import as a queued JSRPC job
1346
1347 JOB is an FS::queue entry.
1348
1349 OPTIONS_HASHREF can have the following keys:
1350
1351 =over 4
1352
1353 =item table
1354
1355 Table name (required).
1356
1357 =item params
1358
1359 Listref of field names for static fields.  They will be given values from the
1360 PARAMS hashref and passed as a "params" hashref to batch_import.
1361
1362 =item formats
1363
1364 Formats hashref.  Keys are field names, values are listrefs that define the
1365 format.
1366
1367 Each listref value can be a column name or a code reference.  Coderefs are run
1368 with the row object, data and a FS::Conf object as the three parameters.
1369 For example, this coderef does the same thing as using the "columnname" string:
1370
1371   sub {
1372     my( $record, $data, $conf ) = @_;
1373     $record->columnname( $data );
1374   },
1375
1376 Coderefs are run after all "column name" fields are assigned.
1377
1378 =item format_types
1379
1380 Optional format hashref of types.  Keys are field names, values are "csv",
1381 "xls" or "fixedlength".  Overrides automatic determination of file type
1382 from extension.
1383
1384 =item format_headers
1385
1386 Optional format hashref of header lines.  Keys are field names, values are 0
1387 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1388 number of lines.
1389
1390 =item format_sep_chars
1391
1392 Optional format hashref of CSV sep_chars.  Keys are field names, values are the
1393 CSV separation character.
1394
1395 =item format_fixedlenth_formats
1396
1397 Optional format hashref of fixed length format defintiions.  Keys are field
1398 names, values Parse::FixedLength listrefs of field definitions.
1399
1400 =item default_csv
1401
1402 Set true to default to CSV file type if the filename does not contain a
1403 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1404 format_types).
1405
1406 =back
1407
1408 PARAMS is a base64-encoded Storable string containing the POSTed data as
1409 a hash ref.  It normally contains at least one field, "uploaded files",
1410 generated by /elements/file-upload.html and containing the list of uploaded
1411 files.  Currently only supports a single file named "file".
1412
1413 =cut
1414
1415 use Storable qw(thaw);
1416 use Data::Dumper;
1417 use MIME::Base64;
1418 sub process_batch_import {
1419   my($job, $opt) = ( shift, shift );
1420
1421   my $table = $opt->{table};
1422   my @pass_params = @{ $opt->{params} };
1423   my %formats = %{ $opt->{formats} };
1424
1425   my $param = thaw(decode_base64(shift));
1426   warn Dumper($param) if $DEBUG;
1427
1428   my $files = $param->{'uploaded_files'}
1429     or die "No files provided.\n";
1430
1431   my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1432
1433   my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1434   my $file = $dir. $files{'file'};
1435
1436   my $error =
1437     FS::Record::batch_import( {
1438       #class-static
1439       table                      => $table,
1440       formats                    => \%formats,
1441       format_types               => $opt->{format_types},
1442       format_headers             => $opt->{format_headers},
1443       format_sep_chars           => $opt->{format_sep_chars},
1444       format_fixedlength_formats => $opt->{format_fixedlength_formats},
1445       #per-import
1446       job                        => $job,
1447       file                       => $file,
1448       #type                       => $type,
1449       format                     => $param->{format},
1450       params                     => { map { $_ => $param->{$_} } @pass_params },
1451       #?
1452       default_csv                => $opt->{default_csv},
1453     } );
1454
1455   unlink $file;
1456
1457   die "$error\n" if $error;
1458 }
1459
1460 =item batch_import PARAM_HASHREF
1461
1462 Class method for batch imports.  Available params:
1463
1464 =over 4
1465
1466 =item table
1467
1468 =item formats
1469
1470 =item format_types
1471
1472 =item format_headers
1473
1474 =item format_sep_chars
1475
1476 =item format_fixedlength_formats
1477
1478 =item params
1479
1480 =item job
1481
1482 FS::queue object, will be updated with progress
1483
1484 =item file
1485
1486 =item type
1487
1488 csv, xls or fixedlength
1489
1490 =item format
1491
1492 =item empty_ok
1493
1494 =back
1495
1496 =cut
1497
1498 sub batch_import {
1499   my $param = shift;
1500
1501   warn "$me batch_import call with params: \n". Dumper($param)
1502     if $DEBUG;
1503
1504   my $table   = $param->{table};
1505   my $formats = $param->{formats};
1506
1507   my $job     = $param->{job};
1508   my $file    = $param->{file};
1509   my $format  = $param->{'format'};
1510   my $params  = $param->{params} || {};
1511
1512   die "unknown format $format" unless exists $formats->{ $format };
1513
1514   my $type = $param->{'format_types'}
1515              ? $param->{'format_types'}{ $format }
1516              : $param->{type} || 'csv';
1517
1518   unless ( $type ) {
1519     if ( $file =~ /\.(\w+)$/i ) {
1520       $type = lc($1);
1521     } else {
1522       #or error out???
1523       warn "can't parse file type from filename $file; defaulting to CSV";
1524       $type = 'csv';
1525     }
1526     $type = 'csv'
1527       if $param->{'default_csv'} && $type ne 'xls';
1528   }
1529
1530   my $header = $param->{'format_headers'}
1531                  ? $param->{'format_headers'}{ $param->{'format'} }
1532                  : 0;
1533
1534   my $sep_char = $param->{'format_sep_chars'}
1535                    ? $param->{'format_sep_chars'}{ $param->{'format'} }
1536                    : ',';
1537
1538   my $fixedlength_format =
1539     $param->{'format_fixedlength_formats'}
1540       ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1541       : '';
1542
1543   my @fields = @{ $formats->{ $format } };
1544
1545   my $row = 0;
1546   my $count;
1547   my $parser;
1548   my @buffer = ();
1549   if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1550
1551     if ( $type eq 'csv' ) {
1552
1553       my %attr = ();
1554       $attr{sep_char} = $sep_char if $sep_char;
1555       $parser = new Text::CSV_XS \%attr;
1556
1557     } elsif ( $type eq 'fixedlength' ) {
1558
1559       eval "use Parse::FixedLength;";
1560       die $@ if $@;
1561       $parser = new Parse::FixedLength $fixedlength_format;
1562
1563     } else {
1564       die "Unknown file type $type\n";
1565     }
1566
1567     @buffer = split(/\r?\n/, slurp($file) );
1568     splice(@buffer, 0, ($header || 0) );
1569     $count = scalar(@buffer);
1570
1571   } elsif ( $type eq 'xls' ) {
1572
1573     eval "use Spreadsheet::ParseExcel;";
1574     die $@ if $@;
1575
1576     eval "use DateTime::Format::Excel;";
1577     #for now, just let the error be thrown if it is used, since only CDR
1578     # formats bill_west and troop use it, not other excel-parsing things
1579     #die $@ if $@;
1580
1581     my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
1582
1583     $parser = $excel->{Worksheet}[0]; #first sheet
1584
1585     $count = $parser->{MaxRow} || $parser->{MinRow};
1586     $count++;
1587
1588     $row = $header || 0;
1589
1590   } else {
1591     die "Unknown file type $type\n";
1592   }
1593
1594   #my $columns;
1595
1596   local $SIG{HUP} = 'IGNORE';
1597   local $SIG{INT} = 'IGNORE';
1598   local $SIG{QUIT} = 'IGNORE';
1599   local $SIG{TERM} = 'IGNORE';
1600   local $SIG{TSTP} = 'IGNORE';
1601   local $SIG{PIPE} = 'IGNORE';
1602
1603   my $oldAutoCommit = $FS::UID::AutoCommit;
1604   local $FS::UID::AutoCommit = 0;
1605   my $dbh = dbh;
1606
1607   my $line;
1608   my $imported = 0;
1609   my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
1610   while (1) {
1611
1612     my @columns = ();
1613     if ( $type eq 'csv' ) {
1614
1615       last unless scalar(@buffer);
1616       $line = shift(@buffer);
1617
1618       $parser->parse($line) or do {
1619         $dbh->rollback if $oldAutoCommit;
1620         return "can't parse: ". $parser->error_input();
1621       };
1622       @columns = $parser->fields();
1623
1624     } elsif ( $type eq 'fixedlength' ) {
1625
1626       @columns = $parser->parse($line);
1627
1628     } elsif ( $type eq 'xls' ) {
1629
1630       last if $row > ($parser->{MaxRow} || $parser->{MinRow})
1631            || ! $parser->{Cells}[$row];
1632
1633       my @row = @{ $parser->{Cells}[$row] };
1634       @columns = map $_->{Val}, @row;
1635
1636       #my $z = 'A';
1637       #warn $z++. ": $_\n" for @columns;
1638
1639     } else {
1640       die "Unknown file type $type\n";
1641     }
1642
1643     my @later = ();
1644     my %hash = %$params;
1645
1646     foreach my $field ( @fields ) {
1647
1648       my $value = shift @columns;
1649
1650       if ( ref($field) eq 'CODE' ) {
1651         #&{$field}(\%hash, $value);
1652         push @later, $field, $value;
1653       } else {
1654         #??? $hash{$field} = $value if length($value);
1655         $hash{$field} = $value if defined($value) && length($value);
1656       }
1657
1658     }
1659
1660     my $class = "FS::$table";
1661
1662     my $record = $class->new( \%hash );
1663
1664     while ( scalar(@later) ) {
1665       my $sub = shift @later;
1666       my $data = shift @later;
1667       &{$sub}($record, $data, $conf);  # $record->&{$sub}($data, $conf);
1668     }
1669
1670     my $error = $record->insert;
1671
1672     if ( $error ) {
1673       $dbh->rollback if $oldAutoCommit;
1674       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
1675     }
1676
1677     $row++;
1678     $imported++;
1679
1680     if ( $job && time - $min_sec > $last ) { #progress bar
1681       $job->update_statustext( int(100 * $imported / $count) );
1682       $last = time;
1683     }
1684
1685   }
1686
1687   $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
1688
1689   return "Empty file!" unless $imported || $param->{empty_ok};
1690
1691   ''; #no error
1692
1693 }
1694
1695 sub _h_statement {
1696   my( $self, $action, $time ) = @_;
1697
1698   $time ||= time;
1699
1700   my @fields =
1701     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1702     real_fields($self->table);
1703   ;
1704
1705   # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1706   # You can see if it changed by the paymask...
1707   if ($conf && $conf->exists('encryption') ) {
1708     @fields = grep  $_ ne 'payinfo' && $_ ne 'cvv2', @fields;
1709   }
1710   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1711
1712   "INSERT INTO h_". $self->table. " ( ".
1713       join(', ', qw(history_date history_user history_action), @fields ).
1714     ") VALUES (".
1715       join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1716     ")"
1717   ;
1718 }
1719
1720 =item unique COLUMN
1721
1722 B<Warning>: External use is B<deprecated>.
1723
1724 Replaces COLUMN in record with a unique number, using counters in the
1725 filesystem.  Used by the B<insert> method on single-field unique columns
1726 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1727 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1728
1729 Returns the new value.
1730
1731 =cut
1732
1733 sub unique {
1734   my($self,$field) = @_;
1735   my($table)=$self->table;
1736
1737   croak "Unique called on field $field, but it is ",
1738         $self->getfield($field),
1739         ", not null!"
1740     if $self->getfield($field);
1741
1742   #warn "table $table is tainted" if is_tainted($table);
1743   #warn "field $field is tainted" if is_tainted($field);
1744
1745   my($counter) = new File::CounterFile "$table.$field",0;
1746 # hack for web demo
1747 #  getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1748 #  my($user)=$1;
1749 #  my($counter) = new File::CounterFile "$user/$table.$field",0;
1750 # endhack
1751
1752   my $index = $counter->inc;
1753   $index = $counter->inc while qsearchs($table, { $field=>$index } );
1754
1755   $index =~ /^(\d*)$/;
1756   $index=$1;
1757
1758   $self->setfield($field,$index);
1759
1760 }
1761
1762 =item ut_float COLUMN
1763
1764 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
1765 null.  If there is an error, returns the error, otherwise returns false.
1766
1767 =cut
1768
1769 sub ut_float {
1770   my($self,$field)=@_ ;
1771   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
1772    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
1773    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
1774    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
1775     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1776   $self->setfield($field,$1);
1777   '';
1778 }
1779 =item ut_floatn COLUMN
1780
1781 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1782 null.  If there is an error, returns the error, otherwise returns false.
1783
1784 =cut
1785
1786 #false laziness w/ut_ipn
1787 sub ut_floatn {
1788   my( $self, $field ) = @_;
1789   if ( $self->getfield($field) =~ /^()$/ ) {
1790     $self->setfield($field,'');
1791     '';
1792   } else {
1793     $self->ut_float($field);
1794   }
1795 }
1796
1797 =item ut_sfloat COLUMN
1798
1799 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1800 May not be null.  If there is an error, returns the error, otherwise returns
1801 false.
1802
1803 =cut
1804
1805 sub ut_sfloat {
1806   my($self,$field)=@_ ;
1807   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
1808    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
1809    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
1810    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
1811     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1812   $self->setfield($field,$1);
1813   '';
1814 }
1815 =item ut_sfloatn COLUMN
1816
1817 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1818 null.  If there is an error, returns the error, otherwise returns false.
1819
1820 =cut
1821
1822 sub ut_sfloatn {
1823   my( $self, $field ) = @_;
1824   if ( $self->getfield($field) =~ /^()$/ ) {
1825     $self->setfield($field,'');
1826     '';
1827   } else {
1828     $self->ut_sfloat($field);
1829   }
1830 }
1831
1832 =item ut_snumber COLUMN
1833
1834 Check/untaint signed numeric data (whole numbers).  If there is an error,
1835 returns the error, otherwise returns false.
1836
1837 =cut
1838
1839 sub ut_snumber {
1840   my($self, $field) = @_;
1841   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
1842     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1843   $self->setfield($field, "$1$2");
1844   '';
1845 }
1846
1847 =item ut_snumbern COLUMN
1848
1849 Check/untaint signed numeric data (whole numbers).  If there is an error,
1850 returns the error, otherwise returns false.
1851
1852 =cut
1853
1854 sub ut_snumbern {
1855   my($self, $field) = @_;
1856   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
1857     or return "Illegal (numeric) $field: ". $self->getfield($field);
1858   if ($1) {
1859     return "Illegal (numeric) $field: ". $self->getfield($field)
1860       unless $2;
1861   }
1862   $self->setfield($field, "$1$2");
1863   '';
1864 }
1865
1866 =item ut_number COLUMN
1867
1868 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
1869 is an error, returns the error, otherwise returns false.
1870
1871 =cut
1872
1873 sub ut_number {
1874   my($self,$field)=@_;
1875   $self->getfield($field) =~ /^\s*(\d+)\s*$/
1876     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1877   $self->setfield($field,$1);
1878   '';
1879 }
1880
1881 =item ut_numbern COLUMN
1882
1883 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
1884 an error, returns the error, otherwise returns false.
1885
1886 =cut
1887
1888 sub ut_numbern {
1889   my($self,$field)=@_;
1890   $self->getfield($field) =~ /^\s*(\d*)\s*$/
1891     or return "Illegal (numeric) $field: ". $self->getfield($field);
1892   $self->setfield($field,$1);
1893   '';
1894 }
1895
1896 =item ut_money COLUMN
1897
1898 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
1899 is an error, returns the error, otherwise returns false.
1900
1901 =cut
1902
1903 sub ut_money {
1904   my($self,$field)=@_;
1905   $self->setfield($field, 0) if $self->getfield($field) eq '';
1906   $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/
1907     or return "Illegal (money) $field: ". $self->getfield($field);
1908   #$self->setfield($field, "$1$2$3" || 0);
1909   $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
1910   '';
1911 }
1912
1913 =item ut_text COLUMN
1914
1915 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
1916 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ]
1917 May not be null.  If there is an error, returns the error, otherwise returns
1918 false.
1919
1920 =cut
1921
1922 sub ut_text {
1923   my($self,$field)=@_;
1924   #warn "msgcat ". \&msgcat. "\n";
1925   #warn "notexist ". \&notexist. "\n";
1926   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
1927   $self->getfield($field)
1928     =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/
1929       or return gettext('illegal_or_empty_text'). " $field: ".
1930                  $self->getfield($field);
1931   $self->setfield($field,$1);
1932   '';
1933 }
1934
1935 =item ut_textn COLUMN
1936
1937 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
1938 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
1939 May be null.  If there is an error, returns the error, otherwise returns false.
1940
1941 =cut
1942
1943 sub ut_textn {
1944   my($self,$field)=@_;
1945   $self->getfield($field)
1946     =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/
1947       or return gettext('illegal_text'). " $field: ". $self->getfield($field);
1948   $self->setfield($field,$1);
1949   '';
1950 }
1951
1952 =item ut_alpha COLUMN
1953
1954 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
1955 an error, returns the error, otherwise returns false.
1956
1957 =cut
1958
1959 sub ut_alpha {
1960   my($self,$field)=@_;
1961   $self->getfield($field) =~ /^(\w+)$/
1962     or return "Illegal or empty (alphanumeric) $field: ".
1963               $self->getfield($field);
1964   $self->setfield($field,$1);
1965   '';
1966 }
1967
1968 =item ut_alpha COLUMN
1969
1970 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
1971 error, returns the error, otherwise returns false.
1972
1973 =cut
1974
1975 sub ut_alphan {
1976   my($self,$field)=@_;
1977   $self->getfield($field) =~ /^(\w*)$/
1978     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
1979   $self->setfield($field,$1);
1980   '';
1981 }
1982
1983 =item ut_alpha_lower COLUMN
1984
1985 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
1986 there is an error, returns the error, otherwise returns false.
1987
1988 =cut
1989
1990 sub ut_alpha_lower {
1991   my($self,$field)=@_;
1992   $self->getfield($field) =~ /[[:upper:]]/
1993     and return "Uppercase characters are not permitted in $field";
1994   $self->ut_alpha($field);
1995 }
1996
1997 =item ut_phonen COLUMN [ COUNTRY ]
1998
1999 Check/untaint phone numbers.  May be null.  If there is an error, returns
2000 the error, otherwise returns false.
2001
2002 Takes an optional two-letter ISO country code; without it or with unsupported
2003 countries, ut_phonen simply calls ut_alphan.
2004
2005 =cut
2006
2007 sub ut_phonen {
2008   my( $self, $field, $country ) = @_;
2009   return $self->ut_alphan($field) unless defined $country;
2010   my $phonen = $self->getfield($field);
2011   if ( $phonen eq '' ) {
2012     $self->setfield($field,'');
2013   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2014     $phonen =~ s/\D//g;
2015     $phonen = $conf->config('cust_main-default_areacode').$phonen
2016       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2017     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2018       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2019     $phonen = "$1-$2-$3";
2020     $phonen .= " x$4" if $4;
2021     $self->setfield($field,$phonen);
2022   } else {
2023     warn "warning: don't know how to check phone numbers for country $country";
2024     return $self->ut_textn($field);
2025   }
2026   '';
2027 }
2028
2029 =item ut_hex COLUMN
2030
2031 Check/untaint hexadecimal values.
2032
2033 =cut
2034
2035 sub ut_hex {
2036   my($self, $field) = @_;
2037   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2038     or return "Illegal (hex) $field: ". $self->getfield($field);
2039   $self->setfield($field, uc($1));
2040   '';
2041 }
2042
2043 =item ut_hexn COLUMN
2044
2045 Check/untaint hexadecimal values.  May be null.
2046
2047 =cut
2048
2049 sub ut_hexn {
2050   my($self, $field) = @_;
2051   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2052     or return "Illegal (hex) $field: ". $self->getfield($field);
2053   $self->setfield($field, uc($1));
2054   '';
2055 }
2056 =item ut_ip COLUMN
2057
2058 Check/untaint ip addresses.  IPv4 only for now.
2059
2060 =cut
2061
2062 sub ut_ip {
2063   my( $self, $field ) = @_;
2064   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2065     or return "Illegal (IP address) $field: ". $self->getfield($field);
2066   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2067   $self->setfield($field, "$1.$2.$3.$4");
2068   '';
2069 }
2070
2071 =item ut_ipn COLUMN
2072
2073 Check/untaint ip addresses.  IPv4 only for now.  May be null.
2074
2075 =cut
2076
2077 sub ut_ipn {
2078   my( $self, $field ) = @_;
2079   if ( $self->getfield($field) =~ /^()$/ ) {
2080     $self->setfield($field,'');
2081     '';
2082   } else {
2083     $self->ut_ip($field);
2084   }
2085 }
2086
2087 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2088
2089 Check/untaint coordinates.
2090 Accepts the following forms:
2091 DDD.DDDDD
2092 -DDD.DDDDD
2093 DDD MM.MMM
2094 -DDD MM.MMM
2095 DDD MM SS
2096 -DDD MM SS
2097 DDD MM MMM
2098 -DDD MM MMM
2099
2100 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2101 The latter form (that is, the MMM are thousands of minutes) is
2102 assumed if the "MMM" is exactly three digits or two digits > 59.
2103
2104 To be safe, just use the DDD.DDDDD form.
2105
2106 If LOWER or UPPER are specified, then the coordinate is checked
2107 for lower and upper bounds, respectively.
2108
2109 =cut
2110
2111 sub ut_coord {
2112
2113   my ($self, $field) = (shift, shift);
2114
2115   my $lower = shift if scalar(@_);
2116   my $upper = shift if scalar(@_);
2117   my $coord = $self->getfield($field);
2118   my $neg = $coord =~ s/^(-)//;
2119
2120   my ($d, $m, $s) = (0, 0, 0);
2121
2122   if (
2123     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2124     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2125     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2126   ) {
2127     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2128     $m = $m / 60;
2129     if ($m > 59) {
2130       return "Invalid (coordinate with minutes > 59) $field: "
2131              . $self->getfield($field);
2132     }
2133
2134     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2135
2136     if (defined($lower) and ($coord < $lower)) {
2137       return "Invalid (coordinate < $lower) $field: "
2138              . $self->getfield($field);;
2139     }
2140
2141     if (defined($upper) and ($coord > $upper)) {
2142       return "Invalid (coordinate > $upper) $field: "
2143              . $self->getfield($field);;
2144     }
2145
2146     $self->setfield($field, $coord);
2147     return '';
2148   }
2149
2150   return "Invalid (coordinate) $field: " . $self->getfield($field);
2151
2152 }
2153
2154 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2155
2156 Same as ut_coord, except optionally null.
2157
2158 =cut
2159
2160 sub ut_coordn {
2161
2162   my ($self, $field) = (shift, shift);
2163
2164   if ($self->getfield($field) =~ /^$/) {
2165     return '';
2166   } else {
2167     return $self->ut_coord($field, @_);
2168   }
2169
2170 }
2171
2172
2173 =item ut_domain COLUMN
2174
2175 Check/untaint host and domain names.
2176
2177 =cut
2178
2179 sub ut_domain {
2180   my( $self, $field ) = @_;
2181   #$self->getfield($field) =~/^(\w+\.)*\w+$/
2182   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2183     or return "Illegal (domain) $field: ". $self->getfield($field);
2184   $self->setfield($field,$1);
2185   '';
2186 }
2187
2188 =item ut_name COLUMN
2189
2190 Check/untaint proper names; allows alphanumerics, spaces and the following
2191 punctuation: , . - '
2192
2193 May not be null.
2194
2195 =cut
2196
2197 sub ut_name {
2198   my( $self, $field ) = @_;
2199   $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
2200     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2201   $self->setfield($field,$1);
2202   '';
2203 }
2204
2205 =item ut_zip COLUMN
2206
2207 Check/untaint zip codes.
2208
2209 =cut
2210
2211 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2212
2213 sub ut_zip {
2214   my( $self, $field, $country ) = @_;
2215
2216   if ( $country eq 'US' ) {
2217
2218     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2219       or return gettext('illegal_zip'). " $field for country $country: ".
2220                 $self->getfield($field);
2221     $self->setfield($field, $1);
2222
2223   } elsif ( $country eq 'CA' ) {
2224
2225     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2226       or return gettext('illegal_zip'). " $field for country $country: ".
2227                 $self->getfield($field);
2228     $self->setfield($field, "$1 $2");
2229
2230   } else {
2231
2232     if ( $self->getfield($field) =~ /^\s*$/
2233          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2234        )
2235     {
2236       $self->setfield($field,'');
2237     } else {
2238       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
2239         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2240       $self->setfield($field,$1);
2241     }
2242
2243   }
2244
2245   '';
2246 }
2247
2248 =item ut_country COLUMN
2249
2250 Check/untaint country codes.  Country names are changed to codes, if possible -
2251 see L<Locale::Country>.
2252
2253 =cut
2254
2255 sub ut_country {
2256   my( $self, $field ) = @_;
2257   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2258     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2259          && country2code($1) ) {
2260       $self->setfield($field,uc(country2code($1)));
2261     }
2262   }
2263   $self->getfield($field) =~ /^(\w\w)$/
2264     or return "Illegal (country) $field: ". $self->getfield($field);
2265   $self->setfield($field,uc($1));
2266   '';
2267 }
2268
2269 =item ut_anything COLUMN
2270
2271 Untaints arbitrary data.  Be careful.
2272
2273 =cut
2274
2275 sub ut_anything {
2276   my( $self, $field ) = @_;
2277   $self->getfield($field) =~ /^(.*)$/s
2278     or return "Illegal $field: ". $self->getfield($field);
2279   $self->setfield($field,$1);
2280   '';
2281 }
2282
2283 =item ut_enum COLUMN CHOICES_ARRAYREF
2284
2285 Check/untaint a column, supplying all possible choices, like the "enum" type.
2286
2287 =cut
2288
2289 sub ut_enum {
2290   my( $self, $field, $choices ) = @_;
2291   foreach my $choice ( @$choices ) {
2292     if ( $self->getfield($field) eq $choice ) {
2293       $self->setfield($choice);
2294       return '';
2295     }
2296   }
2297   return "Illegal (enum) field $field: ". $self->getfield($field);
2298 }
2299
2300 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2301
2302 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
2303 on the column first.
2304
2305 =cut
2306
2307 sub ut_foreign_key {
2308   my( $self, $field, $table, $foreign ) = @_;
2309   return '' if $no_check_foreign;
2310   qsearchs($table, { $foreign => $self->getfield($field) })
2311     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
2312               " in $table.$foreign";
2313   '';
2314 }
2315
2316 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2317
2318 Like ut_foreign_key, except the null value is also allowed.
2319
2320 =cut
2321
2322 sub ut_foreign_keyn {
2323   my( $self, $field, $table, $foreign ) = @_;
2324   $self->getfield($field)
2325     ? $self->ut_foreign_key($field, $table, $foreign)
2326     : '';
2327 }
2328
2329 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
2330
2331 Checks this column as an agentnum, taking into account the current users's
2332 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
2333 right or rights allowing no agentnum.
2334
2335 =cut
2336
2337 sub ut_agentnum_acl {
2338   my( $self, $field ) = (shift, shift);
2339   my $null_acl = scalar(@_) ? shift : [];
2340   $null_acl = [ $null_acl ] unless ref($null_acl);
2341
2342   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
2343   return "Illegal agentnum: $error" if $error;
2344
2345   my $curuser = $FS::CurrentUser::CurrentUser;
2346
2347   if ( $self->$field() ) {
2348
2349     return "Access denied"
2350       unless $curuser->agentnum($self->$field());
2351
2352   } else {
2353
2354     return "Access denied"
2355       unless grep $curuser->access_right($_), @$null_acl;
2356
2357   }
2358
2359   '';
2360
2361 }
2362
2363 =item virtual_fields [ TABLE ]
2364
2365 Returns a list of virtual fields defined for the table.  This should not
2366 be exported, and should only be called as an instance or class method.
2367
2368 =cut
2369
2370 sub virtual_fields {
2371   my $self = shift;
2372   my $table;
2373   $table = $self->table or confess "virtual_fields called on non-table";
2374
2375   confess "Unknown table $table" unless dbdef->table($table);
2376
2377   return () unless dbdef->table('part_virtual_field');
2378
2379   unless ( $virtual_fields_cache{$table} ) {
2380     my $query = 'SELECT name from part_virtual_field ' .
2381                 "WHERE dbtable = '$table'";
2382     my $dbh = dbh;
2383     my $result = $dbh->selectcol_arrayref($query);
2384     confess "Error executing virtual fields query: $query: ". $dbh->errstr
2385       if $dbh->err;
2386     $virtual_fields_cache{$table} = $result;
2387   }
2388
2389   @{$virtual_fields_cache{$table}};
2390
2391 }
2392
2393
2394 =item fields [ TABLE ]
2395
2396 This is a wrapper for real_fields and virtual_fields.  Code that called
2397 fields before should probably continue to call fields.
2398
2399 =cut
2400
2401 sub fields {
2402   my $something = shift;
2403   my $table;
2404   if($something->isa('FS::Record')) {
2405     $table = $something->table;
2406   } else {
2407     $table = $something;
2408     $something = "FS::$table";
2409   }
2410   return (real_fields($table), $something->virtual_fields());
2411 }
2412
2413 =item pvf FIELD_NAME
2414
2415 Returns the FS::part_virtual_field object corresponding to a field in the
2416 record (specified by FIELD_NAME).
2417
2418 =cut
2419
2420 sub pvf {
2421   my ($self, $name) = (shift, shift);
2422
2423   if(grep /^$name$/, $self->virtual_fields) {
2424     return qsearchs('part_virtual_field', { dbtable => $self->table,
2425                                             name    => $name } );
2426   }
2427   ''
2428 }
2429
2430 =item vfieldpart_hashref TABLE
2431
2432 Returns a hashref of virtual field names and vfieldparts applicable to the given
2433 TABLE.
2434
2435 =cut
2436
2437 sub vfieldpart_hashref {
2438   my $self = shift;
2439   my $table = $self->table;
2440
2441   return {} unless dbdef->table('part_virtual_field');
2442
2443   my $dbh = dbh;
2444   my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
2445                   "dbtable = '$table'";
2446   my $sth = $dbh->prepare($statement);
2447   $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
2448   return { map { $_->{name}, $_->{vfieldpart} }
2449     @{$sth->fetchall_arrayref({})} };
2450
2451 }
2452
2453 =item encrypt($value)
2454
2455 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2456
2457 Returns the encrypted string.
2458
2459 You should generally not have to worry about calling this, as the system handles this for you.
2460
2461 =cut
2462
2463 sub encrypt {
2464   my ($self, $value) = @_;
2465   my $encrypted;
2466
2467   if ($conf->exists('encryption')) {
2468     if ($self->is_encrypted($value)) {
2469       # Return the original value if it isn't plaintext.
2470       $encrypted = $value;
2471     } else {
2472       $self->loadRSA;
2473       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2474         # RSA doesn't like the empty string so let's pack it up
2475         # The database doesn't like the RSA data so uuencode it
2476         my $length = length($value)+1;
2477         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2478       } else {
2479         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2480       }
2481     }
2482   }
2483   return $encrypted;
2484 }
2485
2486 =item is_encrypted($value)
2487
2488 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2489
2490 =cut
2491
2492
2493 sub is_encrypted {
2494   my ($self, $value) = @_;
2495   # Possible Bug - Some work may be required here....
2496
2497   if ($value =~ /^M/ && length($value) > 80) {
2498     return 1;
2499   } else {
2500     return 0;
2501   }
2502 }
2503
2504 =item decrypt($value)
2505
2506 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2507
2508 You should generally not have to worry about calling this, as the system handles this for you.
2509
2510 =cut
2511
2512 sub decrypt {
2513   my ($self,$value) = @_;
2514   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2515   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2516     $self->loadRSA;
2517     if (ref($rsa_decrypt) =~ /::RSA/) {
2518       my $encrypted = unpack ("u*", $value);
2519       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2520       if ($@) {warn "Decryption Failed"};
2521     }
2522   }
2523   return $decrypted;
2524 }
2525
2526 sub loadRSA {
2527     my $self = shift;
2528     #Initialize the Module
2529     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2530
2531     if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') {
2532       $rsa_module = $conf->config('encryptionmodule');
2533     }
2534
2535     if (!$rsa_loaded) {
2536         eval ("require $rsa_module"); # No need to import the namespace
2537         $rsa_loaded++;
2538     }
2539     # Initialize Encryption
2540     if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') {
2541       my $public_key = join("\n",$conf->config('encryptionpublickey'));
2542       $rsa_encrypt = $rsa_module->new_public_key($public_key);
2543     }
2544
2545     # Intitalize Decryption
2546     if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') {
2547       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2548       $rsa_decrypt = $rsa_module->new_private_key($private_key);
2549     }
2550 }
2551
2552 =item h_search ACTION
2553
2554 Given an ACTION, either "insert", or "delete", returns the appropriate history
2555 record corresponding to this record, if any.
2556
2557 =cut
2558
2559 sub h_search {
2560   my( $self, $action ) = @_;
2561
2562   my $table = $self->table;
2563   $table =~ s/^h_//;
2564
2565   my $primary_key = dbdef->table($table)->primary_key;
2566
2567   qsearchs({
2568     'table'   => "h_$table",
2569     'hashref' => { $primary_key     => $self->$primary_key(),
2570                    'history_action' => $action,
2571                  },
2572   });
2573
2574 }
2575
2576 =item h_date ACTION
2577
2578 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2579 appropriate history record corresponding to this record, if any.
2580
2581 =cut
2582
2583 sub h_date {
2584   my($self, $action) = @_;
2585   my $h = $self->h_search($action);
2586   $h ? $h->history_date : '';
2587 }
2588
2589 =back
2590
2591 =head1 SUBROUTINES
2592
2593 =over 4
2594
2595 =item real_fields [ TABLE ]
2596
2597 Returns a list of the real columns in the specified table.  Called only by
2598 fields() and other subroutines elsewhere in FS::Record.
2599
2600 =cut
2601
2602 sub real_fields {
2603   my $table = shift;
2604
2605   my($table_obj) = dbdef->table($table);
2606   confess "Unknown table $table" unless $table_obj;
2607   $table_obj->columns;
2608 }
2609
2610 =item _quote VALUE, TABLE, COLUMN
2611
2612 This is an internal function used to construct SQL statements.  It returns
2613 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2614 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2615
2616 =cut
2617
2618 sub _quote {
2619   my($value, $table, $column) = @_;
2620   my $column_obj = dbdef->table($table)->column($column);
2621   my $column_type = $column_obj->type;
2622   my $nullable = $column_obj->null;
2623
2624   warn "  $table.$column: $value ($column_type".
2625        ( $nullable ? ' NULL' : ' NOT NULL' ).
2626        ")\n" if $DEBUG > 2;
2627
2628   if ( $value eq '' && $nullable ) {
2629     'NULL'
2630   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2631     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2632           "using 0 instead";
2633     0;
2634   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2635             ! $column_type =~ /(char|binary|text)$/i ) {
2636     $value;
2637   } else {
2638     dbh->quote($value);
2639   }
2640 }
2641
2642 =item hfields TABLE
2643
2644 This is deprecated.  Don't use it.
2645
2646 It returns a hash-type list with the fields of this record's table set true.
2647
2648 =cut
2649
2650 sub hfields {
2651   carp "warning: hfields is deprecated";
2652   my($table)=@_;
2653   my(%hash);
2654   foreach (fields($table)) {
2655     $hash{$_}=1;
2656   }
2657   \%hash;
2658 }
2659
2660 sub _dump {
2661   my($self)=@_;
2662   join("\n", map {
2663     "$_: ". $self->getfield($_). "|"
2664   } (fields($self->table)) );
2665 }
2666
2667 sub DESTROY { return; }
2668
2669 #sub DESTROY {
2670 #  my $self = shift;
2671 #  #use Carp qw(cluck);
2672 #  #cluck "DESTROYING $self";
2673 #  warn "DESTROYING $self";
2674 #}
2675
2676 #sub is_tainted {
2677 #             return ! eval { join('',@_), kill 0; 1; };
2678 #         }
2679
2680 =item str2time_sql [ DRIVER_NAME ]
2681
2682 Returns a function to convert to unix time based on database type, such as
2683 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
2684 the str2time_sql_closing method to return a closing string rather than just
2685 using a closing parenthesis as previously suggested.
2686
2687 You can pass an optional driver name such as "Pg", "mysql" or
2688 $dbh->{Driver}->{Name} to return a function for that database instead of
2689 the current database.
2690
2691 =cut
2692
2693 sub str2time_sql {
2694   my $driver = shift || driver_name;
2695
2696   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
2697   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
2698
2699   warn "warning: unknown database type $driver; guessing how to convert ".
2700        "dates to UNIX timestamps";
2701   return 'EXTRACT(EPOCH FROM ';
2702
2703 }
2704
2705 =item str2time_sql_closing [ DRIVER_NAME ]
2706
2707 Returns the closing suffix of a function to convert to unix time based on
2708 database type, such as ")::integer" for Pg or ")" for mysql.
2709
2710 You can pass an optional driver name such as "Pg", "mysql" or
2711 $dbh->{Driver}->{Name} to return a function for that database instead of
2712 the current database.
2713
2714 =cut
2715
2716 sub str2time_sql_closing {
2717   my $driver = shift || driver_name;
2718
2719   return ' )::INTEGER ' if $driver =~ /^Pg/i;
2720   return ' ) ';
2721 }
2722
2723 =back
2724
2725 =head1 BUGS
2726
2727 This module should probably be renamed, since much of the functionality is
2728 of general use.  It is not completely unlike Adapter::DBI (see below).
2729
2730 Exported qsearch and qsearchs should be deprecated in favor of method calls
2731 (against an FS::Record object like the old search and searchs that qsearch
2732 and qsearchs were on top of.)
2733
2734 The whole fields / hfields mess should be removed.
2735
2736 The various WHERE clauses should be subroutined.
2737
2738 table string should be deprecated in favor of DBIx::DBSchema::Table.
2739
2740 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
2741 true maps to the database (and WHERE clauses) would also help.
2742
2743 The ut_ methods should ask the dbdef for a default length.
2744
2745 ut_sqltype (like ut_varchar) should all be defined
2746
2747 A fallback check method should be provided which uses the dbdef.
2748
2749 The ut_money method assumes money has two decimal digits.
2750
2751 The Pg money kludge in the new method only strips `$'.
2752
2753 The ut_phonen method only checks US-style phone numbers.
2754
2755 The _quote function should probably use ut_float instead of a regex.
2756
2757 All the subroutines probably should be methods, here or elsewhere.
2758
2759 Probably should borrow/use some dbdef methods where appropriate (like sub
2760 fields)
2761
2762 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
2763 or allow it to be set.  Working around it is ugly any way around - DBI should
2764 be fixed.  (only affects RDBMS which return uppercase column names)
2765
2766 ut_zip should take an optional country like ut_phone.
2767
2768 =head1 SEE ALSO
2769
2770 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
2771
2772 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
2773
2774 http://poop.sf.net/
2775
2776 =cut
2777
2778 1;
2779