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