FS/FS/Record.pm

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