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