4 use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG
5 $conf $conf_encryption $me
7 $nowarn_identical $nowarn_classload
8 $no_update_diff $no_check_foreign
11 use Carp qw(carp cluck croak confess);
12 use Scalar::Util qw( blessed );
13 use File::CounterFile;
16 use File::Slurp qw( slurp );
17 use DBI qw(:sql_types);
18 use DBIx::DBSchema 0.33;
19 use FS::UID qw(dbh getotaker datasrc driver_name);
21 use FS::Schema qw(dbdef);
23 use FS::Msgcat qw(gettext);
24 #use FS::Conf; #dependency loop bs, in install_callback below instead
26 use FS::part_virtual_field;
32 #export dbdef for now... everything else expects to find it here
33 @EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch
34 str2time_sql str2time_sql_closing );
39 $nowarn_identical = 0;
42 $no_check_foreign = 0;
50 $conf_encryption = '';
51 FS::UID->install_callback( sub {
54 $conf = FS::Conf->new;
55 $conf_encryption = $conf->exists('encryption');
56 $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
62 FS::Record - Database record objects
67 use FS::Record qw(dbh fields qsearch qsearchs);
69 $record = new FS::Record 'table', \%hash;
70 $record = new FS::Record 'table', { 'column' => 'value', ... };
72 $record = qsearchs FS::Record 'table', \%hash;
73 $record = qsearchs FS::Record 'table', { 'column' => 'value', ... };
74 @records = qsearch FS::Record 'table', \%hash;
75 @records = qsearch FS::Record 'table', { 'column' => 'value', ... };
77 $table = $record->table;
78 $dbdef_table = $record->dbdef_table;
80 $value = $record->get('column');
81 $value = $record->getfield('column');
82 $value = $record->column;
84 $record->set( 'column' => 'value' );
85 $record->setfield( 'column' => 'value' );
86 $record->column('value');
88 %hash = $record->hash;
90 $hashref = $record->hashref;
92 $error = $record->insert;
94 $error = $record->delete;
96 $error = $new_record->replace($old_record);
98 # external use deprecated - handled by the database (at least for Pg, mysql)
99 $value = $record->unique('column');
101 $error = $record->ut_float('column');
102 $error = $record->ut_floatn('column');
103 $error = $record->ut_number('column');
104 $error = $record->ut_numbern('column');
105 $error = $record->ut_snumber('column');
106 $error = $record->ut_snumbern('column');
107 $error = $record->ut_money('column');
108 $error = $record->ut_text('column');
109 $error = $record->ut_textn('column');
110 $error = $record->ut_alpha('column');
111 $error = $record->ut_alphan('column');
112 $error = $record->ut_phonen('column');
113 $error = $record->ut_anything('column');
114 $error = $record->ut_name('column');
116 $quoted_value = _quote($value,'table','field');
119 $fields = hfields('table');
120 if ( $fields->{Field} ) { # etc.
122 @fields = fields 'table'; #as a subroutine
123 @fields = $record->fields; #as a method call
128 (Mostly) object-oriented interface to database records. Records are currently
129 implemented on top of DBI. FS::Record is intended as a base class for
130 table-specific classes to inherit from, i.e. FS::cust_main.
136 =item new [ TABLE, ] HASHREF
138 Creates a new record. It doesn't store it in the database, though. See
139 L<"insert"> for that.
141 Note that the object stores this hash reference, not a distinct copy of the
142 hash it points to. You can ask the object for a copy with the I<hash>
145 TABLE can only be omitted when a dervived class overrides the table method.
151 my $class = ref($proto) || $proto;
153 bless ($self, $class);
155 unless ( defined ( $self->table ) ) {
156 $self->{'Table'} = shift;
157 carp "warning: FS::Record::new called with table name ". $self->{'Table'};
160 $self->{'Hash'} = shift;
162 foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
163 $self->{'Hash'}{$field}='';
166 $self->_rebless if $self->can('_rebless');
168 $self->{'modified'} = 0;
170 $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
177 my $class = ref($proto) || $proto;
179 bless ($self, $class);
181 $self->{'Table'} = shift unless defined ( $self->table );
183 my $hashref = $self->{'Hash'} = shift;
185 if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
186 my $obj = $cache->cache->{$hashref->{$cache->key}};
187 $obj->_cache($hashref, $cache) if $obj->can('_cache');
190 $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
197 my $class = ref($proto) || $proto;
199 bless ($self, $class);
200 if ( defined $self->table ) {
201 cluck "create constructor is deprecated, use new!";
204 croak "FS::Record::create called (not from a subclass)!";
208 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
210 Searches the database for all records matching (at least) the key/value pairs
211 in HASHREF. Returns all the records found as `FS::TABLE' objects if that
212 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
215 The preferred usage is to pass a hash reference of named parameters:
217 my @records = qsearch( {
218 'table' => 'table_name',
219 'hashref' => { 'field' => 'value'
220 'field' => { 'op' => '<',
225 #these are optional...
227 'extra_sql' => 'AND field ',
228 'order_by' => 'ORDER BY something',
229 #'cache_obj' => '', #optional
230 'addl_from' => 'LEFT JOIN othtable USING ( field )',
235 Much code still uses old-style positional parameters, this is also probably
236 fine in the common case where there are only two parameters:
238 my @records = qsearch( 'table', { 'field' => 'value' } );
240 ###oops, argh, FS::Record::new only lets us create database fields.
241 #Normal behaviour if SELECT is not specified is `*', as in
242 #C<SELECT * FROM table WHERE ...>. However, there is an experimental new
243 #feature where you can specify SELECT - remember, the objects returned,
244 #although blessed into the appropriate `FS::TABLE' package, will only have the
245 #fields you specify. This might have unwanted results if you then go calling
246 #regular FS::TABLE methods
251 my %TYPE = (); #for debugging
254 my ($type, $value) = @_;
255 if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) ||
256 ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/)
264 my($stable, $record, $select, $extra_sql, $order_by, $cache, $addl_from );
266 if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too
268 $stable = $opt->{'table'} or die "table name is required";
269 $record = $opt->{'hashref'} || {};
270 $select = $opt->{'select'} || '*';
271 $extra_sql = $opt->{'extra_sql'} || '';
272 $order_by = $opt->{'order_by'} || '';
273 $cache = $opt->{'cache_obj'} || '';
274 $addl_from = $opt->{'addl_from'} || '';
275 $debug = $opt->{'debug'} || '';
277 ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_;
281 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
283 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
287 my $table = $cache ? $cache->table : $stable;
288 my $dbdef_table = dbdef->table($table)
289 or die "No schema for table $table found - ".
290 "do you need to run freeside-upgrade?";
291 my $pkey = $dbdef_table->primary_key;
293 my @real_fields = grep exists($record->{$_}), real_fields($table);
295 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
296 @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
298 cluck "warning: FS::$table not loaded; virtual fields not searchable"
299 unless $nowarn_classload;
300 @virtual_fields = ();
303 my $statement = "SELECT $select FROM $stable";
304 $statement .= " $addl_from" if $addl_from;
305 if ( @real_fields or @virtual_fields ) {
306 $statement .= ' WHERE '. join(' AND ',
307 get_real_fields($table, $record, \@real_fields) ,
308 get_virtual_fields($table, $pkey, $record, \@virtual_fields),
312 $statement .= " $extra_sql" if defined($extra_sql);
313 $statement .= " $order_by" if defined($order_by);
315 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
316 my $sth = $dbh->prepare($statement)
317 or croak "$dbh->errstr doing $statement";
322 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
325 my $value = $record->{$field};
326 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
327 $value = $value->{'value'} if ref($value);
328 my $type = dbdef->table($table)->column($field)->type;
330 my $TYPE = SQL_VARCHAR;
331 if ( $type =~ /(big)?(int|serial)/i && $value =~ /^\d+(\.\d+)?$/ ) {
334 #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT
335 #fixed by DBD::Pg 2.11.8
336 #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded
337 } elsif ( _is_fs_float( $type, $value ) ) {
343 %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
345 warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
348 #if this needs to be re-enabled, it needs to use a custom op like
349 #"APPROX=" or something (better name?, not '=', to avoid affecting other
351 #if ($TYPE eq SQL_DECIMAL && $op eq 'APPROX=' ) {
352 # # these values are arbitrary; better (faster?) ones welcome
353 # $sth->bind_param($bind++, $value*1.00001, { TYPE => $TYPE } );
354 # $sth->bind_param($bind++, $value*.99999, { TYPE => $TYPE } );
356 $sth->bind_param($bind++, $value, { TYPE => $TYPE } );
361 # $sth->execute( map $record->{$_},
362 # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
363 # ) or croak "Error executing \"$statement\": ". $sth->errstr;
365 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
367 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
368 @virtual_fields = "FS::$table"->virtual_fields;
370 cluck "warning: FS::$table not loaded; virtual fields not returned either"
371 unless $nowarn_classload;
372 @virtual_fields = ();
376 tie %result, "Tie::IxHash";
377 my @stuff = @{ $sth->fetchall_arrayref( {} ) };
378 if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
379 %result = map { $_->{$pkey}, $_ } @stuff;
381 @result{@stuff} = @stuff;
386 if ( keys(%result) and @virtual_fields ) {
388 "SELECT virtual_field.recnum, part_virtual_field.name, ".
389 "virtual_field.value ".
390 "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ".
391 "WHERE part_virtual_field.dbtable = '$table' AND ".
392 "virtual_field.recnum IN (".
393 join(',', keys(%result)). ") AND part_virtual_field.name IN ('".
394 join(q!', '!, @virtual_fields) . "')";
395 warn "[debug]$me $statement\n" if $DEBUG > 1;
396 $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement";
397 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
399 foreach (@{ $sth->fetchall_arrayref({}) }) {
400 my $recnum = $_->{recnum};
401 my $name = $_->{name};
402 my $value = $_->{value};
403 if (exists($result{$recnum})) {
404 $result{$recnum}->{$name} = $value;
409 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
410 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
411 #derivied class didn't override new method, so this optimization is safe
414 new_or_cached( "FS::$table", { %{$_} }, $cache )
418 new( "FS::$table", { %{$_} } )
422 #okay, its been tested
423 # warn "untested code (class FS::$table uses custom new method)";
425 eval 'FS::'. $table. '->new( { %{$_} } )';
429 # Check for encrypted fields and decrypt them.
430 ## only in the local copy, not the cached object
431 if ( $conf_encryption
432 && eval 'defined(@FS::'. $table . '::encrypted_fields)' ) {
433 foreach my $record (@return) {
434 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
435 # Set it directly... This may cause a problem in the future...
436 $record->setfield($field, $record->decrypt($record->getfield($field)));
441 cluck "warning: FS::$table not loaded; returning FS::Record objects";
443 FS::Record->new( $table, { %{$_} } );
449 ## makes this easier to read
451 sub get_virtual_fields {
455 my $virtual_fields = shift;
461 if ( ref($record->{$_}) ) {
462 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
463 if ( uc($op) eq 'ILIKE' ) {
465 $record->{$_}{'value'} = lc($record->{$_}{'value'});
466 $column = "LOWER($_)";
468 $record->{$_} = $record->{$_}{'value'};
471 # ... EXISTS ( SELECT name, value FROM part_virtual_field
473 # ON part_virtual_field.vfieldpart = virtual_field.vfieldpart
474 # WHERE recnum = svc_acct.svcnum
475 # AND (name, value) = ('egad', 'brain') )
477 my $value = $record->{$_};
481 $subq = ($value ? 'EXISTS ' : 'NOT EXISTS ') .
482 "( SELECT part_virtual_field.name, virtual_field.value ".
483 "FROM part_virtual_field JOIN virtual_field ".
484 "ON part_virtual_field.vfieldpart = virtual_field.vfieldpart ".
485 "WHERE virtual_field.recnum = ${table}.${pkey} ".
486 "AND part_virtual_field.name = '${column}'".
488 " AND virtual_field.value ${op} '${value}'"
492 } @{ $virtual_fields } ) ;
495 sub get_real_fields {
498 my $real_fields = shift;
500 ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability
506 my $type = dbdef->table($table)->column($column)->type;
507 my $value = $record->{$column};
508 $value = $value->{'value'} if ref($value);
509 if ( ref($record->{$_}) ) {
510 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
511 #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
512 if ( uc($op) eq 'ILIKE' ) {
514 $record->{$_}{'value'} = lc($record->{$_}{'value'});
515 $column = "LOWER($_)";
517 $record->{$_} = $record->{$_}{'value'}
520 if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
522 if ( driver_name eq 'Pg' ) {
523 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
524 qq-( $column IS NULL )-;
526 qq-( $column IS NULL OR $column = '' )-;
529 qq-( $column IS NULL OR $column = "" )-;
531 } elsif ( $op eq '!=' ) {
532 if ( driver_name eq 'Pg' ) {
533 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
534 qq-( $column IS NOT NULL )-;
536 qq-( $column IS NOT NULL AND $column != '' )-;
539 qq-( $column IS NOT NULL AND $column != "" )-;
542 if ( driver_name eq 'Pg' ) {
543 qq-( $column $op '' )-;
545 qq-( $column $op "" )-;
548 #if this needs to be re-enabled, it needs to use a custom op like
549 #"APPROX=" or something (better name?, not '=', to avoid affecting other
551 #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
552 # ( "$column <= ?", "$column >= ?" );
556 } @{ $real_fields } );
559 =item by_key PRIMARY_KEY_VALUE
561 This is a class method that returns the record with the given primary key
562 value. This method is only useful in FS::Record subclasses. For example:
564 my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
568 my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
573 my ($class, $pkey_value) = @_;
575 my $table = $class->table
576 or croak "No table for $class found";
578 my $dbdef_table = dbdef->table($table)
579 or die "No schema for table $table found - ".
580 "do you need to create it or run dbdef-create?";
581 my $pkey = $dbdef_table->primary_key
582 or die "No primary key for table $table";
584 return qsearchs($table, { $pkey => $pkey_value });
587 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
589 Experimental JOINed search method. Using this method, you can execute a
590 single SELECT spanning multiple tables, and cache the results for subsequent
591 method calls. Interface will almost definately change in an incompatible
599 my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
600 my $cache = FS::SearchCache->new( $ptable, $pkey );
603 grep { !$saw{$_->getfield($pkey)}++ }
604 qsearch($table, $record, $select, $extra_sql, $cache )
608 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
610 Same as qsearch, except that if more than one record matches, it B<carp>s but
611 returns the first. If this happens, you either made a logic error in asking
612 for a single item, or your data is corrupted.
616 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
618 my(@result) = qsearch(@_);
619 cluck "warning: Multiple records in scalar search ($table)"
620 if scalar(@result) > 1;
621 #should warn more vehemently if the search was on a primary key?
622 scalar(@result) ? ($result[0]) : ();
633 Returns the table name.
638 # cluck "warning: FS::Record::table deprecated; supply one in subclass!";
645 Returns the DBIx::DBSchema::Table object for the table.
651 my($table)=$self->table;
652 dbdef->table($table);
657 Returns the primary key for the table.
663 my $pkey = $self->dbdef_table->primary_key;
666 =item get, getfield COLUMN
668 Returns the value of the column/field/key COLUMN.
673 my($self,$field) = @_;
674 # to avoid "Use of unitialized value" errors
675 if ( defined ( $self->{Hash}->{$field} ) ) {
676 $self->{Hash}->{$field};
686 =item set, setfield COLUMN, VALUE
688 Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE.
693 my($self,$field,$value) = @_;
694 $self->{'modified'} = 1;
695 $self->{'Hash'}->{$field} = $value;
702 =item AUTLOADED METHODS
704 $record->column is a synonym for $record->get('column');
706 $record->column('value') is a synonym for $record->set('column','value');
713 my($field)=$AUTOLOAD;
715 if ( defined($value) ) {
716 confess "errant AUTOLOAD $field for $self (arg $value)"
717 unless blessed($self) && $self->can('setfield');
718 $self->setfield($field,$value);
720 confess "errant AUTOLOAD $field for $self (no args)"
721 unless blessed($self) && $self->can('getfield');
722 $self->getfield($field);
728 # my $field = $AUTOLOAD;
730 # if ( defined($_[1]) ) {
731 # $_[0]->setfield($field, $_[1]);
733 # $_[0]->getfield($field);
739 Returns a list of the column/value pairs, usually for assigning to a new hash.
741 To make a distinct duplicate of an FS::Record object, you can do:
743 $new = new FS::Record ( $old->table, { $old->hash } );
749 confess $self. ' -> hash: Hash attribute is undefined'
750 unless defined($self->{'Hash'});
751 %{ $self->{'Hash'} };
756 Returns a reference to the column/value hash. This may be deprecated in the
757 future; if there's a reason you can't just use the autoloaded or get/set
769 Returns true if any of this object's values have been modified with set (or via
770 an autoloaded method). Doesn't yet recognize when you retreive a hashref and
780 =item select_for_update
782 Selects this record with the SQL "FOR UPDATE" command. This can be useful as
787 sub select_for_update {
789 my $primary_key = $self->primary_key;
792 'table' => $self->table,
793 'hashref' => { $primary_key => $self->$primary_key() },
794 'extra_sql' => 'FOR UPDATE',
800 Locks this table with a database-driver specific lock method. This is used
801 as a mutex in order to do a duplicate search.
803 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
805 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
807 Errors are fatal; no useful return value.
809 Note: To use this method for new tables other than svc_acct and svc_phone,
810 edit freeside-upgrade and add those tables to the duplicate_lock list.
816 my $table = $self->table;
818 warn "$me locking $table table\n" if $DEBUG;
820 if ( driver_name =~ /^Pg/i ) {
822 dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
825 } elsif ( driver_name =~ /^mysql/i ) {
827 dbh->do("SELECT * FROM duplicate_lock
828 WHERE lockname = '$table'
830 ) or die dbh->errstr;
834 die "unknown database ". driver_name. "; don't know how to lock table";
838 warn "$me acquired $table table lock\n" if $DEBUG;
844 Inserts this record to the database. If there is an error, returns the error,
845 otherwise returns false.
853 warn "$self -> insert" if $DEBUG;
855 my $error = $self->check;
856 return $error if $error;
858 #single-field unique keys are given a value if false
859 #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
860 foreach ( $self->dbdef_table->unique_singles) {
861 $self->unique($_) unless $self->getfield($_);
864 #and also the primary key, if the database isn't going to
865 my $primary_key = $self->dbdef_table->primary_key;
867 if ( $primary_key ) {
868 my $col = $self->dbdef_table->column($primary_key);
871 uc($col->type) =~ /^(BIG)?SERIAL\d?/
872 || ( driver_name eq 'Pg'
873 && defined($col->default)
874 && $col->default =~ /^nextval\(/i
876 || ( driver_name eq 'mysql'
877 && defined($col->local)
878 && $col->local =~ /AUTO_INCREMENT/i
880 $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
883 my $table = $self->table;
885 # Encrypt before the database
886 if ( defined(eval '@FS::'. $table . '::encrypted_fields')
887 && scalar( eval '@FS::'. $table . '::encrypted_fields')
888 && $conf->exists('encryption')
890 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
891 $self->{'saved'} = $self->getfield($field);
892 $self->setfield($field, $self->encrypt($self->getfield($field)));
896 #false laziness w/delete
898 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
901 my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
904 my $statement = "INSERT INTO $table ";
905 if ( @real_fields ) {
908 join( ', ', @real_fields ).
910 join( ', ', @values ).
914 $statement .= 'DEFAULT VALUES';
916 warn "[debug]$me $statement\n" if $DEBUG > 1;
917 my $sth = dbh->prepare($statement) or return dbh->errstr;
919 local $SIG{HUP} = 'IGNORE';
920 local $SIG{INT} = 'IGNORE';
921 local $SIG{QUIT} = 'IGNORE';
922 local $SIG{TERM} = 'IGNORE';
923 local $SIG{TSTP} = 'IGNORE';
924 local $SIG{PIPE} = 'IGNORE';
926 $sth->execute or return $sth->errstr;
928 # get inserted id from the database, if applicable & needed
929 if ( $db_seq && ! $self->getfield($primary_key) ) {
930 warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
934 if ( driver_name eq 'Pg' ) {
936 #my $oid = $sth->{'pg_oid_status'};
937 #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
939 my $default = $self->dbdef_table->column($primary_key)->default;
940 unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
941 dbh->rollback if $FS::UID::AutoCommit;
942 return "can't parse $table.$primary_key default value".
943 " for sequence name: $default";
947 my $i_sql = "SELECT currval('$sequence')";
948 my $i_sth = dbh->prepare($i_sql) or do {
949 dbh->rollback if $FS::UID::AutoCommit;
952 $i_sth->execute() or do { #$i_sth->execute($oid)
953 dbh->rollback if $FS::UID::AutoCommit;
954 return $i_sth->errstr;
956 $insertid = $i_sth->fetchrow_arrayref->[0];
958 } elsif ( driver_name eq 'mysql' ) {
960 $insertid = dbh->{'mysql_insertid'};
961 # work around mysql_insertid being null some of the time, ala RT :/
962 unless ( $insertid ) {
963 warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
964 "using SELECT LAST_INSERT_ID();";
965 my $i_sql = "SELECT LAST_INSERT_ID()";
966 my $i_sth = dbh->prepare($i_sql) or do {
967 dbh->rollback if $FS::UID::AutoCommit;
970 $i_sth->execute or do {
971 dbh->rollback if $FS::UID::AutoCommit;
972 return $i_sth->errstr;
974 $insertid = $i_sth->fetchrow_arrayref->[0];
979 dbh->rollback if $FS::UID::AutoCommit;
980 return "don't know how to retreive inserted ids from ". driver_name.
981 ", try using counterfiles (maybe run dbdef-create?)";
985 $self->setfield($primary_key, $insertid);
990 grep defined($self->getfield($_)) && $self->getfield($_) ne "",
991 $self->virtual_fields;
992 if (@virtual_fields) {
993 my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
995 my $vfieldpart = $self->vfieldpart_hashref;
997 my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
1000 my $v_sth = dbh->prepare($v_statement) or do {
1001 dbh->rollback if $FS::UID::AutoCommit;
1005 foreach (keys(%v_values)) {
1006 $v_sth->execute($self->getfield($primary_key),
1010 dbh->rollback if $FS::UID::AutoCommit;
1011 return $v_sth->errstr;
1018 if ( defined dbdef->table('h_'. $table) ) {
1019 my $h_statement = $self->_h_statement('insert');
1020 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1021 $h_sth = dbh->prepare($h_statement) or do {
1022 dbh->rollback if $FS::UID::AutoCommit;
1028 $h_sth->execute or return $h_sth->errstr if $h_sth;
1030 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1032 # Now that it has been saved, reset the encrypted fields so that $new
1033 # can still be used.
1034 foreach my $field (keys %{$saved}) {
1035 $self->setfield($field, $saved->{$field});
1043 Depriciated (use insert instead).
1048 cluck "warning: FS::Record::add deprecated!";
1049 insert @_; #call method in this scope
1054 Delete this record from the database. If there is an error, returns the error,
1055 otherwise returns false.
1062 my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1064 $self->getfield($_) eq ''
1065 #? "( $_ IS NULL OR $_ = \"\" )"
1066 ? ( driver_name eq 'Pg'
1068 : "( $_ IS NULL OR $_ = \"\" )"
1070 : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1071 } ( $self->dbdef_table->primary_key )
1072 ? ( $self->dbdef_table->primary_key)
1073 : real_fields($self->table)
1075 warn "[debug]$me $statement\n" if $DEBUG > 1;
1076 my $sth = dbh->prepare($statement) or return dbh->errstr;
1079 if ( defined dbdef->table('h_'. $self->table) ) {
1080 my $h_statement = $self->_h_statement('delete');
1081 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1082 $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1087 my $primary_key = $self->dbdef_table->primary_key;
1090 my $vfp = $self->vfieldpart_hashref;
1091 foreach($self->virtual_fields) {
1092 next if $self->getfield($_) eq '';
1093 unless(@del_vfields) {
1094 my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
1095 $v_sth = dbh->prepare($st) or return dbh->errstr;
1097 push @del_vfields, $_;
1100 local $SIG{HUP} = 'IGNORE';
1101 local $SIG{INT} = 'IGNORE';
1102 local $SIG{QUIT} = 'IGNORE';
1103 local $SIG{TERM} = 'IGNORE';
1104 local $SIG{TSTP} = 'IGNORE';
1105 local $SIG{PIPE} = 'IGNORE';
1107 my $rc = $sth->execute or return $sth->errstr;
1108 #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1109 $h_sth->execute or return $h_sth->errstr if $h_sth;
1110 $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
1111 or return $v_sth->errstr
1112 foreach (@del_vfields);
1114 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1116 #no need to needlessly destoy the data either (causes problems actually)
1117 #undef $self; #no need to keep object!
1124 Depriciated (use delete instead).
1129 cluck "warning: FS::Record::del deprecated!";
1130 &delete(@_); #call method in this scope
1133 =item replace OLD_RECORD
1135 Replace the OLD_RECORD with this one in the database. If there is an error,
1136 returns the error, otherwise returns false.
1141 my ($new, $old) = (shift, shift);
1143 $old = $new->replace_old unless defined($old);
1145 warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1147 if ( $new->can('replace_check') ) {
1148 my $error = $new->replace_check($old);
1149 return $error if $error;
1152 return "Records not in same table!" unless $new->table eq $old->table;
1154 my $primary_key = $old->dbdef_table->primary_key;
1155 return "Can't change primary key $primary_key ".
1156 'from '. $old->getfield($primary_key).
1157 ' to ' . $new->getfield($primary_key)
1159 && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1161 my $error = $new->check;
1162 return $error if $error;
1164 # Encrypt for replace
1166 if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) {
1167 foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1168 $saved->{$field} = $new->getfield($field);
1169 $new->setfield($field, $new->encrypt($new->getfield($field)));
1173 #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1174 my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1175 ? ($_, $new->getfield($_)) : () } $old->fields;
1177 unless (keys(%diff) || $no_update_diff ) {
1178 carp "[warning]$me $new -> replace $old: records identical"
1179 unless $nowarn_identical;
1183 my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1185 "$_ = ". _quote($new->getfield($_),$old->table,$_)
1186 } real_fields($old->table)
1191 if ( $old->getfield($_) eq '' ) {
1193 #false laziness w/qsearch
1194 if ( driver_name eq 'Pg' ) {
1195 my $type = $old->dbdef_table->column($_)->type;
1196 if ( $type =~ /(int|(big)?serial)/i ) {
1199 qq-( $_ IS NULL OR $_ = '' )-;
1202 qq-( $_ IS NULL OR $_ = "" )-;
1206 "$_ = ". _quote($old->getfield($_),$old->table,$_);
1209 } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1212 warn "[debug]$me $statement\n" if $DEBUG > 1;
1213 my $sth = dbh->prepare($statement) or return dbh->errstr;
1216 if ( defined dbdef->table('h_'. $old->table) ) {
1217 my $h_old_statement = $old->_h_statement('replace_old');
1218 warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1219 $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1225 if ( defined dbdef->table('h_'. $new->table) ) {
1226 my $h_new_statement = $new->_h_statement('replace_new');
1227 warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1228 $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1233 # For virtual fields we have three cases with different SQL
1234 # statements: add, replace, delete
1238 my (@add_vfields, @rep_vfields, @del_vfields);
1239 my $vfp = $old->vfieldpart_hashref;
1240 foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
1241 if($diff{$_} eq '') {
1243 unless(@del_vfields) {
1244 my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
1245 "AND vfieldpart = ?";
1246 warn "[debug]$me $st\n" if $DEBUG > 2;
1247 $v_del_sth = dbh->prepare($st) or return dbh->errstr;
1249 push @del_vfields, $_;
1250 } elsif($old->getfield($_) eq '') {
1252 unless(@add_vfields) {
1253 my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
1255 warn "[debug]$me $st\n" if $DEBUG > 2;
1256 $v_add_sth = dbh->prepare($st) or return dbh->errstr;
1258 push @add_vfields, $_;
1261 unless(@rep_vfields) {
1262 my $st = "UPDATE virtual_field SET value = ? ".
1263 "WHERE recnum = ? AND vfieldpart = ?";
1264 warn "[debug]$me $st\n" if $DEBUG > 2;
1265 $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
1267 push @rep_vfields, $_;
1271 local $SIG{HUP} = 'IGNORE';
1272 local $SIG{INT} = 'IGNORE';
1273 local $SIG{QUIT} = 'IGNORE';
1274 local $SIG{TERM} = 'IGNORE';
1275 local $SIG{TSTP} = 'IGNORE';
1276 local $SIG{PIPE} = 'IGNORE';
1278 my $rc = $sth->execute or return $sth->errstr;
1279 #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1280 $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1281 $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1283 $v_del_sth->execute($old->getfield($primary_key),
1285 or return $v_del_sth->errstr
1286 foreach(@del_vfields);
1288 $v_add_sth->execute($new->getfield($_),
1289 $old->getfield($primary_key),
1291 or return $v_add_sth->errstr
1292 foreach(@add_vfields);
1294 $v_rep_sth->execute($new->getfield($_),
1295 $old->getfield($primary_key),
1297 or return $v_rep_sth->errstr
1298 foreach(@rep_vfields);
1300 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1302 # Now that it has been saved, reset the encrypted fields so that $new
1303 # can still be used.
1304 foreach my $field (keys %{$saved}) {
1305 $new->setfield($field, $saved->{$field});
1313 my( $self ) = shift;
1314 warn "[$me] replace called with no arguments; autoloading old record\n"
1317 my $primary_key = $self->dbdef_table->primary_key;
1318 if ( $primary_key ) {
1319 $self->by_key( $self->$primary_key() ) #this is what's returned
1320 or croak "can't find ". $self->table. ".$primary_key ".
1321 $self->$primary_key();
1323 croak $self->table. " has no primary key; pass old record as argument";
1330 Depriciated (use replace instead).
1335 cluck "warning: FS::Record::rep deprecated!";
1336 replace @_; #call method in this scope
1341 Checks virtual fields (using check_blocks). Subclasses should still provide
1342 a check method to validate real fields, foreign keys, etc., and call this
1343 method via $self->SUPER::check.
1345 (FIXME: Should this method try to make sure that it I<is> being called from
1346 a subclass's check method, to keep the current semantics as far as possible?)
1351 #confess "FS::Record::check not implemented; supply one in subclass!";
1354 foreach my $field ($self->virtual_fields) {
1355 for ($self->getfield($field)) {
1356 # See notes on check_block in FS::part_virtual_field.
1357 eval $self->pvf($field)->check_block;
1359 #this is bad, probably want to follow the stack backtrace up and see
1361 my $err = "Fatal error checking $field for $self";
1363 return "$err (see log for backtrace): $@";
1366 $self->setfield($field, $_);
1372 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1374 Processes a batch import as a queued JSRPC job
1376 JOB is an FS::queue entry.
1378 OPTIONS_HASHREF can have the following keys:
1384 Table name (required).
1388 Listref of field names for static fields. They will be given values from the
1389 PARAMS hashref and passed as a "params" hashref to batch_import.
1393 Formats hashref. Keys are field names, values are listrefs that define the
1396 Each listref value can be a column name or a code reference. Coderefs are run
1397 with the row object, data and a FS::Conf object as the three parameters.
1398 For example, this coderef does the same thing as using the "columnname" string:
1401 my( $record, $data, $conf ) = @_;
1402 $record->columnname( $data );
1405 Coderefs are run after all "column name" fields are assigned.
1409 Optional format hashref of types. Keys are field names, values are "csv",
1410 "xls" or "fixedlength". Overrides automatic determination of file type
1413 =item format_headers
1415 Optional format hashref of header lines. Keys are field names, values are 0
1416 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1419 =item format_sep_chars
1421 Optional format hashref of CSV sep_chars. Keys are field names, values are the
1422 CSV separation character.
1424 =item format_fixedlenth_formats
1426 Optional format hashref of fixed length format defintiions. Keys are field
1427 names, values Parse::FixedLength listrefs of field definitions.
1431 Set true to default to CSV file type if the filename does not contain a
1432 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1437 PARAMS is a base64-encoded Storable string containing the POSTed data as
1438 a hash ref. It normally contains at least one field, "uploaded files",
1439 generated by /elements/file-upload.html and containing the list of uploaded
1440 files. Currently only supports a single file named "file".
1444 use Storable qw(thaw);
1447 sub process_batch_import {
1448 my($job, $opt) = ( shift, shift );
1450 my $table = $opt->{table};
1451 my @pass_params = @{ $opt->{params} };
1452 my %formats = %{ $opt->{formats} };
1454 my $param = thaw(decode_base64(shift));
1455 warn Dumper($param) if $DEBUG;
1457 my $files = $param->{'uploaded_files'}
1458 or die "No files provided.\n";
1460 my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1462 my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1463 my $file = $dir. $files{'file'};
1466 FS::Record::batch_import( {
1469 formats => \%formats,
1470 format_types => $opt->{format_types},
1471 format_headers => $opt->{format_headers},
1472 format_sep_chars => $opt->{format_sep_chars},
1473 format_fixedlength_formats => $opt->{format_fixedlength_formats},
1478 format => $param->{format},
1479 params => { map { $_ => $param->{$_} } @pass_params },
1481 default_csv => $opt->{default_csv},
1486 die "$error\n" if $error;
1489 =item batch_import PARAM_HASHREF
1491 Class method for batch imports. Available params:
1501 =item format_headers
1503 =item format_sep_chars
1505 =item format_fixedlength_formats
1511 FS::queue object, will be updated with progress
1517 csv, xls or fixedlength
1530 warn "$me batch_import call with params: \n". Dumper($param)
1533 my $table = $param->{table};
1534 my $formats = $param->{formats};
1536 my $job = $param->{job};
1537 my $file = $param->{file};
1538 my $format = $param->{'format'};
1539 my $params = $param->{params} || {};
1541 die "unknown format $format" unless exists $formats->{ $format };
1543 my $type = $param->{'format_types'}
1544 ? $param->{'format_types'}{ $format }
1545 : $param->{type} || 'csv';
1548 if ( $file =~ /\.(\w+)$/i ) {
1552 warn "can't parse file type from filename $file; defaulting to CSV";
1556 if $param->{'default_csv'} && $type ne 'xls';
1559 my $header = $param->{'format_headers'}
1560 ? $param->{'format_headers'}{ $param->{'format'} }
1563 my $sep_char = $param->{'format_sep_chars'}
1564 ? $param->{'format_sep_chars'}{ $param->{'format'} }
1567 my $fixedlength_format =
1568 $param->{'format_fixedlength_formats'}
1569 ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1572 my @fields = @{ $formats->{ $format } };
1578 if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1580 if ( $type eq 'csv' ) {
1583 $attr{sep_char} = $sep_char if $sep_char;
1584 $parser = new Text::CSV_XS \%attr;
1586 } elsif ( $type eq 'fixedlength' ) {
1588 eval "use Parse::FixedLength;";
1590 $parser = new Parse::FixedLength $fixedlength_format;
1593 die "Unknown file type $type\n";
1596 @buffer = split(/\r?\n/, slurp($file) );
1597 splice(@buffer, 0, ($header || 0) );
1598 $count = scalar(@buffer);
1600 } elsif ( $type eq 'xls' ) {
1602 eval "use Spreadsheet::ParseExcel;";
1605 eval "use DateTime::Format::Excel;";
1606 #for now, just let the error be thrown if it is used, since only CDR
1607 # formats bill_west and troop use it, not other excel-parsing things
1610 my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
1612 $parser = $excel->{Worksheet}[0]; #first sheet
1614 $count = $parser->{MaxRow} || $parser->{MinRow};
1617 $row = $header || 0;
1620 die "Unknown file type $type\n";
1625 local $SIG{HUP} = 'IGNORE';
1626 local $SIG{INT} = 'IGNORE';
1627 local $SIG{QUIT} = 'IGNORE';
1628 local $SIG{TERM} = 'IGNORE';
1629 local $SIG{TSTP} = 'IGNORE';
1630 local $SIG{PIPE} = 'IGNORE';
1632 my $oldAutoCommit = $FS::UID::AutoCommit;
1633 local $FS::UID::AutoCommit = 0;
1638 my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
1642 if ( $type eq 'csv' ) {
1644 last unless scalar(@buffer);
1645 $line = shift(@buffer);
1647 $parser->parse($line) or do {
1648 $dbh->rollback if $oldAutoCommit;
1649 return "can't parse: ". $parser->error_input();
1651 @columns = $parser->fields();
1653 } elsif ( $type eq 'fixedlength' ) {
1655 @columns = $parser->parse($line);
1657 } elsif ( $type eq 'xls' ) {
1659 last if $row > ($parser->{MaxRow} || $parser->{MinRow})
1660 || ! $parser->{Cells}[$row];
1662 my @row = @{ $parser->{Cells}[$row] };
1663 @columns = map $_->{Val}, @row;
1666 #warn $z++. ": $_\n" for @columns;
1669 die "Unknown file type $type\n";
1673 my %hash = %$params;
1675 foreach my $field ( @fields ) {
1677 my $value = shift @columns;
1679 if ( ref($field) eq 'CODE' ) {
1680 #&{$field}(\%hash, $value);
1681 push @later, $field, $value;
1683 #??? $hash{$field} = $value if length($value);
1684 $hash{$field} = $value if defined($value) && length($value);
1689 my $class = "FS::$table";
1691 my $record = $class->new( \%hash );
1693 while ( scalar(@later) ) {
1694 my $sub = shift @later;
1695 my $data = shift @later;
1696 &{$sub}($record, $data, $conf); # $record->&{$sub}($data, $conf);
1699 my $error = $record->insert;
1702 $dbh->rollback if $oldAutoCommit;
1703 return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
1709 if ( $job && time - $min_sec > $last ) { #progress bar
1710 $job->update_statustext( int(100 * $imported / $count) );
1716 $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
1718 return "Empty file!" unless $imported || $param->{empty_ok};
1725 my( $self, $action, $time ) = @_;
1730 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1731 real_fields($self->table);
1734 # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1735 # You can see if it changed by the paymask...
1736 if ($conf && $conf->exists('encryption') ) {
1737 @fields = grep $_ ne 'payinfo' && $_ ne 'cvv2', @fields;
1739 my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1741 "INSERT INTO h_". $self->table. " ( ".
1742 join(', ', qw(history_date history_user history_action), @fields ).
1744 join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1751 B<Warning>: External use is B<deprecated>.
1753 Replaces COLUMN in record with a unique number, using counters in the
1754 filesystem. Used by the B<insert> method on single-field unique columns
1755 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1756 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1758 Returns the new value.
1763 my($self,$field) = @_;
1764 my($table)=$self->table;
1766 croak "Unique called on field $field, but it is ",
1767 $self->getfield($field),
1769 if $self->getfield($field);
1771 #warn "table $table is tainted" if is_tainted($table);
1772 #warn "field $field is tainted" if is_tainted($field);
1774 my($counter) = new File::CounterFile "$table.$field",0;
1776 # getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1778 # my($counter) = new File::CounterFile "$user/$table.$field",0;
1781 my $index = $counter->inc;
1782 $index = $counter->inc while qsearchs($table, { $field=>$index } );
1784 $index =~ /^(\d*)$/;
1787 $self->setfield($field,$index);
1791 =item ut_float COLUMN
1793 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be
1794 null. If there is an error, returns the error, otherwise returns false.
1799 my($self,$field)=@_ ;
1800 ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
1801 $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
1802 $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
1803 $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
1804 or return "Illegal or empty (float) $field: ". $self->getfield($field);
1805 $self->setfield($field,$1);
1808 =item ut_floatn COLUMN
1810 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
1811 null. If there is an error, returns the error, otherwise returns false.
1815 #false laziness w/ut_ipn
1817 my( $self, $field ) = @_;
1818 if ( $self->getfield($field) =~ /^()$/ ) {
1819 $self->setfield($field,'');
1822 $self->ut_float($field);
1826 =item ut_sfloat COLUMN
1828 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1829 May not be null. If there is an error, returns the error, otherwise returns
1835 my($self,$field)=@_ ;
1836 ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
1837 $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
1838 $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
1839 $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
1840 or return "Illegal or empty (float) $field: ". $self->getfield($field);
1841 $self->setfield($field,$1);
1844 =item ut_sfloatn COLUMN
1846 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
1847 null. If there is an error, returns the error, otherwise returns false.
1852 my( $self, $field ) = @_;
1853 if ( $self->getfield($field) =~ /^()$/ ) {
1854 $self->setfield($field,'');
1857 $self->ut_sfloat($field);
1861 =item ut_snumber COLUMN
1863 Check/untaint signed numeric data (whole numbers). If there is an error,
1864 returns the error, otherwise returns false.
1869 my($self, $field) = @_;
1870 $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
1871 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1872 $self->setfield($field, "$1$2");
1876 =item ut_snumbern COLUMN
1878 Check/untaint signed numeric data (whole numbers). If there is an error,
1879 returns the error, otherwise returns false.
1884 my($self, $field) = @_;
1885 $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
1886 or return "Illegal (numeric) $field: ". $self->getfield($field);
1888 return "Illegal (numeric) $field: ". $self->getfield($field)
1891 $self->setfield($field, "$1$2");
1895 =item ut_number COLUMN
1897 Check/untaint simple numeric data (whole numbers). May not be null. If there
1898 is an error, returns the error, otherwise returns false.
1903 my($self,$field)=@_;
1904 $self->getfield($field) =~ /^\s*(\d+)\s*$/
1905 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1906 $self->setfield($field,$1);
1910 =item ut_numbern COLUMN
1912 Check/untaint simple numeric data (whole numbers). May be null. If there is
1913 an error, returns the error, otherwise returns false.
1918 my($self,$field)=@_;
1919 $self->getfield($field) =~ /^\s*(\d*)\s*$/
1920 or return "Illegal (numeric) $field: ". $self->getfield($field);
1921 $self->setfield($field,$1);
1925 =item ut_money COLUMN
1927 Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
1928 is an error, returns the error, otherwise returns false.
1933 my($self,$field)=@_;
1934 $self->setfield($field, 0) if $self->getfield($field) eq '';
1935 $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/
1936 or return "Illegal (money) $field: ". $self->getfield($field);
1937 #$self->setfield($field, "$1$2$3" || 0);
1938 $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
1942 =item ut_text COLUMN
1944 Check/untaint text. Alphanumerics, spaces, and the following punctuation
1945 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ]
1946 May not be null. If there is an error, returns the error, otherwise returns
1952 my($self,$field)=@_;
1953 #warn "msgcat ". \&msgcat. "\n";
1954 #warn "notexist ". \¬exist. "\n";
1955 #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
1956 $self->getfield($field)
1957 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/
1958 or return gettext('illegal_or_empty_text'). " $field: ".
1959 $self->getfield($field);
1960 $self->setfield($field,$1);
1964 =item ut_textn COLUMN
1966 Check/untaint text. Alphanumerics, spaces, and the following punctuation
1967 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
1968 May be null. If there is an error, returns the error, otherwise returns false.
1973 my($self,$field)=@_;
1974 $self->getfield($field)
1975 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/
1976 or return gettext('illegal_text'). " $field: ". $self->getfield($field);
1977 $self->setfield($field,$1);
1981 =item ut_alpha COLUMN
1983 Check/untaint alphanumeric strings (no spaces). May not be null. If there is
1984 an error, returns the error, otherwise returns false.
1989 my($self,$field)=@_;
1990 $self->getfield($field) =~ /^(\w+)$/
1991 or return "Illegal or empty (alphanumeric) $field: ".
1992 $self->getfield($field);
1993 $self->setfield($field,$1);
1997 =item ut_alpha COLUMN
1999 Check/untaint alphanumeric strings (no spaces). May be null. If there is an
2000 error, returns the error, otherwise returns false.
2005 my($self,$field)=@_;
2006 $self->getfield($field) =~ /^(\w*)$/
2007 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2008 $self->setfield($field,$1);
2012 =item ut_alpha_lower COLUMN
2014 Check/untaint lowercase alphanumeric strings (no spaces). May not be null. If
2015 there is an error, returns the error, otherwise returns false.
2019 sub ut_alpha_lower {
2020 my($self,$field)=@_;
2021 $self->getfield($field) =~ /[[:upper:]]/
2022 and return "Uppercase characters are not permitted in $field";
2023 $self->ut_alpha($field);
2026 =item ut_phonen COLUMN [ COUNTRY ]
2028 Check/untaint phone numbers. May be null. If there is an error, returns
2029 the error, otherwise returns false.
2031 Takes an optional two-letter ISO country code; without it or with unsupported
2032 countries, ut_phonen simply calls ut_alphan.
2037 my( $self, $field, $country ) = @_;
2038 return $self->ut_alphan($field) unless defined $country;
2039 my $phonen = $self->getfield($field);
2040 if ( $phonen eq '' ) {
2041 $self->setfield($field,'');
2042 } elsif ( $country eq 'US' || $country eq 'CA' ) {
2044 $phonen = $conf->config('cust_main-default_areacode').$phonen
2045 if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2046 $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2047 or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2048 $phonen = "$1-$2-$3";
2049 $phonen .= " x$4" if $4;
2050 $self->setfield($field,$phonen);
2052 warn "warning: don't know how to check phone numbers for country $country";
2053 return $self->ut_textn($field);
2060 Check/untaint hexadecimal values.
2065 my($self, $field) = @_;
2066 $self->getfield($field) =~ /^([\da-fA-F]+)$/
2067 or return "Illegal (hex) $field: ". $self->getfield($field);
2068 $self->setfield($field, uc($1));
2072 =item ut_hexn COLUMN
2074 Check/untaint hexadecimal values. May be null.
2079 my($self, $field) = @_;
2080 $self->getfield($field) =~ /^([\da-fA-F]*)$/
2081 or return "Illegal (hex) $field: ". $self->getfield($field);
2082 $self->setfield($field, uc($1));
2087 Check/untaint ip addresses. IPv4 only for now.
2092 my( $self, $field ) = @_;
2093 $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2094 or return "Illegal (IP address) $field: ". $self->getfield($field);
2095 for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2096 $self->setfield($field, "$1.$2.$3.$4");
2102 Check/untaint ip addresses. IPv4 only for now. May be null.
2107 my( $self, $field ) = @_;
2108 if ( $self->getfield($field) =~ /^()$/ ) {
2109 $self->setfield($field,'');
2112 $self->ut_ip($field);
2116 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2118 Check/untaint coordinates.
2119 Accepts the following forms:
2129 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2130 The latter form (that is, the MMM are thousands of minutes) is
2131 assumed if the "MMM" is exactly three digits or two digits > 59.
2133 To be safe, just use the DDD.DDDDD form.
2135 If LOWER or UPPER are specified, then the coordinate is checked
2136 for lower and upper bounds, respectively.
2142 my ($self, $field) = (shift, shift);
2144 my $lower = shift if scalar(@_);
2145 my $upper = shift if scalar(@_);
2146 my $coord = $self->getfield($field);
2147 my $neg = $coord =~ s/^(-)//;
2149 my ($d, $m, $s) = (0, 0, 0);
2152 (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2153 (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2154 (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2156 $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2159 return "Invalid (coordinate with minutes > 59) $field: "
2160 . $self->getfield($field);
2163 $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2165 if (defined($lower) and ($coord < $lower)) {
2166 return "Invalid (coordinate < $lower) $field: "
2167 . $self->getfield($field);;
2170 if (defined($upper) and ($coord > $upper)) {
2171 return "Invalid (coordinate > $upper) $field: "
2172 . $self->getfield($field);;
2175 $self->setfield($field, $coord);
2179 return "Invalid (coordinate) $field: " . $self->getfield($field);
2183 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2185 Same as ut_coord, except optionally null.
2191 my ($self, $field) = (shift, shift);
2193 if ($self->getfield($field) =~ /^$/) {
2196 return $self->ut_coord($field, @_);
2202 =item ut_domain COLUMN
2204 Check/untaint host and domain names.
2209 my( $self, $field ) = @_;
2210 #$self->getfield($field) =~/^(\w+\.)*\w+$/
2211 $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2212 or return "Illegal (domain) $field: ". $self->getfield($field);
2213 $self->setfield($field,$1);
2217 =item ut_name COLUMN
2219 Check/untaint proper names; allows alphanumerics, spaces and the following
2220 punctuation: , . - '
2227 my( $self, $field ) = @_;
2228 $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
2229 or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2230 $self->setfield($field,$1);
2236 Check/untaint zip codes.
2240 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2243 my( $self, $field, $country ) = @_;
2245 if ( $country eq 'US' ) {
2247 $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2248 or return gettext('illegal_zip'). " $field for country $country: ".
2249 $self->getfield($field);
2250 $self->setfield($field, $1);
2252 } elsif ( $country eq 'CA' ) {
2254 $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2255 or return gettext('illegal_zip'). " $field for country $country: ".
2256 $self->getfield($field);
2257 $self->setfield($field, "$1 $2");
2261 if ( $self->getfield($field) =~ /^\s*$/
2262 && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2265 $self->setfield($field,'');
2267 $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
2268 or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2269 $self->setfield($field,$1);
2277 =item ut_country COLUMN
2279 Check/untaint country codes. Country names are changed to codes, if possible -
2280 see L<Locale::Country>.
2285 my( $self, $field ) = @_;
2286 unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2287 if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2288 && country2code($1) ) {
2289 $self->setfield($field,uc(country2code($1)));
2292 $self->getfield($field) =~ /^(\w\w)$/
2293 or return "Illegal (country) $field: ". $self->getfield($field);
2294 $self->setfield($field,uc($1));
2298 =item ut_anything COLUMN
2300 Untaints arbitrary data. Be careful.
2305 my( $self, $field ) = @_;
2306 $self->getfield($field) =~ /^(.*)$/s
2307 or return "Illegal $field: ". $self->getfield($field);
2308 $self->setfield($field,$1);
2312 =item ut_enum COLUMN CHOICES_ARRAYREF
2314 Check/untaint a column, supplying all possible choices, like the "enum" type.
2319 my( $self, $field, $choices ) = @_;
2320 foreach my $choice ( @$choices ) {
2321 if ( $self->getfield($field) eq $choice ) {
2322 $self->setfield($choice);
2326 return "Illegal (enum) field $field: ". $self->getfield($field);
2329 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2331 Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
2332 on the column first.
2336 sub ut_foreign_key {
2337 my( $self, $field, $table, $foreign ) = @_;
2338 return '' if $no_check_foreign;
2339 qsearchs($table, { $foreign => $self->getfield($field) })
2340 or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
2341 " in $table.$foreign";
2345 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2347 Like ut_foreign_key, except the null value is also allowed.
2351 sub ut_foreign_keyn {
2352 my( $self, $field, $table, $foreign ) = @_;
2353 $self->getfield($field)
2354 ? $self->ut_foreign_key($field, $table, $foreign)
2358 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
2360 Checks this column as an agentnum, taking into account the current users's
2361 ACLs. NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
2362 right or rights allowing no agentnum.
2366 sub ut_agentnum_acl {
2367 my( $self, $field ) = (shift, shift);
2368 my $null_acl = scalar(@_) ? shift : [];
2369 $null_acl = [ $null_acl ] unless ref($null_acl);
2371 my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
2372 return "Illegal agentnum: $error" if $error;
2374 my $curuser = $FS::CurrentUser::CurrentUser;
2376 if ( $self->$field() ) {
2378 return "Access denied"
2379 unless $curuser->agentnum($self->$field());
2383 return "Access denied"
2384 unless grep $curuser->access_right($_), @$null_acl;
2392 =item virtual_fields [ TABLE ]
2394 Returns a list of virtual fields defined for the table. This should not
2395 be exported, and should only be called as an instance or class method.
2399 sub virtual_fields {
2402 $table = $self->table or confess "virtual_fields called on non-table";
2404 confess "Unknown table $table" unless dbdef->table($table);
2406 return () unless dbdef->table('part_virtual_field');
2408 unless ( $virtual_fields_cache{$table} ) {
2409 my $query = 'SELECT name from part_virtual_field ' .
2410 "WHERE dbtable = '$table'";
2412 my $result = $dbh->selectcol_arrayref($query);
2413 confess "Error executing virtual fields query: $query: ". $dbh->errstr
2415 $virtual_fields_cache{$table} = $result;
2418 @{$virtual_fields_cache{$table}};
2423 =item fields [ TABLE ]
2425 This is a wrapper for real_fields and virtual_fields. Code that called
2426 fields before should probably continue to call fields.
2431 my $something = shift;
2433 if($something->isa('FS::Record')) {
2434 $table = $something->table;
2436 $table = $something;
2437 $something = "FS::$table";
2439 return (real_fields($table), $something->virtual_fields());
2442 =item pvf FIELD_NAME
2444 Returns the FS::part_virtual_field object corresponding to a field in the
2445 record (specified by FIELD_NAME).
2450 my ($self, $name) = (shift, shift);
2452 if(grep /^$name$/, $self->virtual_fields) {
2453 return qsearchs('part_virtual_field', { dbtable => $self->table,
2459 =item vfieldpart_hashref TABLE
2461 Returns a hashref of virtual field names and vfieldparts applicable to the given
2466 sub vfieldpart_hashref {
2468 my $table = $self->table;
2470 return {} unless dbdef->table('part_virtual_field');
2473 my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
2474 "dbtable = '$table'";
2475 my $sth = $dbh->prepare($statement);
2476 $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
2477 return { map { $_->{name}, $_->{vfieldpart} }
2478 @{$sth->fetchall_arrayref({})} };
2482 =item encrypt($value)
2484 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2486 Returns the encrypted string.
2488 You should generally not have to worry about calling this, as the system handles this for you.
2493 my ($self, $value) = @_;
2496 if ($conf->exists('encryption')) {
2497 if ($self->is_encrypted($value)) {
2498 # Return the original value if it isn't plaintext.
2499 $encrypted = $value;
2502 if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2503 # RSA doesn't like the empty string so let's pack it up
2504 # The database doesn't like the RSA data so uuencode it
2505 my $length = length($value)+1;
2506 $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2508 die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2515 =item is_encrypted($value)
2517 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2523 my ($self, $value) = @_;
2524 # Possible Bug - Some work may be required here....
2526 if ($value =~ /^M/ && length($value) > 80) {
2533 =item decrypt($value)
2535 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2537 You should generally not have to worry about calling this, as the system handles this for you.
2542 my ($self,$value) = @_;
2543 my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2544 if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2546 if (ref($rsa_decrypt) =~ /::RSA/) {
2547 my $encrypted = unpack ("u*", $value);
2548 $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2549 if ($@) {warn "Decryption Failed"};
2557 #Initialize the Module
2558 $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2560 if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') {
2561 $rsa_module = $conf->config('encryptionmodule');
2565 eval ("require $rsa_module"); # No need to import the namespace
2568 # Initialize Encryption
2569 if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') {
2570 my $public_key = join("\n",$conf->config('encryptionpublickey'));
2571 $rsa_encrypt = $rsa_module->new_public_key($public_key);
2574 # Intitalize Decryption
2575 if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') {
2576 my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2577 $rsa_decrypt = $rsa_module->new_private_key($private_key);
2581 =item h_search ACTION
2583 Given an ACTION, either "insert", or "delete", returns the appropriate history
2584 record corresponding to this record, if any.
2589 my( $self, $action ) = @_;
2591 my $table = $self->table;
2594 my $primary_key = dbdef->table($table)->primary_key;
2597 'table' => "h_$table",
2598 'hashref' => { $primary_key => $self->$primary_key(),
2599 'history_action' => $action,
2607 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2608 appropriate history record corresponding to this record, if any.
2613 my($self, $action) = @_;
2614 my $h = $self->h_search($action);
2615 $h ? $h->history_date : '';
2624 =item real_fields [ TABLE ]
2626 Returns a list of the real columns in the specified table. Called only by
2627 fields() and other subroutines elsewhere in FS::Record.
2634 my($table_obj) = dbdef->table($table);
2635 confess "Unknown table $table" unless $table_obj;
2636 $table_obj->columns;
2639 =item _quote VALUE, TABLE, COLUMN
2641 This is an internal function used to construct SQL statements. It returns
2642 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2643 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2648 my($value, $table, $column) = @_;
2649 my $column_obj = dbdef->table($table)->column($column);
2650 my $column_type = $column_obj->type;
2651 my $nullable = $column_obj->null;
2653 warn " $table.$column: $value ($column_type".
2654 ( $nullable ? ' NULL' : ' NOT NULL' ).
2655 ")\n" if $DEBUG > 2;
2657 if ( $value eq '' && $nullable ) {
2659 } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2660 cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2663 } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2664 ! $column_type =~ /(char|binary|text)$/i ) {
2673 This is deprecated. Don't use it.
2675 It returns a hash-type list with the fields of this record's table set true.
2680 carp "warning: hfields is deprecated";
2683 foreach (fields($table)) {
2692 "$_: ". $self->getfield($_). "|"
2693 } (fields($self->table)) );
2696 sub DESTROY { return; }
2700 # #use Carp qw(cluck);
2701 # #cluck "DESTROYING $self";
2702 # warn "DESTROYING $self";
2706 # return ! eval { join('',@_), kill 0; 1; };
2709 =item str2time_sql [ DRIVER_NAME ]
2711 Returns a function to convert to unix time based on database type, such as
2712 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql. See
2713 the str2time_sql_closing method to return a closing string rather than just
2714 using a closing parenthesis as previously suggested.
2716 You can pass an optional driver name such as "Pg", "mysql" or
2717 $dbh->{Driver}->{Name} to return a function for that database instead of
2718 the current database.
2723 my $driver = shift || driver_name;
2725 return 'UNIX_TIMESTAMP(' if $driver =~ /^mysql/i;
2726 return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
2728 warn "warning: unknown database type $driver; guessing how to convert ".
2729 "dates to UNIX timestamps";
2730 return 'EXTRACT(EPOCH FROM ';
2734 =item str2time_sql_closing [ DRIVER_NAME ]
2736 Returns the closing suffix of a function to convert to unix time based on
2737 database type, such as ")::integer" for Pg or ")" for mysql.
2739 You can pass an optional driver name such as "Pg", "mysql" or
2740 $dbh->{Driver}->{Name} to return a function for that database instead of
2741 the current database.
2745 sub str2time_sql_closing {
2746 my $driver = shift || driver_name;
2748 return ' )::INTEGER ' if $driver =~ /^Pg/i;
2756 This module should probably be renamed, since much of the functionality is
2757 of general use. It is not completely unlike Adapter::DBI (see below).
2759 Exported qsearch and qsearchs should be deprecated in favor of method calls
2760 (against an FS::Record object like the old search and searchs that qsearch
2761 and qsearchs were on top of.)
2763 The whole fields / hfields mess should be removed.
2765 The various WHERE clauses should be subroutined.
2767 table string should be deprecated in favor of DBIx::DBSchema::Table.
2769 No doubt we could benefit from a Tied hash. Documenting how exists / defined
2770 true maps to the database (and WHERE clauses) would also help.
2772 The ut_ methods should ask the dbdef for a default length.
2774 ut_sqltype (like ut_varchar) should all be defined
2776 A fallback check method should be provided which uses the dbdef.
2778 The ut_money method assumes money has two decimal digits.
2780 The Pg money kludge in the new method only strips `$'.
2782 The ut_phonen method only checks US-style phone numbers.
2784 The _quote function should probably use ut_float instead of a regex.
2786 All the subroutines probably should be methods, here or elsewhere.
2788 Probably should borrow/use some dbdef methods where appropriate (like sub
2791 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
2792 or allow it to be set. Working around it is ugly any way around - DBI should
2793 be fixed. (only affects RDBMS which return uppercase column names)
2795 ut_zip should take an optional country like ut_phone.
2799 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
2801 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.