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