FS/FS/Record.pm

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