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