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