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