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 non-null unique keys are given a value if empty
 904   #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
 905   foreach ( $self->dbdef_table->unique_singles) {
 906     next if $self->getfield($_);
 907     next if $self->dbdef_table->column($_)->null eq 'NULL';
 908     $self->unique($_);
 909   }
 910
 911   #and also the primary key, if the database isn't going to
 912   my $primary_key = $self->dbdef_table->primary_key;
 913   my $db_seq = 0;
 914   if ( $primary_key ) {
 915     my $col = $self->dbdef_table->column($primary_key);
 916
 917     $db_seq =
 918       uc($col->type) =~ /^(BIG)?SERIAL\d?/
 919       || ( driver_name eq 'Pg'
 920              && defined($col->default)
 921              && $col->quoted_default =~ /^nextval\(/i
 922          )
 923       || ( driver_name eq 'mysql'
 924              && defined($col->local)
 925              && $col->local =~ /AUTO_INCREMENT/i
 926          );
 927     $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
 928   }
 929
 930   my $table = $self->table;
 931
 932   # Encrypt before the database
 933   if (    defined(eval '@FS::'. $table . '::encrypted_fields')
 934        && scalar( eval '@FS::'. $table . '::encrypted_fields')
 935        && $conf->exists('encryption')
 936   ) {
 937     foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
 938       next if $field eq 'payinfo'
 939                 && ($self->isa('FS::payinfo_transaction_Mixin')
 940                     || $self->isa('FS::payinfo_Mixin') )
 941                 && $self->payby
 942                 && !grep { $self->payby eq $_ } @encrypt_payby;
 943       $saved->{$field} = $self->getfield($field);
 944       $self->setfield($field, $self->encrypt($self->getfield($field)));
 945     }
 946   }
 947
 948   #false laziness w/delete
 949   my @real_fields =
 950     grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
 951     real_fields($table)
 952   ;
 953   my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
 954   #eslaf
 955
 956   my $statement = "INSERT INTO $table ";
 957   if ( @real_fields ) {
 958     $statement .=
 959       "( ".
 960         join( ', ', @real_fields ).
 961       ") VALUES (".
 962         join( ', ', @values ).
 963        ")"
 964     ;
 965   } else {
 966     $statement .= 'DEFAULT VALUES';
 967   }
 968   warn "[debug]$me $statement\n" if $DEBUG > 1;
 969   my $sth = dbh->prepare($statement) or return dbh->errstr;
 970
 971   local $SIG{HUP} = 'IGNORE';
 972   local $SIG{INT} = 'IGNORE';
 973   local $SIG{QUIT} = 'IGNORE';
 974   local $SIG{TERM} = 'IGNORE';
 975   local $SIG{TSTP} = 'IGNORE';
 976   local $SIG{PIPE} = 'IGNORE';
 977
 978   $sth->execute or return $sth->errstr;
 979
 980   # get inserted id from the database, if applicable & needed
 981   if ( $db_seq && ! $self->getfield($primary_key) ) {
 982     warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
 983
 984     my $insertid = '';
 985
 986     if ( driver_name eq 'Pg' ) {
 987
 988       #my $oid = $sth->{'pg_oid_status'};
 989       #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
 990
 991       my $default = $self->dbdef_table->column($primary_key)->quoted_default;
 992       unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
 993         dbh->rollback if $FS::UID::AutoCommit;
 994         return "can't parse $table.$primary_key default value".
 995                " for sequence name: $default";
 996       }
 997       my $sequence = $1;
 998
 999       my $i_sql = "SELECT currval('$sequence')";
1000       my $i_sth = dbh->prepare($i_sql) or do {
1001         dbh->rollback if $FS::UID::AutoCommit;
1002         return dbh->errstr;
1003       };
1004       $i_sth->execute() or do { #$i_sth->execute($oid)
1005         dbh->rollback if $FS::UID::AutoCommit;
1006         return $i_sth->errstr;
1007       };
1008       $insertid = $i_sth->fetchrow_arrayref->[0];
1009
1010     } elsif ( driver_name eq 'mysql' ) {
1011
1012       $insertid = dbh->{'mysql_insertid'};
1013       # work around mysql_insertid being null some of the time, ala RT :/
1014       unless ( $insertid ) {
1015         warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
1016              "using SELECT LAST_INSERT_ID();";
1017         my $i_sql = "SELECT LAST_INSERT_ID()";
1018         my $i_sth = dbh->prepare($i_sql) or do {
1019           dbh->rollback if $FS::UID::AutoCommit;
1020           return dbh->errstr;
1021         };
1022         $i_sth->execute or do {
1023           dbh->rollback if $FS::UID::AutoCommit;
1024           return $i_sth->errstr;
1025         };
1026         $insertid = $i_sth->fetchrow_arrayref->[0];
1027       }
1028
1029     } else {
1030
1031       dbh->rollback if $FS::UID::AutoCommit;
1032       return "don't know how to retreive inserted ids from ". driver_name.
1033              ", try using counterfiles (maybe run dbdef-create?)";
1034
1035     }
1036
1037     $self->setfield($primary_key, $insertid);
1038
1039   }
1040
1041   my $h_sth;
1042   if ( defined dbdef->table('h_'. $table) ) {
1043     my $h_statement = $self->_h_statement('insert');
1044     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1045     $h_sth = dbh->prepare($h_statement) or do {
1046       dbh->rollback if $FS::UID::AutoCommit;
1047       return dbh->errstr;
1048     };
1049   } else {
1050     $h_sth = '';
1051   }
1052   $h_sth->execute or return $h_sth->errstr if $h_sth;
1053
1054   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1055
1056   # Now that it has been saved, reset the encrypted fields so that $new
1057   # can still be used.
1058   foreach my $field (keys %{$saved}) {
1059     $self->setfield($field, $saved->{$field});
1060   }
1061
1062   '';
1063 }
1064
1065 =item add
1066
1067 Depriciated (use insert instead).
1068
1069 =cut
1070
1071 sub add {
1072   cluck "warning: FS::Record::add deprecated!";
1073   insert @_; #call method in this scope
1074 }
1075
1076 =item delete
1077
1078 Delete this record from the database.  If there is an error, returns the error,
1079 otherwise returns false.
1080
1081 =cut
1082
1083 sub delete {
1084   my $self = shift;
1085
1086   my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1087     map {
1088       $self->getfield($_) eq ''
1089         #? "( $_ IS NULL OR $_ = \"\" )"
1090         ? ( driver_name eq 'Pg'
1091               ? "$_ IS NULL"
1092               : "( $_ IS NULL OR $_ = \"\" )"
1093           )
1094         : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1095     } ( $self->dbdef_table->primary_key )
1096           ? ( $self->dbdef_table->primary_key)
1097           : real_fields($self->table)
1098   );
1099   warn "[debug]$me $statement\n" if $DEBUG > 1;
1100   my $sth = dbh->prepare($statement) or return dbh->errstr;
1101
1102   my $h_sth;
1103   if ( defined dbdef->table('h_'. $self->table) ) {
1104     my $h_statement = $self->_h_statement('delete');
1105     warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1106     $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1107   } else {
1108     $h_sth = '';
1109   }
1110
1111   my $primary_key = $self->dbdef_table->primary_key;
1112
1113   local $SIG{HUP} = 'IGNORE';
1114   local $SIG{INT} = 'IGNORE';
1115   local $SIG{QUIT} = 'IGNORE';
1116   local $SIG{TERM} = 'IGNORE';
1117   local $SIG{TSTP} = 'IGNORE';
1118   local $SIG{PIPE} = 'IGNORE';
1119
1120   my $rc = $sth->execute or return $sth->errstr;
1121   #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1122   $h_sth->execute or return $h_sth->errstr if $h_sth;
1123
1124   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1125
1126   #no need to needlessly destoy the data either (causes problems actually)
1127   #undef $self; #no need to keep object!
1128
1129   '';
1130 }
1131
1132 =item del
1133
1134 Depriciated (use delete instead).
1135
1136 =cut
1137
1138 sub del {
1139   cluck "warning: FS::Record::del deprecated!";
1140   &delete(@_); #call method in this scope
1141 }
1142
1143 =item replace OLD_RECORD
1144
1145 Replace the OLD_RECORD with this one in the database.  If there is an error,
1146 returns the error, otherwise returns false.
1147
1148 =cut
1149
1150 sub replace {
1151   my ($new, $old) = (shift, shift);
1152
1153   $old = $new->replace_old unless defined($old);
1154
1155   warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1156
1157   if ( $new->can('replace_check') ) {
1158     my $error = $new->replace_check($old);
1159     return $error if $error;
1160   }
1161
1162   return "Records not in same table!" unless $new->table eq $old->table;
1163
1164   my $primary_key = $old->dbdef_table->primary_key;
1165   return "Can't change primary key $primary_key ".
1166          'from '. $old->getfield($primary_key).
1167          ' to ' . $new->getfield($primary_key)
1168     if $primary_key
1169        && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1170
1171   my $error = $new->check;
1172   return $error if $error;
1173
1174   # Encrypt for replace
1175   my $saved = {};
1176   if (    $conf->exists('encryption')
1177        && defined(eval '@FS::'. $new->table . '::encrypted_fields')
1178        && scalar( eval '@FS::'. $new->table . '::encrypted_fields')
1179   ) {
1180     foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1181       next if $field eq 'payinfo'
1182                 && ($new->isa('FS::payinfo_transaction_Mixin')
1183                     || $new->isa('FS::payinfo_Mixin') )
1184                 && $new->payby
1185                 && !grep { $new->payby eq $_ } @encrypt_payby;
1186       $saved->{$field} = $new->getfield($field);
1187       $new->setfield($field, $new->encrypt($new->getfield($field)));
1188     }
1189   }
1190
1191   #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1192   my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1193                    ? ($_, $new->getfield($_)) : () } $old->fields;
1194
1195   unless (keys(%diff) || $no_update_diff ) {
1196     carp "[warning]$me ". ref($new)."->replace ".
1197            ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
1198          ": records identical"
1199       unless $nowarn_identical;
1200     return '';
1201   }
1202
1203   my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1204     map {
1205       "$_ = ". _quote($new->getfield($_),$old->table,$_)
1206     } real_fields($old->table)
1207   ). ' WHERE '.
1208     join(' AND ',
1209       map {
1210
1211         if ( $old->getfield($_) eq '' ) {
1212
1213          #false laziness w/qsearch
1214          if ( driver_name eq 'Pg' ) {
1215             my $type = $old->dbdef_table->column($_)->type;
1216             if ( $type =~ /(int|(big)?serial)/i ) {
1217               qq-( $_ IS NULL )-;
1218             } else {
1219               qq-( $_ IS NULL OR $_ = '' )-;
1220             }
1221           } else {
1222             qq-( $_ IS NULL OR $_ = "" )-;
1223           }
1224
1225         } else {
1226           "$_ = ". _quote($old->getfield($_),$old->table,$_);
1227         }
1228
1229       } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1230     )
1231   ;
1232   warn "[debug]$me $statement\n" if $DEBUG > 1;
1233   my $sth = dbh->prepare($statement) or return dbh->errstr;
1234
1235   my $h_old_sth;
1236   if ( defined dbdef->table('h_'. $old->table) ) {
1237     my $h_old_statement = $old->_h_statement('replace_old');
1238     warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1239     $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1240   } else {
1241     $h_old_sth = '';
1242   }
1243
1244   my $h_new_sth;
1245   if ( defined dbdef->table('h_'. $new->table) ) {
1246     my $h_new_statement = $new->_h_statement('replace_new');
1247     warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1248     $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1249   } else {
1250     $h_new_sth = '';
1251   }
1252
1253   local $SIG{HUP} = 'IGNORE';
1254   local $SIG{INT} = 'IGNORE';
1255   local $SIG{QUIT} = 'IGNORE';
1256   local $SIG{TERM} = 'IGNORE';
1257   local $SIG{TSTP} = 'IGNORE';
1258   local $SIG{PIPE} = 'IGNORE';
1259
1260   my $rc = $sth->execute or return $sth->errstr;
1261   #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1262   $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1263   $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1264
1265   dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1266
1267   # Now that it has been saved, reset the encrypted fields so that $new
1268   # can still be used.
1269   foreach my $field (keys %{$saved}) {
1270     $new->setfield($field, $saved->{$field});
1271   }
1272
1273   '';
1274
1275 }
1276
1277 sub replace_old {
1278   my( $self ) = shift;
1279   warn "[$me] replace called with no arguments; autoloading old record\n"
1280     if $DEBUG;
1281
1282   my $primary_key = $self->dbdef_table->primary_key;
1283   if ( $primary_key ) {
1284     $self->by_key( $self->$primary_key() ) #this is what's returned
1285       or croak "can't find ". $self->table. ".$primary_key ".
1286         $self->$primary_key();
1287   } else {
1288     croak $self->table. " has no primary key; pass old record as argument";
1289   }
1290
1291 }
1292
1293 =item rep
1294
1295 Depriciated (use replace instead).
1296
1297 =cut
1298
1299 sub rep {
1300   cluck "warning: FS::Record::rep deprecated!";
1301   replace @_; #call method in this scope
1302 }
1303
1304 =item check
1305
1306 Checks custom fields. Subclasses should still provide a check method to validate
1307 non-custom fields, foreign keys, etc., and call this method via $self->SUPER::check.
1308
1309 =cut
1310
1311 sub check {
1312     my $self = shift;
1313     foreach my $field ($self->virtual_fields) {
1314         my $error = $self->ut_textn($field);
1315         return $error if $error;
1316     }
1317     '';
1318 }
1319
1320 =item virtual_fields [ TABLE ]
1321
1322 Returns a list of virtual fields defined for the table.  This should not
1323 be exported, and should only be called as an instance or class method.
1324
1325 =cut
1326
1327 sub virtual_fields {
1328   my $self = shift;
1329   my $table;
1330   $table = $self->table or confess "virtual_fields called on non-table";
1331
1332   confess "Unknown table $table" unless dbdef->table($table);
1333
1334   return () unless dbdef->table('part_virtual_field');
1335
1336   unless ( $virtual_fields_cache{$table} ) {
1337     my $concat = [ "'cf_'", "name" ];
1338     my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' .
1339                 "WHERE dbtable = '$table'";
1340     my $dbh = dbh;
1341     my $result = $dbh->selectcol_arrayref($query);
1342     confess "Error executing virtual fields query: $query: ". $dbh->errstr
1343       if $dbh->err;
1344     $virtual_fields_cache{$table} = $result;
1345   }
1346
1347   @{$virtual_fields_cache{$table}};
1348
1349 }
1350
1351 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1352
1353 Processes a batch import as a queued JSRPC job
1354
1355 JOB is an FS::queue entry.
1356
1357 OPTIONS_HASHREF can have the following keys:
1358
1359 =over 4
1360
1361 =item table
1362
1363 Table name (required).
1364
1365 =item params
1366
1367 Listref of field names for static fields.  They will be given values from the
1368 PARAMS hashref and passed as a "params" hashref to batch_import.
1369
1370 =item formats
1371
1372 Formats hashref.  Keys are field names, values are listrefs that define the
1373 format.
1374
1375 Each listref value can be a column name or a code reference.  Coderefs are run
1376 with the row object, data and a FS::Conf object as the three parameters.
1377 For example, this coderef does the same thing as using the "columnname" string:
1378
1379   sub {
1380     my( $record, $data, $conf ) = @_;
1381     $record->columnname( $data );
1382   },
1383
1384 Coderefs are run after all "column name" fields are assigned.
1385
1386 =item format_types
1387
1388 Optional format hashref of types.  Keys are field names, values are "csv",
1389 "xls" or "fixedlength".  Overrides automatic determination of file type
1390 from extension.
1391
1392 =item format_headers
1393
1394 Optional format hashref of header lines.  Keys are field names, values are 0
1395 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1396 number of lines.
1397
1398 =item format_sep_chars
1399
1400 Optional format hashref of CSV sep_chars.  Keys are field names, values are the
1401 CSV separation character.
1402
1403 =item format_fixedlenth_formats
1404
1405 Optional format hashref of fixed length format defintiions.  Keys are field
1406 names, values Parse::FixedLength listrefs of field definitions.
1407
1408 =item default_csv
1409
1410 Set true to default to CSV file type if the filename does not contain a
1411 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1412 format_types).
1413
1414 =back
1415
1416 PARAMS is a base64-encoded Storable string containing the POSTed data as
1417 a hash ref.  It normally contains at least one field, "uploaded files",
1418 generated by /elements/file-upload.html and containing the list of uploaded
1419 files.  Currently only supports a single file named "file".
1420
1421 =cut
1422
1423 use Storable qw(thaw);
1424 use Data::Dumper;
1425 use MIME::Base64;
1426 sub process_batch_import {
1427   my($job, $opt) = ( shift, shift );
1428
1429   my $table = $opt->{table};
1430   my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1431   my %formats = %{ $opt->{formats} };
1432
1433   my $param = thaw(decode_base64(shift));
1434   warn Dumper($param) if $DEBUG;
1435
1436   my $files = $param->{'uploaded_files'}
1437     or die "No files provided.\n";
1438
1439   my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1440
1441   my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1442   my $file = $dir. $files{'file'};
1443
1444   my %iopt = (
1445     #class-static
1446     table                      => $table,
1447     formats                    => \%formats,
1448     format_types               => $opt->{format_types},
1449     format_headers             => $opt->{format_headers},
1450     format_sep_chars           => $opt->{format_sep_chars},
1451     format_fixedlength_formats => $opt->{format_fixedlength_formats},
1452     format_xml_formats         => $opt->{format_xml_formats},
1453     format_row_callbacks       => $opt->{format_row_callbacks},
1454     #per-import
1455     job                        => $job,
1456     file                       => $file,
1457     #type                       => $type,
1458     format                     => $param->{format},
1459     params                     => { map { $_ => $param->{$_} } @pass_params },
1460     #?
1461     default_csv                => $opt->{default_csv},
1462     postinsert_callback        => $opt->{postinsert_callback},
1463   );
1464
1465   if ( $opt->{'batch_namecol'} ) {
1466     $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1467     $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1468   }
1469
1470   my $error = FS::Record::batch_import( \%iopt );
1471
1472   unlink $file;
1473
1474   die "$error\n" if $error;
1475 }
1476
1477 =item batch_import PARAM_HASHREF
1478
1479 Class method for batch imports.  Available params:
1480
1481 =over 4
1482
1483 =item table
1484
1485 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1486
1487 =item formats
1488
1489 =item format_types
1490
1491 =item format_headers
1492
1493 =item format_sep_chars
1494
1495 =item format_fixedlength_formats
1496
1497 =item format_row_callbacks
1498
1499 =item fields - Alternate way to specify import, specifying import fields directly as a listref
1500
1501 =item preinsert_callback
1502
1503 =item postinsert_callback
1504
1505 =item params
1506
1507 =item job
1508
1509 FS::queue object, will be updated with progress
1510
1511 =item file
1512
1513 =item type
1514
1515 csv, xls, fixedlength, xml
1516
1517 =item empty_ok
1518
1519 =back
1520
1521 =cut
1522
1523 sub batch_import {
1524   my $param = shift;
1525
1526   warn "$me batch_import call with params: \n". Dumper($param)
1527     if $DEBUG;
1528
1529   my $table   = $param->{table};
1530
1531   my $job     = $param->{job};
1532   my $file    = $param->{file};
1533   my $params  = $param->{params} || {};
1534
1535   my( $type, $header, $sep_char, $fixedlength_format,
1536       $xml_format, $row_callback, @fields );
1537
1538   my $postinsert_callback = '';
1539   $postinsert_callback = $param->{'postinsert_callback'}
1540           if $param->{'postinsert_callback'};
1541   my $preinsert_callback = '';
1542   $preinsert_callback = $param->{'preinsert_callback'}
1543           if $param->{'preinsert_callback'};
1544
1545   if ( $param->{'format'} ) {
1546
1547     my $format  = $param->{'format'};
1548     my $formats = $param->{formats};
1549     die "unknown format $format" unless exists $formats->{ $format };
1550
1551     $type = $param->{'format_types'}
1552             ? $param->{'format_types'}{ $format }
1553             : $param->{type} || 'csv';
1554
1555
1556     $header = $param->{'format_headers'}
1557                ? $param->{'format_headers'}{ $param->{'format'} }
1558                : 0;
1559
1560     $sep_char = $param->{'format_sep_chars'}
1561                   ? $param->{'format_sep_chars'}{ $param->{'format'} }
1562                   : ',';
1563
1564     $fixedlength_format =
1565       $param->{'format_fixedlength_formats'}
1566         ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1567         : '';
1568
1569     $xml_format =
1570       $param->{'format_xml_formats'}
1571         ? $param->{'format_xml_formats'}{ $param->{'format'} }
1572         : '';
1573
1574     $row_callback =
1575       $param->{'format_row_callbacks'}
1576         ? $param->{'format_row_callbacks'}{ $param->{'format'} }
1577         : '';
1578
1579     @fields = @{ $formats->{ $format } };
1580
1581   } elsif ( $param->{'fields'} ) {
1582
1583     $type = ''; #infer from filename
1584     $header = 0;
1585     $sep_char = ',';
1586     $fixedlength_format = '';
1587     $row_callback = '';
1588     @fields = @{ $param->{'fields'} };
1589
1590   } else {
1591     die "neither format nor fields specified";
1592   }
1593
1594   #my $file    = $param->{file};
1595
1596   unless ( $type ) {
1597     if ( $file =~ /\.(\w+)$/i ) {
1598       $type = lc($1);
1599     } else {
1600       #or error out???
1601       warn "can't parse file type from filename $file; defaulting to CSV";
1602       $type = 'csv';
1603     }
1604     $type = 'csv'
1605       if $param->{'default_csv'} && $type ne 'xls';
1606   }
1607
1608
1609   my $row = 0;
1610   my $count;
1611   my $parser;
1612   my @buffer = ();
1613   if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1614
1615     if ( $type eq 'csv' ) {
1616
1617       my %attr = ();
1618       $attr{sep_char} = $sep_char if $sep_char;
1619       $parser = new Text::CSV_XS \%attr;
1620
1621     } elsif ( $type eq 'fixedlength' ) {
1622
1623       eval "use Parse::FixedLength;";
1624       die $@ if $@;
1625       $parser = Parse::FixedLength->new($fixedlength_format);
1626
1627     }
1628     else {
1629       die "Unknown file type $type\n";
1630     }
1631
1632     @buffer = split(/\r?\n/, slurp($file) );
1633     splice(@buffer, 0, ($header || 0) );
1634     $count = scalar(@buffer);
1635
1636   } elsif ( $type eq 'xls' ) {
1637
1638     eval "use Spreadsheet::ParseExcel;";
1639     die $@ if $@;
1640
1641     eval "use DateTime::Format::Excel;";
1642     #for now, just let the error be thrown if it is used, since only CDR
1643     # formats bill_west and troop use it, not other excel-parsing things
1644     #die $@ if $@;
1645
1646     my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
1647
1648     $parser = $excel->{Worksheet}[0]; #first sheet
1649
1650     $count = $parser->{MaxRow} || $parser->{MinRow};
1651     $count++;
1652
1653     $row = $header || 0;
1654   } elsif ( $type eq 'xml' ) {
1655     # FS::pay_batch
1656     eval "use XML::Simple;";
1657     die $@ if $@;
1658     my $xmlrow = $xml_format->{'xmlrow'};
1659     $parser = $xml_format->{'xmlkeys'};
1660     die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
1661     my $data = XML::Simple::XMLin(
1662       $file,
1663       'SuppressEmpty' => '', #sets empty values to ''
1664       'KeepRoot'      => 1,
1665     );
1666     my $rows = $data;
1667     $rows = $rows->{$_} foreach @$xmlrow;
1668     $rows = [ $rows ] if ref($rows) ne 'ARRAY';
1669     $count = @buffer = @$rows;
1670   } else {
1671     die "Unknown file type $type\n";
1672   }
1673
1674   #my $columns;
1675
1676   local $SIG{HUP} = 'IGNORE';
1677   local $SIG{INT} = 'IGNORE';
1678   local $SIG{QUIT} = 'IGNORE';
1679   local $SIG{TERM} = 'IGNORE';
1680   local $SIG{TSTP} = 'IGNORE';
1681   local $SIG{PIPE} = 'IGNORE';
1682
1683   my $oldAutoCommit = $FS::UID::AutoCommit;
1684   local $FS::UID::AutoCommit = 0;
1685   my $dbh = dbh;
1686
1687   #my $params  = $param->{params} || {};
1688   if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
1689     my $batch_col   = $param->{'batch_keycol'};
1690
1691     my $batch_class = 'FS::'. $param->{'batch_table'};
1692     my $batch = $batch_class->new({
1693       $param->{'batch_namecol'} => $param->{'batch_namevalue'}
1694     });
1695     my $error = $batch->insert;
1696     if ( $error ) {
1697       $dbh->rollback if $oldAutoCommit;
1698       return "can't insert batch record: $error";
1699     }
1700     #primary key via dbdef? (so the column names don't have to match)
1701     my $batch_value = $batch->get( $param->{'batch_keycol'} );
1702
1703     $params->{ $batch_col } = $batch_value;
1704   }
1705
1706   #my $job     = $param->{job};
1707   my $line;
1708   my $imported = 0;
1709   my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
1710   while (1) {
1711
1712     my @columns = ();
1713     if ( $type eq 'csv' ) {
1714
1715       last unless scalar(@buffer);
1716       $line = shift(@buffer);
1717
1718       next if $line =~ /^\s*$/; #skip empty lines
1719
1720       $line = &{$row_callback}($line) if $row_callback;
1721
1722       next if $line =~ /^\s*$/; #skip empty lines
1723
1724       $parser->parse($line) or do {
1725         $dbh->rollback if $oldAutoCommit;
1726         return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
1727       };
1728       @columns = $parser->fields();
1729
1730     } elsif ( $type eq 'fixedlength' ) {
1731
1732       last unless scalar(@buffer);
1733       $line = shift(@buffer);
1734
1735       @columns = $parser->parse($line);
1736
1737     } elsif ( $type eq 'xls' ) {
1738
1739       last if $row > ($parser->{MaxRow} || $parser->{MinRow})
1740            || ! $parser->{Cells}[$row];
1741
1742       my @row = @{ $parser->{Cells}[$row] };
1743       @columns = map $_->{Val}, @row;
1744
1745       #my $z = 'A';
1746       #warn $z++. ": $_\n" for @columns;
1747
1748     } elsif ( $type eq 'xml' ) {
1749       # $parser = [ 'Column0Key', 'Column1Key' ... ]
1750       last unless scalar(@buffer);
1751       my $row = shift @buffer;
1752       @columns = @{ $row }{ @$parser };
1753     } else {
1754       die "Unknown file type $type\n";
1755     }
1756
1757     my @later = ();
1758     my %hash = %$params;
1759
1760     foreach my $field ( @fields ) {
1761
1762       my $value = shift @columns;
1763
1764       if ( ref($field) eq 'CODE' ) {
1765         #&{$field}(\%hash, $value);
1766         push @later, $field, $value;
1767       } else {
1768         #??? $hash{$field} = $value if length($value);
1769         $hash{$field} = $value if defined($value) && length($value);
1770       }
1771
1772     }
1773
1774     #my $table   = $param->{table};
1775     my $class = "FS::$table";
1776
1777     my $record = $class->new( \%hash );
1778
1779     my $param = {};
1780     while ( scalar(@later) ) {
1781       my $sub = shift @later;
1782       my $data = shift @later;
1783       eval {
1784         &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
1785       };
1786       if ( $@ ) {
1787         $dbh->rollback if $oldAutoCommit;
1788         return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
1789       }
1790       last if exists( $param->{skiprow} );
1791     }
1792     next if exists( $param->{skiprow} );
1793
1794     if ( $preinsert_callback ) {
1795       my $error = &{$preinsert_callback}($record, $param);
1796       if ( $error ) {
1797         $dbh->rollback if $oldAutoCommit;
1798         return "preinsert_callback error". ( $line ? " for $line" : '' ).
1799                ": $error";
1800       }
1801       next if exists $param->{skiprow} && $param->{skiprow};
1802     }
1803
1804     my $error = $record->insert;
1805
1806     if ( $error ) {
1807       $dbh->rollback if $oldAutoCommit;
1808       return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
1809     }
1810
1811     $row++;
1812     $imported++;
1813
1814     if ( $postinsert_callback ) {
1815       my $error = &{$postinsert_callback}($record, $param);
1816       if ( $error ) {
1817         $dbh->rollback if $oldAutoCommit;
1818         return "postinsert_callback error". ( $line ? " for $line" : '' ).
1819                ": $error";
1820       }
1821     }
1822
1823     if ( $job && time - $min_sec > $last ) { #progress bar
1824       $job->update_statustext( int(100 * $imported / $count) );
1825       $last = time;
1826     }
1827
1828   }
1829
1830   unless ( $imported || $param->{empty_ok} ) {
1831     $dbh->rollback if $oldAutoCommit;
1832     return "Empty file!";
1833   }
1834
1835   $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
1836
1837   ''; #no error
1838
1839 }
1840
1841 sub _h_statement {
1842   my( $self, $action, $time ) = @_;
1843
1844   $time ||= time;
1845
1846   my %nohistory = map { $_=>1 } $self->nohistory_fields;
1847
1848   my @fields =
1849     grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
1850     real_fields($self->table);
1851   ;
1852
1853   # If we're encrypting then don't store the payinfo in the history
1854   if ( $conf && $conf->exists('encryption') && $self->table ne 'banned_pay' ) {
1855     @fields = grep { $_ ne 'payinfo' } @fields;
1856   }
1857
1858   my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1859
1860   "INSERT INTO h_". $self->table. " ( ".
1861       join(', ', qw(history_date history_user history_action), @fields ).
1862     ") VALUES (".
1863       join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1864     ")"
1865   ;
1866 }
1867
1868 =item unique COLUMN
1869
1870 B<Warning>: External use is B<deprecated>.
1871
1872 Replaces COLUMN in record with a unique number, using counters in the
1873 filesystem.  Used by the B<insert> method on single-field unique columns
1874 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1875 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1876
1877 Returns the new value.
1878
1879 =cut
1880
1881 sub unique {
1882   my($self,$field) = @_;
1883   my($table)=$self->table;
1884
1885   croak "Unique called on field $field, but it is ",
1886         $self->getfield($field),
1887         ", not null!"
1888     if $self->getfield($field);
1889
1890   #warn "table $table is tainted" if is_tainted($table);
1891   #warn "field $field is tainted" if is_tainted($field);
1892
1893   my($counter) = new File::CounterFile "$table.$field",0;
1894 # hack for web demo
1895 #  getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1896 #  my($user)=$1;
1897 #  my($counter) = new File::CounterFile "$user/$table.$field",0;
1898 # endhack
1899
1900   my $index = $counter->inc;
1901   $index = $counter->inc while qsearchs($table, { $field=>$index } );
1902
1903   $index =~ /^(\d*)$/;
1904   $index=$1;
1905
1906   $self->setfield($field,$index);
1907
1908 }
1909
1910 =item ut_float COLUMN
1911
1912 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May not be
1913 null.  If there is an error, returns the error, otherwise returns false.
1914
1915 =cut
1916
1917 sub ut_float {
1918   my($self,$field)=@_ ;
1919   ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
1920    $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
1921    $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
1922    $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
1923     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1924   $self->setfield($field,$1);
1925   '';
1926 }
1927 =item ut_floatn COLUMN
1928
1929 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1930 null.  If there is an error, returns the error, otherwise returns false.
1931
1932 =cut
1933
1934 #false laziness w/ut_ipn
1935 sub ut_floatn {
1936   my( $self, $field ) = @_;
1937   if ( $self->getfield($field) =~ /^()$/ ) {
1938     $self->setfield($field,'');
1939     '';
1940   } else {
1941     $self->ut_float($field);
1942   }
1943 }
1944
1945 =item ut_sfloat COLUMN
1946
1947 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1948 May not be null.  If there is an error, returns the error, otherwise returns
1949 false.
1950
1951 =cut
1952
1953 sub ut_sfloat {
1954   my($self,$field)=@_ ;
1955   ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
1956    $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
1957    $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
1958    $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
1959     or return "Illegal or empty (float) $field: ". $self->getfield($field);
1960   $self->setfield($field,$1);
1961   '';
1962 }
1963 =item ut_sfloatn COLUMN
1964
1965 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.  May be
1966 null.  If there is an error, returns the error, otherwise returns false.
1967
1968 =cut
1969
1970 sub ut_sfloatn {
1971   my( $self, $field ) = @_;
1972   if ( $self->getfield($field) =~ /^()$/ ) {
1973     $self->setfield($field,'');
1974     '';
1975   } else {
1976     $self->ut_sfloat($field);
1977   }
1978 }
1979
1980 =item ut_snumber COLUMN
1981
1982 Check/untaint signed numeric data (whole numbers).  If there is an error,
1983 returns the error, otherwise returns false.
1984
1985 =cut
1986
1987 sub ut_snumber {
1988   my($self, $field) = @_;
1989   $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
1990     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1991   $self->setfield($field, "$1$2");
1992   '';
1993 }
1994
1995 =item ut_snumbern COLUMN
1996
1997 Check/untaint signed numeric data (whole numbers).  If there is an error,
1998 returns the error, otherwise returns false.
1999
2000 =cut
2001
2002 sub ut_snumbern {
2003   my($self, $field) = @_;
2004   $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2005     or return "Illegal (numeric) $field: ". $self->getfield($field);
2006   if ($1) {
2007     return "Illegal (numeric) $field: ". $self->getfield($field)
2008       unless $2;
2009   }
2010   $self->setfield($field, "$1$2");
2011   '';
2012 }
2013
2014 =item ut_number COLUMN
2015
2016 Check/untaint simple numeric data (whole numbers).  May not be null.  If there
2017 is an error, returns the error, otherwise returns false.
2018
2019 =cut
2020
2021 sub ut_number {
2022   my($self,$field)=@_;
2023   $self->getfield($field) =~ /^\s*(\d+)\s*$/
2024     or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2025   $self->setfield($field,$1);
2026   '';
2027 }
2028
2029 =item ut_numbern COLUMN
2030
2031 Check/untaint simple numeric data (whole numbers).  May be null.  If there is
2032 an error, returns the error, otherwise returns false.
2033
2034 =cut
2035
2036 sub ut_numbern {
2037   my($self,$field)=@_;
2038   $self->getfield($field) =~ /^\s*(\d*)\s*$/
2039     or return "Illegal (numeric) $field: ". $self->getfield($field);
2040   $self->setfield($field,$1);
2041   '';
2042 }
2043
2044 =item ut_money COLUMN
2045
2046 Check/untaint monetary numbers.  May be negative.  Set to 0 if null.  If there
2047 is an error, returns the error, otherwise returns false.
2048
2049 =cut
2050
2051 sub ut_money {
2052   my($self,$field)=@_;
2053   $self->setfield($field, 0) if $self->getfield($field) eq '';
2054   $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/
2055     or return "Illegal (money) $field: ". $self->getfield($field);
2056   #$self->setfield($field, "$1$2$3" || 0);
2057   $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2058   '';
2059 }
2060
2061 =item ut_moneyn COLUMN
2062
2063 Check/untaint monetary numbers.  May be negative.  If there
2064 is an error, returns the error, otherwise returns false.
2065
2066 =cut
2067
2068 sub ut_moneyn {
2069   my($self,$field)=@_;
2070   if ($self->getfield($field) eq '') {
2071     $self->setfield($field, '');
2072     return '';
2073   }
2074   $self->ut_money($field);
2075 }
2076
2077 =item ut_text COLUMN
2078
2079 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2080 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2081 May not be null.  If there is an error, returns the error, otherwise returns
2082 false.
2083
2084 =cut
2085
2086 sub ut_text {
2087   my($self,$field)=@_;
2088   #warn "msgcat ". \&msgcat. "\n";
2089   #warn "notexist ". \&notexist. "\n";
2090   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2091   $self->getfield($field)
2092     =~ /^([\wô \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
2093       or return gettext('illegal_or_empty_text'). " $field: ".
2094                  $self->getfield($field);
2095   $self->setfield($field,$1);
2096   '';
2097 }
2098
2099 =item ut_textn COLUMN
2100
2101 Check/untaint text.  Alphanumerics, spaces, and the following punctuation
2102 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2103 May be null.  If there is an error, returns the error, otherwise returns false.
2104
2105 =cut
2106
2107 sub ut_textn {
2108   my($self,$field)=@_;
2109   return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2110   $self->ut_text($field);
2111 }
2112
2113 =item ut_alpha COLUMN
2114
2115 Check/untaint alphanumeric strings (no spaces).  May not be null.  If there is
2116 an error, returns the error, otherwise returns false.
2117
2118 =cut
2119
2120 sub ut_alpha {
2121   my($self,$field)=@_;
2122   $self->getfield($field) =~ /^(\w+)$/
2123     or return "Illegal or empty (alphanumeric) $field: ".
2124               $self->getfield($field);
2125   $self->setfield($field,$1);
2126   '';
2127 }
2128
2129 =item ut_alphan COLUMN
2130
2131 Check/untaint alphanumeric strings (no spaces).  May be null.  If there is an
2132 error, returns the error, otherwise returns false.
2133
2134 =cut
2135
2136 sub ut_alphan {
2137   my($self,$field)=@_;
2138   $self->getfield($field) =~ /^(\w*)$/
2139     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2140   $self->setfield($field,$1);
2141   '';
2142 }
2143
2144 =item ut_alphasn COLUMN
2145
2146 Check/untaint alphanumeric strings, spaces allowed.  May be null.  If there is
2147 an error, returns the error, otherwise returns false.
2148
2149 =cut
2150
2151 sub ut_alphasn {
2152   my($self,$field)=@_;
2153   $self->getfield($field) =~ /^([\w ]*)$/
2154     or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2155   $self->setfield($field,$1);
2156   '';
2157 }
2158
2159
2160 =item ut_alpha_lower COLUMN
2161
2162 Check/untaint lowercase alphanumeric strings (no spaces).  May not be null.  If
2163 there is an error, returns the error, otherwise returns false.
2164
2165 =cut
2166
2167 sub ut_alpha_lower {
2168   my($self,$field)=@_;
2169   $self->getfield($field) =~ /[[:upper:]]/
2170     and return "Uppercase characters are not permitted in $field";
2171   $self->ut_alpha($field);
2172 }
2173
2174 =item ut_phonen COLUMN [ COUNTRY ]
2175
2176 Check/untaint phone numbers.  May be null.  If there is an error, returns
2177 the error, otherwise returns false.
2178
2179 Takes an optional two-letter ISO country code; without it or with unsupported
2180 countries, ut_phonen simply calls ut_alphan.
2181
2182 =cut
2183
2184 sub ut_phonen {
2185   my( $self, $field, $country ) = @_;
2186   return $self->ut_alphan($field) unless defined $country;
2187   my $phonen = $self->getfield($field);
2188   if ( $phonen eq '' ) {
2189     $self->setfield($field,'');
2190   } elsif ( $country eq 'US' || $country eq 'CA' ) {
2191     $phonen =~ s/\D//g;
2192     $phonen = $conf->config('cust_main-default_areacode').$phonen
2193       if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2194     $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2195       or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2196     $phonen = "$1-$2-$3";
2197     $phonen .= " x$4" if $4;
2198     $self->setfield($field,$phonen);
2199   } else {
2200     warn "warning: don't know how to check phone numbers for country $country";
2201     return $self->ut_textn($field);
2202   }
2203   '';
2204 }
2205
2206 =item ut_hex COLUMN
2207
2208 Check/untaint hexadecimal values.
2209
2210 =cut
2211
2212 sub ut_hex {
2213   my($self, $field) = @_;
2214   $self->getfield($field) =~ /^([\da-fA-F]+)$/
2215     or return "Illegal (hex) $field: ". $self->getfield($field);
2216   $self->setfield($field, uc($1));
2217   '';
2218 }
2219
2220 =item ut_hexn COLUMN
2221
2222 Check/untaint hexadecimal values.  May be null.
2223
2224 =cut
2225
2226 sub ut_hexn {
2227   my($self, $field) = @_;
2228   $self->getfield($field) =~ /^([\da-fA-F]*)$/
2229     or return "Illegal (hex) $field: ". $self->getfield($field);
2230   $self->setfield($field, uc($1));
2231   '';
2232 }
2233
2234 =item ut_mac_addr COLUMN
2235
2236 Check/untaint mac addresses.  May be null.
2237
2238 =cut
2239
2240 sub ut_mac_addr {
2241   my($self, $field) = @_;
2242
2243   my $mac = $self->get($field);
2244   $mac =~ s/\s+//g;
2245   $mac =~ s/://g;
2246   $self->set($field, $mac);
2247
2248   my $e = $self->ut_hex($field);
2249   return $e if $e;
2250
2251   return "Illegal (mac address) $field: ". $self->getfield($field)
2252     unless length($self->getfield($field)) == 12;
2253
2254   '';
2255
2256 }
2257
2258 =item ut_mac_addrn COLUMN
2259
2260 Check/untaint mac addresses.  May be null.
2261
2262 =cut
2263
2264 sub ut_mac_addrn {
2265   my($self, $field) = @_;
2266   ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2267 }
2268
2269 =item ut_ip COLUMN
2270
2271 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2272 to 127.0.0.1.
2273
2274 =cut
2275
2276 sub ut_ip {
2277   my( $self, $field ) = @_;
2278   $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2279   $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2280     or return "Illegal (IP address) $field: ". $self->getfield($field);
2281   for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2282   $self->setfield($field, "$1.$2.$3.$4");
2283   '';
2284 }
2285
2286 =item ut_ipn COLUMN
2287
2288 Check/untaint ip addresses.  IPv4 only for now, though ::1 is auto-translated
2289 to 127.0.0.1.  May be null.
2290
2291 =cut
2292
2293 sub ut_ipn {
2294   my( $self, $field ) = @_;
2295   if ( $self->getfield($field) =~ /^()$/ ) {
2296     $self->setfield($field,'');
2297     '';
2298   } else {
2299     $self->ut_ip($field);
2300   }
2301 }
2302
2303 =item ut_ip46 COLUMN
2304
2305 Check/untaint IPv4 or IPv6 address.
2306
2307 =cut
2308
2309 sub ut_ip46 {
2310   my( $self, $field ) = @_;
2311   my $ip = NetAddr::IP->new($self->getfield($field))
2312     or return "Illegal (IP address) $field: ".$self->getfield($field);
2313   $self->setfield($field, lc($ip->addr));
2314   return '';
2315 }
2316
2317 =item ut_ip46n
2318
2319 Check/untaint IPv6 or IPv6 address.  May be null.
2320
2321 =cut
2322
2323 sub ut_ip46n {
2324   my( $self, $field ) = @_;
2325   if ( $self->getfield($field) =~ /^$/ ) {
2326     $self->setfield($field, '');
2327     return '';
2328   }
2329   $self->ut_ip46($field);
2330 }
2331
2332 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2333
2334 Check/untaint coordinates.
2335 Accepts the following forms:
2336 DDD.DDDDD
2337 -DDD.DDDDD
2338 DDD MM.MMM
2339 -DDD MM.MMM
2340 DDD MM SS
2341 -DDD MM SS
2342 DDD MM MMM
2343 -DDD MM MMM
2344
2345 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2346 The latter form (that is, the MMM are thousands of minutes) is
2347 assumed if the "MMM" is exactly three digits or two digits > 59.
2348
2349 To be safe, just use the DDD.DDDDD form.
2350
2351 If LOWER or UPPER are specified, then the coordinate is checked
2352 for lower and upper bounds, respectively.
2353
2354 =cut
2355
2356 sub ut_coord {
2357   my ($self, $field) = (shift, shift);
2358
2359   my($lower, $upper);
2360   if ( $field =~ /latitude/ ) {
2361     $lower = $lat_lower;
2362     $upper = 90;
2363   } elsif ( $field =~ /longitude/ ) {
2364     $lower = -180;
2365     $upper = $lon_upper;
2366   }
2367
2368   my $coord = $self->getfield($field);
2369   my $neg = $coord =~ s/^(-)//;
2370
2371   my ($d, $m, $s) = (0, 0, 0);
2372
2373   if (
2374     (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2375     (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2376     (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2377   ) {
2378     $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2379     $m = $m / 60;
2380     if ($m > 59) {
2381       return "Invalid (coordinate with minutes > 59) $field: "
2382              . $self->getfield($field);
2383     }
2384
2385     $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2386
2387     if (defined($lower) and ($coord < $lower)) {
2388       return "Invalid (coordinate < $lower) $field: "
2389              . $self->getfield($field);;
2390     }
2391
2392     if (defined($upper) and ($coord > $upper)) {
2393       return "Invalid (coordinate > $upper) $field: "
2394              . $self->getfield($field);;
2395     }
2396
2397     $self->setfield($field, $coord);
2398     return '';
2399   }
2400
2401   return "Invalid (coordinate) $field: " . $self->getfield($field);
2402
2403 }
2404
2405 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2406
2407 Same as ut_coord, except optionally null.
2408
2409 =cut
2410
2411 sub ut_coordn {
2412
2413   my ($self, $field) = (shift, shift);
2414
2415   if ($self->getfield($field) =~ /^\s*$/) {
2416     return '';
2417   } else {
2418     return $self->ut_coord($field, @_);
2419   }
2420
2421 }
2422
2423
2424 =item ut_domain COLUMN
2425
2426 Check/untaint host and domain names.
2427
2428 =cut
2429
2430 sub ut_domain {
2431   my( $self, $field ) = @_;
2432   #$self->getfield($field) =~/^(\w+\.)*\w+$/
2433   $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2434     or return "Illegal (domain) $field: ". $self->getfield($field);
2435   $self->setfield($field,$1);
2436   '';
2437 }
2438
2439 =item ut_name COLUMN
2440
2441 Check/untaint proper names; allows alphanumerics, spaces and the following
2442 punctuation: , . - '
2443
2444 May not be null.
2445
2446 =cut
2447
2448 sub ut_name {
2449   my( $self, $field ) = @_;
2450 #  warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
2451   $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
2452     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2453   $self->setfield($field,$1);
2454   '';
2455 }
2456
2457 =item ut_zip COLUMN
2458
2459 Check/untaint zip codes.
2460
2461 =cut
2462
2463 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2464
2465 sub ut_zip {
2466   my( $self, $field, $country ) = @_;
2467
2468   if ( $country eq 'US' ) {
2469
2470     $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2471       or return gettext('illegal_zip'). " $field for country $country: ".
2472                 $self->getfield($field);
2473     $self->setfield($field, $1);
2474
2475   } elsif ( $country eq 'CA' ) {
2476
2477     $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2478       or return gettext('illegal_zip'). " $field for country $country: ".
2479                 $self->getfield($field);
2480     $self->setfield($field, "$1 $2");
2481
2482   } else {
2483
2484     if ( $self->getfield($field) =~ /^\s*$/
2485          && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2486        )
2487     {
2488       $self->setfield($field,'');
2489     } else {
2490       $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
2491         or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2492       $self->setfield($field,$1);
2493     }
2494
2495   }
2496
2497   '';
2498 }
2499
2500 =item ut_country COLUMN
2501
2502 Check/untaint country codes.  Country names are changed to codes, if possible -
2503 see L<Locale::Country>.
2504
2505 =cut
2506
2507 sub ut_country {
2508   my( $self, $field ) = @_;
2509   unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2510     if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2511          && country2code($1) ) {
2512       $self->setfield($field,uc(country2code($1)));
2513     }
2514   }
2515   $self->getfield($field) =~ /^(\w\w)$/
2516     or return "Illegal (country) $field: ". $self->getfield($field);
2517   $self->setfield($field,uc($1));
2518   '';
2519 }
2520
2521 =item ut_anything COLUMN
2522
2523 Untaints arbitrary data.  Be careful.
2524
2525 =cut
2526
2527 sub ut_anything {
2528   my( $self, $field ) = @_;
2529   $self->getfield($field) =~ /^(.*)$/s
2530     or return "Illegal $field: ". $self->getfield($field);
2531   $self->setfield($field,$1);
2532   '';
2533 }
2534
2535 =item ut_enum COLUMN CHOICES_ARRAYREF
2536
2537 Check/untaint a column, supplying all possible choices, like the "enum" type.
2538
2539 =cut
2540
2541 sub ut_enum {
2542   my( $self, $field, $choices ) = @_;
2543   foreach my $choice ( @$choices ) {
2544     if ( $self->getfield($field) eq $choice ) {
2545       $self->setfield($field, $choice);
2546       return '';
2547     }
2548   }
2549   return "Illegal (enum) field $field: ". $self->getfield($field);
2550 }
2551
2552 =item ut_enumn COLUMN CHOICES_ARRAYREF
2553
2554 Like ut_enum, except the null value is also allowed.
2555
2556 =cut
2557
2558 sub ut_enumn {
2559   my( $self, $field, $choices ) = @_;
2560   $self->getfield($field)
2561     ? $self->ut_enum($field, $choices)
2562     : '';
2563 }
2564
2565
2566 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2567
2568 Check/untaint a foreign column key.  Call a regular ut_ method (like ut_number)
2569 on the column first.
2570
2571 =cut
2572
2573 sub ut_foreign_key {
2574   my( $self, $field, $table, $foreign ) = @_;
2575   return '' if $no_check_foreign;
2576   qsearchs($table, { $foreign => $self->getfield($field) })
2577     or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
2578               " in $table.$foreign";
2579   '';
2580 }
2581
2582 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2583
2584 Like ut_foreign_key, except the null value is also allowed.
2585
2586 =cut
2587
2588 sub ut_foreign_keyn {
2589   my( $self, $field, $table, $foreign ) = @_;
2590   $self->getfield($field)
2591     ? $self->ut_foreign_key($field, $table, $foreign)
2592     : '';
2593 }
2594
2595 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
2596
2597 Checks this column as an agentnum, taking into account the current users's
2598 ACLs.  NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
2599 right or rights allowing no agentnum.
2600
2601 =cut
2602
2603 sub ut_agentnum_acl {
2604   my( $self, $field ) = (shift, shift);
2605   my $null_acl = scalar(@_) ? shift : [];
2606   $null_acl = [ $null_acl ] unless ref($null_acl);
2607
2608   my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
2609   return "Illegal agentnum: $error" if $error;
2610
2611   my $curuser = $FS::CurrentUser::CurrentUser;
2612
2613   if ( $self->$field() ) {
2614
2615     return "Access denied"
2616       unless $curuser->agentnum($self->$field());
2617
2618   } else {
2619
2620     return "Access denied"
2621       unless grep $curuser->access_right($_), @$null_acl;
2622
2623   }
2624
2625   '';
2626
2627 }
2628
2629 =item fields [ TABLE ]
2630
2631 This is a wrapper for real_fields.  Code that called
2632 fields before should probably continue to call fields.
2633
2634 =cut
2635
2636 sub fields {
2637   my $something = shift;
2638   my $table;
2639   if($something->isa('FS::Record')) {
2640     $table = $something->table;
2641   } else {
2642     $table = $something;
2643     $something = "FS::$table";
2644   }
2645   return (real_fields($table));
2646 }
2647
2648
2649 =item encrypt($value)
2650
2651 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2652
2653 Returns the encrypted string.
2654
2655 You should generally not have to worry about calling this, as the system handles this for you.
2656
2657 =cut
2658
2659 sub encrypt {
2660   my ($self, $value) = @_;
2661   my $encrypted;
2662
2663   if ($conf->exists('encryption')) {
2664     if ($self->is_encrypted($value)) {
2665       # Return the original value if it isn't plaintext.
2666       $encrypted = $value;
2667     } else {
2668       $self->loadRSA;
2669       if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2670         # RSA doesn't like the empty string so let's pack it up
2671         # The database doesn't like the RSA data so uuencode it
2672         my $length = length($value)+1;
2673         $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2674       } else {
2675         die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2676       }
2677     }
2678   }
2679   return $encrypted;
2680 }
2681
2682 =item is_encrypted($value)
2683
2684 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2685
2686 =cut
2687
2688
2689 sub is_encrypted {
2690   my ($self, $value) = @_;
2691   # Possible Bug - Some work may be required here....
2692
2693   if ($value =~ /^M/ && length($value) > 80) {
2694     return 1;
2695   } else {
2696     return 0;
2697   }
2698 }
2699
2700 =item decrypt($value)
2701
2702 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2703
2704 You should generally not have to worry about calling this, as the system handles this for you.
2705
2706 =cut
2707
2708 sub decrypt {
2709   my ($self,$value) = @_;
2710   my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2711   if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2712     $self->loadRSA;
2713     if (ref($rsa_decrypt) =~ /::RSA/) {
2714       my $encrypted = unpack ("u*", $value);
2715       $decrypted =  unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2716       if ($@) {warn "Decryption Failed"};
2717     }
2718   }
2719   return $decrypted;
2720 }
2721
2722 sub loadRSA {
2723     my $self = shift;
2724     #Initialize the Module
2725     $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2726
2727     if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
2728       $rsa_module = $conf->config('encryptionmodule');
2729     }
2730
2731     if (!$rsa_loaded) {
2732         eval ("require $rsa_module"); # No need to import the namespace
2733         $rsa_loaded++;
2734     }
2735     # Initialize Encryption
2736     if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
2737       my $public_key = join("\n",$conf->config('encryptionpublickey'));
2738       $rsa_encrypt = $rsa_module->new_public_key($public_key);
2739     }
2740
2741     # Intitalize Decryption
2742     if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
2743       my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2744       $rsa_decrypt = $rsa_module->new_private_key($private_key);
2745     }
2746 }
2747
2748 =item h_search ACTION
2749
2750 Given an ACTION, either "insert", or "delete", returns the appropriate history
2751 record corresponding to this record, if any.
2752
2753 =cut
2754
2755 sub h_search {
2756   my( $self, $action ) = @_;
2757
2758   my $table = $self->table;
2759   $table =~ s/^h_//;
2760
2761   my $primary_key = dbdef->table($table)->primary_key;
2762
2763   qsearchs({
2764     'table'   => "h_$table",
2765     'hashref' => { $primary_key     => $self->$primary_key(),
2766                    'history_action' => $action,
2767                  },
2768   });
2769
2770 }
2771
2772 =item h_date ACTION
2773
2774 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2775 appropriate history record corresponding to this record, if any.
2776
2777 =cut
2778
2779 sub h_date {
2780   my($self, $action) = @_;
2781   my $h = $self->h_search($action);
2782   $h ? $h->history_date : '';
2783 }
2784
2785 =item scalar_sql SQL [ PLACEHOLDER, ... ]
2786
2787 A class or object method.  Executes the sql statement represented by SQL and
2788 returns a scalar representing the result: the first column of the first row.
2789
2790 Dies on bogus SQL.  Returns an empty string if no row is returned.
2791
2792 Typically used for statments which return a single value such as "SELECT
2793 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
2794
2795 =cut
2796
2797 sub scalar_sql {
2798   my($self, $sql) = (shift, shift);
2799   my $sth = dbh->prepare($sql) or die dbh->errstr;
2800   $sth->execute(@_)
2801     or die "Unexpected error executing statement $sql: ". $sth->errstr;
2802   my $row = $sth->fetchrow_arrayref or return '';
2803   my $scalar = $row->[0];
2804   defined($scalar) ? $scalar : '';
2805 }
2806
2807 =item count [ WHERE ]
2808
2809 Convenience method for the common case of "SELECT COUNT(*) FROM table",
2810 with optional WHERE.  Must be called as method on a class with an
2811 associated table.
2812
2813 =cut
2814
2815 sub count {
2816   my($self, $where) = (shift, shift);
2817   my $table = $self->table or die 'count called on object of class '.ref($self);
2818   my $sql = "SELECT COUNT(*) FROM $table";
2819   $sql .= " WHERE $where" if $where;
2820   $self->scalar_sql($sql);
2821 }
2822
2823 =back
2824
2825 =head1 SUBROUTINES
2826
2827 =over 4
2828
2829 =item real_fields [ TABLE ]
2830
2831 Returns a list of the real columns in the specified table.  Called only by
2832 fields() and other subroutines elsewhere in FS::Record.
2833
2834 =cut
2835
2836 sub real_fields {
2837   my $table = shift;
2838
2839   my($table_obj) = dbdef->table($table);
2840   confess "Unknown table $table" unless $table_obj;
2841   $table_obj->columns;
2842 }
2843
2844 =item pvf FIELD_NAME
2845
2846 Returns the FS::part_virtual_field object corresponding to a field in the
2847 record (specified by FIELD_NAME).
2848
2849 =cut
2850
2851 sub pvf {
2852   my ($self, $name) = (shift, shift);
2853
2854   if(grep /^$name$/, $self->virtual_fields) {
2855     $name =~ s/^cf_//;
2856     my $concat = [ "'cf_'", "name" ];
2857     return qsearchs({   table   =>  'part_virtual_field',
2858                         hashref =>  { dbtable => $self->table,
2859                                       name    => $name
2860                                     },
2861                         select  =>  'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
2862                     });
2863   }
2864   ''
2865 }
2866
2867 =item _quote VALUE, TABLE, COLUMN
2868
2869 This is an internal function used to construct SQL statements.  It returns
2870 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2871 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2872
2873 =cut
2874
2875 sub _quote {
2876   my($value, $table, $column) = @_;
2877   my $column_obj = dbdef->table($table)->column($column);
2878   my $column_type = $column_obj->type;
2879   my $nullable = $column_obj->null;
2880
2881   warn "  $table.$column: $value ($column_type".
2882        ( $nullable ? ' NULL' : ' NOT NULL' ).
2883        ")\n" if $DEBUG > 2;
2884
2885   if ( $value eq '' && $nullable ) {
2886     'NULL';
2887   } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2888     cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2889           "using 0 instead";
2890     0;
2891   } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2892             ! $column_type =~ /(char|binary|text)$/i ) {
2893     $value;
2894   } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
2895            && driver_name eq 'Pg'
2896           )
2897   {
2898     no strict 'subs';
2899 #    dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right
2900     # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\,
2901     # single-quote the whole mess, and put an "E" in front.
2902     return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'");
2903   } else {
2904     dbh->quote($value);
2905   }
2906 }
2907
2908 =item hfields TABLE
2909
2910 This is deprecated.  Don't use it.
2911
2912 It returns a hash-type list with the fields of this record's table set true.
2913
2914 =cut
2915
2916 sub hfields {
2917   carp "warning: hfields is deprecated";
2918   my($table)=@_;
2919   my(%hash);
2920   foreach (fields($table)) {
2921     $hash{$_}=1;
2922   }
2923   \%hash;
2924 }
2925
2926 sub _dump {
2927   my($self)=@_;
2928   join("\n", map {
2929     "$_: ". $self->getfield($_). "|"
2930   } (fields($self->table)) );
2931 }
2932
2933 sub DESTROY { return; }
2934
2935 #sub DESTROY {
2936 #  my $self = shift;
2937 #  #use Carp qw(cluck);
2938 #  #cluck "DESTROYING $self";
2939 #  warn "DESTROYING $self";
2940 #}
2941
2942 #sub is_tainted {
2943 #             return ! eval { join('',@_), kill 0; 1; };
2944 #         }
2945
2946 =item str2time_sql [ DRIVER_NAME ]
2947
2948 Returns a function to convert to unix time based on database type, such as
2949 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql.  See
2950 the str2time_sql_closing method to return a closing string rather than just
2951 using a closing parenthesis as previously suggested.
2952
2953 You can pass an optional driver name such as "Pg", "mysql" or
2954 $dbh->{Driver}->{Name} to return a function for that database instead of
2955 the current database.
2956
2957 =cut
2958
2959 sub str2time_sql {
2960   my $driver = shift || driver_name;
2961
2962   return 'UNIX_TIMESTAMP('      if $driver =~ /^mysql/i;
2963   return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
2964
2965   warn "warning: unknown database type $driver; guessing how to convert ".
2966        "dates to UNIX timestamps";
2967   return 'EXTRACT(EPOCH FROM ';
2968
2969 }
2970
2971 =item str2time_sql_closing [ DRIVER_NAME ]
2972
2973 Returns the closing suffix of a function to convert to unix time based on
2974 database type, such as ")::integer" for Pg or ")" for mysql.
2975
2976 You can pass an optional driver name such as "Pg", "mysql" or
2977 $dbh->{Driver}->{Name} to return a function for that database instead of
2978 the current database.
2979
2980 =cut
2981
2982 sub str2time_sql_closing {
2983   my $driver = shift || driver_name;
2984
2985   return ' )::INTEGER ' if $driver =~ /^Pg/i;
2986   return ' ) ';
2987 }
2988
2989 =item regexp_sql [ DRIVER_NAME ]
2990
2991 Returns the operator to do a regular expression comparison based on database
2992 type, such as '~' for Pg or 'REGEXP' for mysql.
2993
2994 You can pass an optional driver name such as "Pg", "mysql" or
2995 $dbh->{Driver}->{Name} to return a function for that database instead of
2996 the current database.
2997
2998 =cut
2999
3000 sub regexp_sql {
3001   my $driver = shift || driver_name;
3002
3003   return '~'      if $driver =~ /^Pg/i;
3004   return 'REGEXP' if $driver =~ /^mysql/i;
3005
3006   die "don't know how to use regular expressions in ". driver_name." databases";
3007
3008 }
3009
3010 =item not_regexp_sql [ DRIVER_NAME ]
3011
3012 Returns the operator to do a regular expression negation based on database
3013 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3014
3015 You can pass an optional driver name such as "Pg", "mysql" or
3016 $dbh->{Driver}->{Name} to return a function for that database instead of
3017 the current database.
3018
3019 =cut
3020
3021 sub not_regexp_sql {
3022   my $driver = shift || driver_name;
3023
3024   return '!~'         if $driver =~ /^Pg/i;
3025   return 'NOT REGEXP' if $driver =~ /^mysql/i;
3026
3027   die "don't know how to use regular expressions in ". driver_name." databases";
3028
3029 }
3030
3031 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3032
3033 Returns the items concatendated based on database type, using "CONCAT()" for
3034 mysql and " || " for Pg and other databases.
3035
3036 You can pass an optional driver name such as "Pg", "mysql" or
3037 $dbh->{Driver}->{Name} to return a function for that database instead of
3038 the current database.
3039
3040 =cut
3041
3042 sub concat_sql {
3043   my $driver = ref($_[0]) ? driver_name : shift;
3044   my $items = shift;
3045
3046   if ( $driver =~ /^mysql/i ) {
3047     'CONCAT('. join(',', @$items). ')';
3048   } else {
3049     join('||', @$items);
3050   }
3051
3052 }
3053
3054 =back
3055
3056 =head1 BUGS
3057
3058 This module should probably be renamed, since much of the functionality is
3059 of general use.  It is not completely unlike Adapter::DBI (see below).
3060
3061 Exported qsearch and qsearchs should be deprecated in favor of method calls
3062 (against an FS::Record object like the old search and searchs that qsearch
3063 and qsearchs were on top of.)
3064
3065 The whole fields / hfields mess should be removed.
3066
3067 The various WHERE clauses should be subroutined.
3068
3069 table string should be deprecated in favor of DBIx::DBSchema::Table.
3070
3071 No doubt we could benefit from a Tied hash.  Documenting how exists / defined
3072 true maps to the database (and WHERE clauses) would also help.
3073
3074 The ut_ methods should ask the dbdef for a default length.
3075
3076 ut_sqltype (like ut_varchar) should all be defined
3077
3078 A fallback check method should be provided which uses the dbdef.
3079
3080 The ut_money method assumes money has two decimal digits.
3081
3082 The Pg money kludge in the new method only strips `$'.
3083
3084 The ut_phonen method only checks US-style phone numbers.
3085
3086 The _quote function should probably use ut_float instead of a regex.
3087
3088 All the subroutines probably should be methods, here or elsewhere.
3089
3090 Probably should borrow/use some dbdef methods where appropriate (like sub
3091 fields)
3092
3093 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3094 or allow it to be set.  Working around it is ugly any way around - DBI should
3095 be fixed.  (only affects RDBMS which return uppercase column names)
3096
3097 ut_zip should take an optional country like ut_phone.
3098
3099 =head1 SEE ALSO
3100
3101 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3102
3103 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
3104
3105 http://poop.sf.net/
3106
3107 =cut
3108
3109 1;
3110