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