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 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       &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
1798         if $asn_format->{row_callback};
1799       foreach my $key ( keys %{ $asn_format->{map} } ) {
1800         $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
1801       }
1802
1803     } else {
1804       die "Unknown file type $type\n";
1805     }
1806
1807     my @later = ();
1808
1809     foreach my $field ( @fields ) {
1810
1811       my $value = shift @columns;
1812
1813       if ( ref($field) eq 'CODE' ) {
1814         #&{$field}(\%hash, $value);
1815         push @later, $field, $value;
1816       } else {
1817         #??? $hash{$field} = $value if length($value);
1818         $hash{$field} = $value if defined($value) && length($value);
1819       }
1820
1821     }
1822
1823     #my $table   = $param->{table};
1824     my $class = "FS::$table";
1825
1826     my $record = $class->new( \%hash );
1827
1828     my $param = {};
1829     while ( scalar(@later) ) {
1830       my $sub = shift @later;
1831       my $data = shift @later;
1832       eval {
1833         &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
1834       };
1835       if ( $@ ) {
1836         $dbh->rollback if $oldAutoCommit;
1837         return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
1838       }
1839       last if exists( $param->{skiprow} );
1840     }
1841     next if exists( $param->{skiprow} );
1842
1843     if ( $preinsert_callback ) {
1844       my $error = &{$preinsert_callback}($record, $param);
1845       if ( $error ) {
1846         $dbh->rollback if $oldAutoCommit;
1847         return "preinsert_callback error". ( $line ? " for $line" : '' ).
1848                ": $error";
1849       }
1850       next if exists $param->{skiprow} && $param->{skiprow};
1851     }
1852
1853     my $error = $record->insert;
1854
1855     if ( $error ) {
1856       $dbh->rollback if $oldAutoCommit;
1857       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
1858     }
1859
1860     $row++;
1861     $imported++;
1862
1863     if ( $postinsert_callback ) {
1864       my $error = &{$postinsert_callback}($record, $param);
1865       if ( $error ) {
1866         $dbh->rollback if $oldAutoCommit;
1867         return "postinsert_callback error". ( $line ? " for $line" : '' ).
1868                ": $error";
1869       }
1870     }
1871
1872     if ( $job && time - $min_sec > $last ) { #progress bar
1873       $job->update_statustext( int(100 * $imported / $count) );
1874       $last = time;
1875     }
1876
1877   }
1878
1879   unless ( $imported || $param->{empty_ok} ) {
1880     $dbh->rollback if $oldAutoCommit;
1881     return "Empty file!";
1882   }
1883
1884   $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
1885
1886   ''; #no error
1887
1888 }
1889
1890 sub _h_statement {
1891   my( $self, $action, $time ) = @_;
1892
1893   $time ||= time;
1894
1895   my %nohistory = map { $_=>1 } $self->nohistory_fields;
1896
1897   my @fields =
1898     grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
1899     real_fields($self->table);
1900   ;
1901
1902   # If we're encrypting then don't store the payinfo in the history
1903   if ( $conf && $conf->exists('encryption') && $self->table ne 'banned_pay' ) {
1904     @fields = grep { $_ ne 'payinfo' } @fields;
1905   }
1906
1907   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1908
1909   "INSERT INTO h_". $self->table. " ( ".
1910       join(', ', qw(history_date history_user history_action), @fields ).
1911     ") VALUES (".
1912       join(', ', $time,
1913                  dbh->quote( $FS::CurrentUser::CurrentUser->username ),
1914                  dbh->quote($action),
1915                  @values
1916       ).
1917     ")"
1918   ;
1919 }
1920
1921 =item unique COLUMN
1922
1923 B<Warning>: External use is B<deprecated>.
1924
1925 Replaces COLUMN in record with a unique number, using counters in the
1926 filesystem.  Used by the B<insert> method on single-field unique columns
1927 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1928 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1929
1930 Returns the new value.
1931
1932 =cut
1933
1934 sub unique {
1935   my($self,$field) = @_;
1936   my($table)=$self->table;
1937
1938   croak "Unique called on field $field, but it is ",
1939         $self->getfield($field),
1940         ", not null!"
1941     if $self->getfield($field);
1942
1943   #warn "table $table is tainted" if is_tainted($table);
1944   #warn "field $field is tainted" if is_tainted($field);
1945
1946   my($counter) = new File::CounterFile "$table.$field",0;
1947
1948   my $index = $counter->inc;
1949   $index = $counter->inc while qsearchs($table, { $field=>$index } );
1950
1951   $index =~ /^(\d*)$/;
1952   $index=$1;
1953
1954   $self->setfield($field,$index);
1955
1956 }
1957
1958 =item ut_float COLUMN
1959
1960 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
1961 null.  If there is an error, returns the error, otherwise returns false.
1962
1963 =cut
1964
1965 sub ut_float {
1966   my($self,$field)=@_ ;
1967   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
1968    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
1969    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
1970    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
1971     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1972   $self->setfield($field,$1);
1973   '';
1974 }
1975 =item ut_floatn COLUMN
1976
1977 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1978 null.  If there is an error, returns the error, otherwise returns false.
1979
1980 =cut
1981
1982 #false laziness w/ut_ipn
1983 sub ut_floatn {
1984   my( $self, $field ) = @_;
1985   if ( $self->getfield($field) =~ /^()$/ ) {
1986     $self->setfield($field,'');
1987     '';
1988   } else {
1989     $self->ut_float($field);
1990   }
1991 }
1992
1993 =item ut_sfloat COLUMN
1994
1995 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1996 May not be null.  If there is an error, returns the error, otherwise returns
1997 false.
1998
1999 =cut
2000
2001 sub ut_sfloat {
2002   my($self,$field)=@_ ;
2003   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2004    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2005    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2006    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2007     or return "Illegal or empty (float) $field: ". $self->getfield($field);
2008   $self->setfield($field,$1);
2009   '';
2010 }
2011 =item ut_sfloatn COLUMN
2012
2013 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
2014 null.  If there is an error, returns the error, otherwise returns false.
2015
2016 =cut
2017
2018 sub ut_sfloatn {
2019   my( $self, $field ) = @_;
2020   if ( $self->getfield($field) =~ /^()$/ ) {
2021     $self->setfield($field,'');
2022     '';
2023   } else {
2024     $self->ut_sfloat($field);
2025   }
2026 }
2027
2028 =item ut_snumber COLUMN
2029
2030 Check/untaint signed numeric data (whole numbers).  If there is an error,
2031 returns the error, otherwise returns false.
2032
2033 =cut
2034
2035 sub ut_snumber {
2036   my($self, $field) = @_;
2037   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2038     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2039   $self->setfield($field, "$1$2");
2040   '';
2041 }
2042
2043 =item ut_snumbern COLUMN
2044
2045 Check/untaint signed numeric data (whole numbers).  If there is an error,
2046 returns the error, otherwise returns false.
2047
2048 =cut
2049
2050 sub ut_snumbern {
2051   my($self, $field) = @_;
2052   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2053     or return "Illegal (numeric) $field: ". $self->getfield($field);
2054   if ($1) {
2055     return "Illegal (numeric) $field: ". $self->getfield($field)
2056       unless $2;
2057   }
2058   $self->setfield($field, "$1$2");
2059   '';
2060 }
2061
2062 =item ut_number COLUMN
2063
2064 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
2065 is an error, returns the error, otherwise returns false.
2066
2067 =cut
2068
2069 sub ut_number {
2070   my($self,$field)=@_;
2071   $self->getfield($field) =~ /^\s*(\d+)\s*$/
2072     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2073   $self->setfield($field,$1);
2074   '';
2075 }
2076
2077 =item ut_numbern COLUMN
2078
2079 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
2080 an error, returns the error, otherwise returns false.
2081
2082 =cut
2083
2084 sub ut_numbern {
2085   my($self,$field)=@_;
2086   $self->getfield($field) =~ /^\s*(\d*)\s*$/
2087     or return "Illegal (numeric) $field: ". $self->getfield($field);
2088   $self->setfield($field,$1);
2089   '';
2090 }
2091
2092 =item ut_money COLUMN
2093
2094 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
2095 is an error, returns the error, otherwise returns false.
2096
2097 =cut
2098
2099 sub ut_money {
2100   my($self,$field)=@_;
2101
2102   if ( $self->getfield($field) eq '' ) {
2103     $self->setfield($field, 0);
2104   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2105     #handle one decimal place without barfing out
2106     $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2107   } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2108     $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2109   } else {
2110     return "Illegal (money) $field: ". $self->getfield($field);
2111   }
2112
2113   '';
2114 }
2115
2116 =item ut_moneyn COLUMN
2117
2118 Check/untaint monetary numbers.  May be negative.  If there
2119 is an error, returns the error, otherwise returns false.
2120
2121 =cut
2122
2123 sub ut_moneyn {
2124   my($self,$field)=@_;
2125   if ($self->getfield($field) eq '') {
2126     $self->setfield($field, '');
2127     return '';
2128   }
2129   $self->ut_money($field);
2130 }
2131
2132 =item ut_text COLUMN
2133
2134 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2135 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2136 May not be null.  If there is an error, returns the error, otherwise returns
2137 false.
2138
2139 =cut
2140
2141 sub ut_text {
2142   my($self,$field)=@_;
2143   #warn "msgcat ". \&msgcat. "\n";
2144   #warn "notexist ". \&notexist. "\n";
2145   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2146   $self->getfield($field)
2147     =~ /^([\wô \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
2148       or return gettext('illegal_or_empty_text'). " $field: ".
2149                  $self->getfield($field);
2150   $self->setfield($field,$1);
2151   '';
2152 }
2153
2154 =item ut_textn COLUMN
2155
2156 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2157 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2158 May be null.  If there is an error, returns the error, otherwise returns false.
2159
2160 =cut
2161
2162 sub ut_textn {
2163   my($self,$field)=@_;
2164   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2165   $self->ut_text($field);
2166 }
2167
2168 =item ut_alpha COLUMN
2169
2170 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
2171 an error, returns the error, otherwise returns false.
2172
2173 =cut
2174
2175 sub ut_alpha {
2176   my($self,$field)=@_;
2177   $self->getfield($field) =~ /^(\w+)$/
2178     or return "Illegal or empty (alphanumeric) $field: ".
2179               $self->getfield($field);
2180   $self->setfield($field,$1);
2181   '';
2182 }
2183
2184 =item ut_alphan COLUMN
2185
2186 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
2187 error, returns the error, otherwise returns false.
2188
2189 =cut
2190
2191 sub ut_alphan {
2192   my($self,$field)=@_;
2193   $self->getfield($field) =~ /^(\w*)$/
2194     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2195   $self->setfield($field,$1);
2196   '';
2197 }
2198
2199 =item ut_alphasn COLUMN
2200
2201 Check/untaint alphanumeric strings, spaces allowed.  May be null.  If there is
2202 an error, returns the error, otherwise returns false.
2203
2204 =cut
2205
2206 sub ut_alphasn {
2207   my($self,$field)=@_;
2208   $self->getfield($field) =~ /^([\w ]*)$/
2209     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2210   $self->setfield($field,$1);
2211   '';
2212 }
2213
2214
2215 =item ut_alpha_lower COLUMN
2216
2217 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
2218 there is an error, returns the error, otherwise returns false.
2219
2220 =cut
2221
2222 sub ut_alpha_lower {
2223   my($self,$field)=@_;
2224   $self->getfield($field) =~ /[[:upper:]]/
2225     and return "Uppercase characters are not permitted in $field";
2226   $self->ut_alpha($field);
2227 }
2228
2229 =item ut_phonen COLUMN [ COUNTRY ]
2230
2231 Check/untaint phone numbers.  May be null.  If there is an error, returns
2232 the error, otherwise returns false.
2233
2234 Takes an optional two-letter ISO country code; without it or with unsupported
2235 countries, ut_phonen simply calls ut_alphan.
2236
2237 =cut
2238
2239 sub ut_phonen {
2240   my( $self, $field, $country ) = @_;
2241   return $self->ut_alphan($field) unless defined $country;
2242   my $phonen = $self->getfield($field);
2243   if ( $phonen eq '' ) {
2244     $self->setfield($field,'');
2245   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2246     $phonen =~ s/\D//g;
2247     $phonen = $conf->config('cust_main-default_areacode').$phonen
2248       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2249     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2250       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2251     $phonen = "$1-$2-$3";
2252     $phonen .= " x$4" if $4;
2253     $self->setfield($field,$phonen);
2254   } else {
2255     warn "warning: don't know how to check phone numbers for country $country";
2256     return $self->ut_textn($field);
2257   }
2258   '';
2259 }
2260
2261 =item ut_hex COLUMN
2262
2263 Check/untaint hexadecimal values.
2264
2265 =cut
2266
2267 sub ut_hex {
2268   my($self, $field) = @_;
2269   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2270     or return "Illegal (hex) $field: ". $self->getfield($field);
2271   $self->setfield($field, uc($1));
2272   '';
2273 }
2274
2275 =item ut_hexn COLUMN
2276
2277 Check/untaint hexadecimal values.  May be null.
2278
2279 =cut
2280
2281 sub ut_hexn {
2282   my($self, $field) = @_;
2283   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2284     or return "Illegal (hex) $field: ". $self->getfield($field);
2285   $self->setfield($field, uc($1));
2286   '';
2287 }
2288
2289 =item ut_mac_addr COLUMN
2290
2291 Check/untaint mac addresses.  May be null.
2292
2293 =cut
2294
2295 sub ut_mac_addr {
2296   my($self, $field) = @_;
2297
2298   my $mac = $self->get($field);
2299   $mac =~ s/\s+//g;
2300   $mac =~ s/://g;
2301   $self->set($field, $mac);
2302
2303   my $e = $self->ut_hex($field);
2304   return $e if $e;
2305
2306   return "Illegal (mac address) $field: ". $self->getfield($field)
2307     unless length($self->getfield($field)) == 12;
2308
2309   '';
2310
2311 }
2312
2313 =item ut_mac_addrn COLUMN
2314
2315 Check/untaint mac addresses.  May be null.
2316
2317 =cut
2318
2319 sub ut_mac_addrn {
2320   my($self, $field) = @_;
2321   ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2322 }
2323
2324 =item ut_ip COLUMN
2325
2326 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2327 to 127.0.0.1.
2328
2329 =cut
2330
2331 sub ut_ip {
2332   my( $self, $field ) = @_;
2333   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2334   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2335     or return "Illegal (IP address) $field: ". $self->getfield($field);
2336   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2337   $self->setfield($field, "$1.$2.$3.$4");
2338   '';
2339 }
2340
2341 =item ut_ipn COLUMN
2342
2343 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2344 to 127.0.0.1.  May be null.
2345
2346 =cut
2347
2348 sub ut_ipn {
2349   my( $self, $field ) = @_;
2350   if ( $self->getfield($field) =~ /^()$/ ) {
2351     $self->setfield($field,'');
2352     '';
2353   } else {
2354     $self->ut_ip($field);
2355   }
2356 }
2357
2358 =item ut_ip46 COLUMN
2359
2360 Check/untaint IPv4 or IPv6 address.
2361
2362 =cut
2363
2364 sub ut_ip46 {
2365   my( $self, $field ) = @_;
2366   my $ip = NetAddr::IP->new($self->getfield($field))
2367     or return "Illegal (IP address) $field: ".$self->getfield($field);
2368   $self->setfield($field, lc($ip->addr));
2369   return '';
2370 }
2371
2372 =item ut_ip46n
2373
2374 Check/untaint IPv6 or IPv6 address.  May be null.
2375
2376 =cut
2377
2378 sub ut_ip46n {
2379   my( $self, $field ) = @_;
2380   if ( $self->getfield($field) =~ /^$/ ) {
2381     $self->setfield($field, '');
2382     return '';
2383   }
2384   $self->ut_ip46($field);
2385 }
2386
2387 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2388
2389 Check/untaint coordinates.
2390 Accepts the following forms:
2391 DDD.DDDDD
2392 -DDD.DDDDD
2393 DDD MM.MMM
2394 -DDD MM.MMM
2395 DDD MM SS
2396 -DDD MM SS
2397 DDD MM MMM
2398 -DDD MM MMM
2399
2400 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2401 The latter form (that is, the MMM are thousands of minutes) is
2402 assumed if the "MMM" is exactly three digits or two digits > 59.
2403
2404 To be safe, just use the DDD.DDDDD form.
2405
2406 If LOWER or UPPER are specified, then the coordinate is checked
2407 for lower and upper bounds, respectively.
2408
2409 =cut
2410
2411 sub ut_coord {
2412   my ($self, $field) = (shift, shift);
2413
2414   my($lower, $upper);
2415   if ( $field =~ /latitude/ ) {
2416     $lower = $lat_lower;
2417     $upper = 90;
2418   } elsif ( $field =~ /longitude/ ) {
2419     $lower = -180;
2420     $upper = $lon_upper;
2421   }
2422
2423   my $coord = $self->getfield($field);
2424   my $neg = $coord =~ s/^(-)//;
2425
2426   my ($d, $m, $s) = (0, 0, 0);
2427
2428   if (
2429     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2430     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2431     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2432   ) {
2433     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2434     $m = $m / 60;
2435     if ($m > 59) {
2436       return "Invalid (coordinate with minutes > 59) $field: "
2437              . $self->getfield($field);
2438     }
2439
2440     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2441
2442     if (defined($lower) and ($coord < $lower)) {
2443       return "Invalid (coordinate < $lower) $field: "
2444              . $self->getfield($field);;
2445     }
2446
2447     if (defined($upper) and ($coord > $upper)) {
2448       return "Invalid (coordinate > $upper) $field: "
2449              . $self->getfield($field);;
2450     }
2451
2452     $self->setfield($field, $coord);
2453     return '';
2454   }
2455
2456   return "Invalid (coordinate) $field: " . $self->getfield($field);
2457
2458 }
2459
2460 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2461
2462 Same as ut_coord, except optionally null.
2463
2464 =cut
2465
2466 sub ut_coordn {
2467
2468   my ($self, $field) = (shift, shift);
2469
2470   if ($self->getfield($field) =~ /^\s*$/) {
2471     return '';
2472   } else {
2473     return $self->ut_coord($field, @_);
2474   }
2475
2476 }
2477
2478 =item ut_domain COLUMN
2479
2480 Check/untaint host and domain names.  May not be null.
2481
2482 =cut
2483
2484 sub ut_domain {
2485   my( $self, $field ) = @_;
2486   #$self->getfield($field) =~/^(\w+\.)*\w+$/
2487   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2488     or return "Illegal (hostname) $field: ". $self->getfield($field);
2489   $self->setfield($field,$1);
2490   '';
2491 }
2492
2493 =item ut_domainn COLUMN
2494
2495 Check/untaint host and domain names.  May be null.
2496
2497 =cut
2498
2499 sub ut_domainn {
2500   my( $self, $field ) = @_;
2501   if ( $self->getfield($field) =~ /^()$/ ) {
2502     $self->setfield($field,'');
2503     '';
2504   } else {
2505     $self->ut_domain($field);
2506   }
2507 }
2508
2509 =item ut_name COLUMN
2510
2511 Check/untaint proper names; allows alphanumerics, spaces and the following
2512 punctuation: , . - '
2513
2514 May not be null.
2515
2516 =cut
2517
2518 sub ut_name {
2519   my( $self, $field ) = @_;
2520 #  warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
2521   $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
2522     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2523   my $name = $1;
2524   $name =~ s/^\s+//;
2525   $name =~ s/\s+$//;
2526   $name =~ s/\s+/ /g;
2527   $self->setfield($field, $name);
2528   '';
2529 }
2530
2531 =item ut_namen COLUMN
2532
2533 Check/untaint proper names; allows alphanumerics, spaces and the following
2534 punctuation: , . - '
2535
2536 May not be null.
2537
2538 =cut
2539
2540 sub ut_namen {
2541   my( $self, $field ) = @_;
2542   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2543   $self->ut_name($field);
2544 }
2545
2546 =item ut_zip COLUMN
2547
2548 Check/untaint zip codes.
2549
2550 =cut
2551
2552 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2553
2554 sub ut_zip {
2555   my( $self, $field, $country ) = @_;
2556
2557   if ( $country eq 'US' ) {
2558
2559     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2560       or return gettext('illegal_zip'). " $field for country $country: ".
2561                 $self->getfield($field);
2562     $self->setfield($field, $1);
2563
2564   } elsif ( $country eq 'CA' ) {
2565
2566     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2567       or return gettext('illegal_zip'). " $field for country $country: ".
2568                 $self->getfield($field);
2569     $self->setfield($field, "$1 $2");
2570
2571   } else {
2572
2573     if ( $self->getfield($field) =~ /^\s*$/
2574          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2575        )
2576     {
2577       $self->setfield($field,'');
2578     } else {
2579       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
2580         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2581       $self->setfield($field,$1);
2582     }
2583
2584   }
2585
2586   '';
2587 }
2588
2589 =item ut_country COLUMN
2590
2591 Check/untaint country codes.  Country names are changed to codes, if possible -
2592 see L<Locale::Country>.
2593
2594 =cut
2595
2596 sub ut_country {
2597   my( $self, $field ) = @_;
2598   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2599     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2600          && country2code($1) ) {
2601       $self->setfield($field,uc(country2code($1)));
2602     }
2603   }
2604   $self->getfield($field) =~ /^(\w\w)$/
2605     or return "Illegal (country) $field: ". $self->getfield($field);
2606   $self->setfield($field,uc($1));
2607   '';
2608 }
2609
2610 =item ut_anything COLUMN
2611
2612 Untaints arbitrary data.  Be careful.
2613
2614 =cut
2615
2616 sub ut_anything {
2617   my( $self, $field ) = @_;
2618   $self->getfield($field) =~ /^(.*)$/s
2619     or return "Illegal $field: ". $self->getfield($field);
2620   $self->setfield($field,$1);
2621   '';
2622 }
2623
2624 =item ut_enum COLUMN CHOICES_ARRAYREF
2625
2626 Check/untaint a column, supplying all possible choices, like the "enum" type.
2627
2628 =cut
2629
2630 sub ut_enum {
2631   my( $self, $field, $choices ) = @_;
2632   foreach my $choice ( @$choices ) {
2633     if ( $self->getfield($field) eq $choice ) {
2634       $self->setfield($field, $choice);
2635       return '';
2636     }
2637   }
2638   return "Illegal (enum) field $field: ". $self->getfield($field);
2639 }
2640
2641 =item ut_enumn COLUMN CHOICES_ARRAYREF
2642
2643 Like ut_enum, except the null value is also allowed.
2644
2645 =cut
2646
2647 sub ut_enumn {
2648   my( $self, $field, $choices ) = @_;
2649   $self->getfield($field)
2650     ? $self->ut_enum($field, $choices)
2651     : '';
2652 }
2653
2654 =item ut_flag COLUMN
2655
2656 Check/untaint a column if it contains either an empty string or 'Y'.  This
2657 is the standard form for boolean flags in Freeside.
2658
2659 =cut
2660
2661 sub ut_flag {
2662   my( $self, $field ) = @_;
2663   my $value = uc($self->getfield($field));
2664   if ( $value eq '' or $value eq 'Y' ) {
2665     $self->setfield($field, $value);
2666     return '';
2667   }
2668   return "Illegal (flag) field $field: $value";
2669 }
2670
2671 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2672
2673 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
2674 on the column first.
2675
2676 =cut
2677
2678 sub ut_foreign_key {
2679   my( $self, $field, $table, $foreign ) = @_;
2680   return '' if $no_check_foreign;
2681   qsearchs($table, { $foreign => $self->getfield($field) })
2682     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
2683               " in $table.$foreign";
2684   '';
2685 }
2686
2687 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2688
2689 Like ut_foreign_key, except the null value is also allowed.
2690
2691 =cut
2692
2693 sub ut_foreign_keyn {
2694   my( $self, $field, $table, $foreign ) = @_;
2695   $self->getfield($field)
2696     ? $self->ut_foreign_key($field, $table, $foreign)
2697     : '';
2698 }
2699
2700 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
2701
2702 Checks this column as an agentnum, taking into account the current users's
2703 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
2704 right or rights allowing no agentnum.
2705
2706 =cut
2707
2708 sub ut_agentnum_acl {
2709   my( $self, $field ) = (shift, shift);
2710   my $null_acl = scalar(@_) ? shift : [];
2711   $null_acl = [ $null_acl ] unless ref($null_acl);
2712
2713   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
2714   return "Illegal agentnum: $error" if $error;
2715
2716   my $curuser = $FS::CurrentUser::CurrentUser;
2717
2718   if ( $self->$field() ) {
2719
2720     return "Access denied"
2721       unless $curuser->agentnum($self->$field());
2722
2723   } else {
2724
2725     return "Access denied"
2726       unless grep $curuser->access_right($_), @$null_acl;
2727
2728   }
2729
2730   '';
2731
2732 }
2733
2734 =item fields [ TABLE ]
2735
2736 This is a wrapper for real_fields.  Code that called
2737 fields before should probably continue to call fields.
2738
2739 =cut
2740
2741 sub fields {
2742   my $something = shift;
2743   my $table;
2744   if($something->isa('FS::Record')) {
2745     $table = $something->table;
2746   } else {
2747     $table = $something;
2748     $something = "FS::$table";
2749   }
2750   return (real_fields($table));
2751 }
2752
2753
2754 =item encrypt($value)
2755
2756 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2757
2758 Returns the encrypted string.
2759
2760 You should generally not have to worry about calling this, as the system handles this for you.
2761
2762 =cut
2763
2764 sub encrypt {
2765   my ($self, $value) = @_;
2766   my $encrypted;
2767
2768   if ($conf->exists('encryption')) {
2769     if ($self->is_encrypted($value)) {
2770       # Return the original value if it isn't plaintext.
2771       $encrypted = $value;
2772     } else {
2773       $self->loadRSA;
2774       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2775         # RSA doesn't like the empty string so let's pack it up
2776         # The database doesn't like the RSA data so uuencode it
2777         my $length = length($value)+1;
2778         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2779       } else {
2780         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2781       }
2782     }
2783   }
2784   return $encrypted;
2785 }
2786
2787 =item is_encrypted($value)
2788
2789 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2790
2791 =cut
2792
2793
2794 sub is_encrypted {
2795   my ($self, $value) = @_;
2796   # Possible Bug - Some work may be required here....
2797
2798   if ($value =~ /^M/ && length($value) > 80) {
2799     return 1;
2800   } else {
2801     return 0;
2802   }
2803 }
2804
2805 =item decrypt($value)
2806
2807 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2808
2809 You should generally not have to worry about calling this, as the system handles this for you.
2810
2811 =cut
2812
2813 sub decrypt {
2814   my ($self,$value) = @_;
2815   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2816   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2817     $self->loadRSA;
2818     if (ref($rsa_decrypt) =~ /::RSA/) {
2819       my $encrypted = unpack ("u*", $value);
2820       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2821       if ($@) {warn "Decryption Failed"};
2822     }
2823   }
2824   return $decrypted;
2825 }
2826
2827 sub loadRSA {
2828     my $self = shift;
2829     #Initialize the Module
2830     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2831
2832     if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
2833       $rsa_module = $conf->config('encryptionmodule');
2834     }
2835
2836     if (!$rsa_loaded) {
2837         eval ("require $rsa_module"); # No need to import the namespace
2838         $rsa_loaded++;
2839     }
2840     # Initialize Encryption
2841     if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
2842       my $public_key = join("\n",$conf->config('encryptionpublickey'));
2843       $rsa_encrypt = $rsa_module->new_public_key($public_key);
2844     }
2845
2846     # Intitalize Decryption
2847     if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
2848       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2849       $rsa_decrypt = $rsa_module->new_private_key($private_key);
2850     }
2851 }
2852
2853 =item h_search ACTION
2854
2855 Given an ACTION, either "insert", or "delete", returns the appropriate history
2856 record corresponding to this record, if any.
2857
2858 =cut
2859
2860 sub h_search {
2861   my( $self, $action ) = @_;
2862
2863   my $table = $self->table;
2864   $table =~ s/^h_//;
2865
2866   my $primary_key = dbdef->table($table)->primary_key;
2867
2868   qsearchs({
2869     'table'   => "h_$table",
2870     'hashref' => { $primary_key     => $self->$primary_key(),
2871                    'history_action' => $action,
2872                  },
2873   });
2874
2875 }
2876
2877 =item h_date ACTION
2878
2879 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2880 appropriate history record corresponding to this record, if any.
2881
2882 =cut
2883
2884 sub h_date {
2885   my($self, $action) = @_;
2886   my $h = $self->h_search($action);
2887   $h ? $h->history_date : '';
2888 }
2889
2890 =item scalar_sql SQL [ PLACEHOLDER, ... ]
2891
2892 A class or object method.  Executes the sql statement represented by SQL and
2893 returns a scalar representing the result: the first column of the first row.
2894
2895 Dies on bogus SQL.  Returns an empty string if no row is returned.
2896
2897 Typically used for statments which return a single value such as "SELECT
2898 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
2899
2900 =cut
2901
2902 sub scalar_sql {
2903   my($self, $sql) = (shift, shift);
2904   my $sth = dbh->prepare($sql) or die dbh->errstr;
2905   $sth->execute(@_)
2906     or die "Unexpected error executing statement $sql: ". $sth->errstr;
2907   my $row = $sth->fetchrow_arrayref or return '';
2908   my $scalar = $row->[0];
2909   defined($scalar) ? $scalar : '';
2910 }
2911
2912 =item count [ WHERE ]
2913
2914 Convenience method for the common case of "SELECT COUNT(*) FROM table",
2915 with optional WHERE.  Must be called as method on a class with an
2916 associated table.
2917
2918 =cut
2919
2920 sub count {
2921   my($self, $where) = (shift, shift);
2922   my $table = $self->table or die 'count called on object of class '.ref($self);
2923   my $sql = "SELECT COUNT(*) FROM $table";
2924   $sql .= " WHERE $where" if $where;
2925   $self->scalar_sql($sql);
2926 }
2927
2928 =back
2929
2930 =head1 SUBROUTINES
2931
2932 =over 4
2933
2934 =item real_fields [ TABLE ]
2935
2936 Returns a list of the real columns in the specified table.  Called only by
2937 fields() and other subroutines elsewhere in FS::Record.
2938
2939 =cut
2940
2941 sub real_fields {
2942   my $table = shift;
2943
2944   my($table_obj) = dbdef->table($table);
2945   confess "Unknown table $table" unless $table_obj;
2946   $table_obj->columns;
2947 }
2948
2949 =item pvf FIELD_NAME
2950
2951 Returns the FS::part_virtual_field object corresponding to a field in the
2952 record (specified by FIELD_NAME).
2953
2954 =cut
2955
2956 sub pvf {
2957   my ($self, $name) = (shift, shift);
2958
2959   if(grep /^$name$/, $self->virtual_fields) {
2960     $name =~ s/^cf_//;
2961     my $concat = [ "'cf_'", "name" ];
2962     return qsearchs({   table   =>  'part_virtual_field',
2963                         hashref =>  { dbtable => $self->table,
2964                                       name    => $name
2965                                     },
2966                         select  =>  'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
2967                     });
2968   }
2969   ''
2970 }
2971
2972 =item _quote VALUE, TABLE, COLUMN
2973
2974 This is an internal function used to construct SQL statements.  It returns
2975 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2976 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2977
2978 =cut
2979
2980 sub _quote {
2981   my($value, $table, $column) = @_;
2982   my $column_obj = dbdef->table($table)->column($column);
2983   my $column_type = $column_obj->type;
2984   my $nullable = $column_obj->null;
2985
2986   warn "  $table.$column: $value ($column_type".
2987        ( $nullable ? ' NULL' : ' NOT NULL' ).
2988        ")\n" if $DEBUG > 2;
2989
2990   if ( $value eq '' && $nullable ) {
2991     'NULL';
2992   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2993     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2994           "using 0 instead";
2995     0;
2996   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2997             ! $column_type =~ /(char|binary|text)$/i ) {
2998     $value;
2999   } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3000            && driver_name eq 'Pg'
3001           )
3002   {
3003     no strict 'subs';
3004 #    dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right
3005     # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\,
3006     # single-quote the whole mess, and put an "E" in front.
3007     return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'");
3008   } else {
3009     dbh->quote($value);
3010   }
3011 }
3012
3013 =item hfields TABLE
3014
3015 This is deprecated.  Don't use it.
3016
3017 It returns a hash-type list with the fields of this record's table set true.
3018
3019 =cut
3020
3021 sub hfields {
3022   carp "warning: hfields is deprecated";
3023   my($table)=@_;
3024   my(%hash);
3025   foreach (fields($table)) {
3026     $hash{$_}=1;
3027   }
3028   \%hash;
3029 }
3030
3031 sub _dump {
3032   my($self)=@_;
3033   join("\n", map {
3034     "$_: ". $self->getfield($_). "|"
3035   } (fields($self->table)) );
3036 }
3037
3038 sub DESTROY { return; }
3039
3040 #sub DESTROY {
3041 #  my $self = shift;
3042 #  #use Carp qw(cluck);
3043 #  #cluck "DESTROYING $self";
3044 #  warn "DESTROYING $self";
3045 #}
3046
3047 #sub is_tainted {
3048 #             return ! eval { join('',@_), kill 0; 1; };
3049 #         }
3050
3051 =item str2time_sql [ DRIVER_NAME ]
3052
3053 Returns a function to convert to unix time based on database type, such as
3054 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
3055 the str2time_sql_closing method to return a closing string rather than just
3056 using a closing parenthesis as previously suggested.
3057
3058 You can pass an optional driver name such as "Pg", "mysql" or
3059 $dbh->{Driver}->{Name} to return a function for that database instead of
3060 the current database.
3061
3062 =cut
3063
3064 sub str2time_sql {
3065   my $driver = shift || driver_name;
3066
3067   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
3068   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3069
3070   warn "warning: unknown database type $driver; guessing how to convert ".
3071        "dates to UNIX timestamps";
3072   return 'EXTRACT(EPOCH FROM ';
3073
3074 }
3075
3076 =item str2time_sql_closing [ DRIVER_NAME ]
3077
3078 Returns the closing suffix of a function to convert to unix time based on
3079 database type, such as ")::integer" for Pg or ")" for mysql.
3080
3081 You can pass an optional driver name such as "Pg", "mysql" or
3082 $dbh->{Driver}->{Name} to return a function for that database instead of
3083 the current database.
3084
3085 =cut
3086
3087 sub str2time_sql_closing {
3088   my $driver = shift || driver_name;
3089
3090   return ' )::INTEGER ' if $driver =~ /^Pg/i;
3091   return ' ) ';
3092 }
3093
3094 =item regexp_sql [ DRIVER_NAME ]
3095
3096 Returns the operator to do a regular expression comparison based on database
3097 type, such as '~' for Pg or 'REGEXP' for mysql.
3098
3099 You can pass an optional driver name such as "Pg", "mysql" or
3100 $dbh->{Driver}->{Name} to return a function for that database instead of
3101 the current database.
3102
3103 =cut
3104
3105 sub regexp_sql {
3106   my $driver = shift || driver_name;
3107
3108   return '~'      if $driver =~ /^Pg/i;
3109   return 'REGEXP' if $driver =~ /^mysql/i;
3110
3111   die "don't know how to use regular expressions in ". driver_name." databases";
3112
3113 }
3114
3115 =item not_regexp_sql [ DRIVER_NAME ]
3116
3117 Returns the operator to do a regular expression negation based on database
3118 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3119
3120 You can pass an optional driver name such as "Pg", "mysql" or
3121 $dbh->{Driver}->{Name} to return a function for that database instead of
3122 the current database.
3123
3124 =cut
3125
3126 sub not_regexp_sql {
3127   my $driver = shift || driver_name;
3128
3129   return '!~'         if $driver =~ /^Pg/i;
3130   return 'NOT REGEXP' if $driver =~ /^mysql/i;
3131
3132   die "don't know how to use regular expressions in ". driver_name." databases";
3133
3134 }
3135
3136 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3137
3138 Returns the items concatenated based on database type, using "CONCAT()" for
3139 mysql and " || " for Pg and other databases.
3140
3141 You can pass an optional driver name such as "Pg", "mysql" or
3142 $dbh->{Driver}->{Name} to return a function for that database instead of
3143 the current database.
3144
3145 =cut
3146
3147 sub concat_sql {
3148   my $driver = ref($_[0]) ? driver_name : shift;
3149   my $items = shift;
3150
3151   if ( $driver =~ /^mysql/i ) {
3152     'CONCAT('. join(',', @$items). ')';
3153   } else {
3154     join('||', @$items);
3155   }
3156
3157 }
3158
3159 =item midnight_sql DATE
3160
3161 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3162 on that day in the system timezone, using the default driver name.
3163
3164 =cut
3165
3166 sub midnight_sql {
3167   my $driver = driver_name;
3168   my $expr = shift;
3169   if ( $driver =~ /^mysql/i ) {
3170     "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3171   }
3172   else {
3173     "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3174   }
3175 }
3176
3177 =back
3178
3179 =head1 BUGS
3180
3181 This module should probably be renamed, since much of the functionality is
3182 of general use.  It is not completely unlike Adapter::DBI (see below).
3183
3184 Exported qsearch and qsearchs should be deprecated in favor of method calls
3185 (against an FS::Record object like the old search and searchs that qsearch
3186 and qsearchs were on top of.)
3187
3188 The whole fields / hfields mess should be removed.
3189
3190 The various WHERE clauses should be subroutined.
3191
3192 table string should be deprecated in favor of DBIx::DBSchema::Table.
3193
3194 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
3195 true maps to the database (and WHERE clauses) would also help.
3196
3197 The ut_ methods should ask the dbdef for a default length.
3198
3199 ut_sqltype (like ut_varchar) should all be defined
3200
3201 A fallback check method should be provided which uses the dbdef.
3202
3203 The ut_money method assumes money has two decimal digits.
3204
3205 The Pg money kludge in the new method only strips `$'.
3206
3207 The ut_phonen method only checks US-style phone numbers.
3208
3209 The _quote function should probably use ut_float instead of a regex.
3210
3211 All the subroutines probably should be methods, here or elsewhere.
3212
3213 Probably should borrow/use some dbdef methods where appropriate (like sub
3214 fields)
3215
3216 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3217 or allow it to be set.  Working around it is ugly any way around - DBI should
3218 be fixed.  (only affects RDBMS which return uppercase column names)
3219
3220 ut_zip should take an optional country like ut_phone.
3221
3222 =head1 SEE ALSO
3223
3224 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3225
3226 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
3227
3228 http://poop.sf.net/
3229
3230 =cut
3231
3232 1;
3233