4 use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG
5 $conf $conf_encryption $me
7 $nowarn_identical $no_update_diff $no_check_foreign
10 use Carp qw(carp cluck croak confess);
11 use Scalar::Util qw( blessed );
12 use File::CounterFile;
15 use File::Slurp qw( slurp );
16 use DBI qw(:sql_types);
17 use DBIx::DBSchema 0.33;
18 use FS::UID qw(dbh getotaker datasrc driver_name);
20 use FS::Schema qw(dbdef);
22 use FS::Msgcat qw(gettext);
23 #use FS::Conf; #dependency loop bs, in install_callback below instead
25 use FS::part_virtual_field;
31 #export dbdef for now... everything else expects to find it here
32 @EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch
33 str2time_sql str2time_sql_closing );
38 $nowarn_identical = 0;
40 $no_check_foreign = 0;
48 $conf_encryption = '';
49 FS::UID->install_callback( sub {
52 $conf = FS::Conf->new;
53 $conf_encryption = $conf->exists('encryption');
54 $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
60 FS::Record - Database record objects
65 use FS::Record qw(dbh fields qsearch qsearchs);
67 $record = new FS::Record 'table', \%hash;
68 $record = new FS::Record 'table', { 'column' => 'value', ... };
70 $record = qsearchs FS::Record 'table', \%hash;
71 $record = qsearchs FS::Record 'table', { 'column' => 'value', ... };
72 @records = qsearch FS::Record 'table', \%hash;
73 @records = qsearch FS::Record 'table', { 'column' => 'value', ... };
75 $table = $record->table;
76 $dbdef_table = $record->dbdef_table;
78 $value = $record->get('column');
79 $value = $record->getfield('column');
80 $value = $record->column;
82 $record->set( 'column' => 'value' );
83 $record->setfield( 'column' => 'value' );
84 $record->column('value');
86 %hash = $record->hash;
88 $hashref = $record->hashref;
90 $error = $record->insert;
92 $error = $record->delete;
94 $error = $new_record->replace($old_record);
96 # external use deprecated - handled by the database (at least for Pg, mysql)
97 $value = $record->unique('column');
99 $error = $record->ut_float('column');
100 $error = $record->ut_floatn('column');
101 $error = $record->ut_number('column');
102 $error = $record->ut_numbern('column');
103 $error = $record->ut_snumber('column');
104 $error = $record->ut_snumbern('column');
105 $error = $record->ut_money('column');
106 $error = $record->ut_text('column');
107 $error = $record->ut_textn('column');
108 $error = $record->ut_alpha('column');
109 $error = $record->ut_alphan('column');
110 $error = $record->ut_phonen('column');
111 $error = $record->ut_anything('column');
112 $error = $record->ut_name('column');
114 $quoted_value = _quote($value,'table','field');
117 $fields = hfields('table');
118 if ( $fields->{Field} ) { # etc.
120 @fields = fields 'table'; #as a subroutine
121 @fields = $record->fields; #as a method call
126 (Mostly) object-oriented interface to database records. Records are currently
127 implemented on top of DBI. FS::Record is intended as a base class for
128 table-specific classes to inherit from, i.e. FS::cust_main.
134 =item new [ TABLE, ] HASHREF
136 Creates a new record. It doesn't store it in the database, though. See
137 L<"insert"> for that.
139 Note that the object stores this hash reference, not a distinct copy of the
140 hash it points to. You can ask the object for a copy with the I<hash>
143 TABLE can only be omitted when a dervived class overrides the table method.
149 my $class = ref($proto) || $proto;
151 bless ($self, $class);
153 unless ( defined ( $self->table ) ) {
154 $self->{'Table'} = shift;
155 carp "warning: FS::Record::new called with table name ". $self->{'Table'};
158 $self->{'Hash'} = shift;
160 foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
161 $self->{'Hash'}{$field}='';
164 $self->_rebless if $self->can('_rebless');
166 $self->{'modified'} = 0;
168 $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
175 my $class = ref($proto) || $proto;
177 bless ($self, $class);
179 $self->{'Table'} = shift unless defined ( $self->table );
181 my $hashref = $self->{'Hash'} = shift;
183 if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
184 my $obj = $cache->cache->{$hashref->{$cache->key}};
185 $obj->_cache($hashref, $cache) if $obj->can('_cache');
188 $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
195 my $class = ref($proto) || $proto;
197 bless ($self, $class);
198 if ( defined $self->table ) {
199 cluck "create constructor is deprecated, use new!";
202 croak "FS::Record::create called (not from a subclass)!";
206 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
208 Searches the database for all records matching (at least) the key/value pairs
209 in HASHREF. Returns all the records found as `FS::TABLE' objects if that
210 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
213 The preferred usage is to pass a hash reference of named parameters:
215 my @records = qsearch( {
216 'table' => 'table_name',
217 'hashref' => { 'field' => 'value'
218 'field' => { 'op' => '<',
223 #these are optional...
225 'extra_sql' => 'AND field ',
226 'order_by' => 'ORDER BY something',
227 #'cache_obj' => '', #optional
228 'addl_from' => 'LEFT JOIN othtable USING ( field )',
233 Much code still uses old-style positional parameters, this is also probably
234 fine in the common case where there are only two parameters:
236 my @records = qsearch( 'table', { 'field' => 'value' } );
238 ###oops, argh, FS::Record::new only lets us create database fields.
239 #Normal behaviour if SELECT is not specified is `*', as in
240 #C<SELECT * FROM table WHERE ...>. However, there is an experimental new
241 #feature where you can specify SELECT - remember, the objects returned,
242 #although blessed into the appropriate `FS::TABLE' package, will only have the
243 #fields you specify. This might have unwanted results if you then go calling
244 #regular FS::TABLE methods
249 my %TYPE = (); #for debugging
252 my ($type, $value) = @_;
253 if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) ||
254 ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/)
262 my($stable, $record, $select, $extra_sql, $order_by, $cache, $addl_from );
264 if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too
266 $stable = $opt->{'table'} or die "table name is required";
267 $record = $opt->{'hashref'} || {};
268 $select = $opt->{'select'} || '*';
269 $extra_sql = $opt->{'extra_sql'} || '';
270 $order_by = $opt->{'order_by'} || '';
271 $cache = $opt->{'cache_obj'} || '';
272 $addl_from = $opt->{'addl_from'} || '';
273 $debug = $opt->{'debug'} || '';
275 ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_;
279 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
281 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
285 my $table = $cache ? $cache->table : $stable;
286 my $dbdef_table = dbdef->table($table)
287 or die "No schema for table $table found - ".
288 "do you need to run freeside-upgrade?";
289 my $pkey = $dbdef_table->primary_key;
291 my @real_fields = grep exists($record->{$_}), real_fields($table);
293 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
294 @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
296 cluck "warning: FS::$table not loaded; virtual fields not searchable";
297 @virtual_fields = ();
300 my $statement = "SELECT $select FROM $stable";
301 $statement .= " $addl_from" if $addl_from;
302 if ( @real_fields or @virtual_fields ) {
303 $statement .= ' WHERE '. join(' AND ',
304 get_real_fields($table, $record, \@real_fields) ,
305 get_virtual_fields($table, $pkey, $record, \@virtual_fields),
309 $statement .= " $extra_sql" if defined($extra_sql);
310 $statement .= " $order_by" if defined($order_by);
312 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
313 my $sth = $dbh->prepare($statement)
314 or croak "$dbh->errstr doing $statement";
319 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
322 my $value = $record->{$field};
323 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
324 $value = $value->{'value'} if ref($value);
325 my $type = dbdef->table($table)->column($field)->type;
327 my $TYPE = SQL_VARCHAR;
328 if ( $type =~ /(int|(big)?serial)/i && $value =~ /^\d+(\.\d+)?$/ ) {
331 #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT
332 #fixed by DBD::Pg 2.11.8
333 #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded
334 } elsif ( _is_fs_float( $type, $value ) ) {
340 %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
342 warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
345 #if this needs to be re-enabled, it needs to use a custom op like
346 #"APPROX=" or something (better name?, not '=', to avoid affecting other
348 #if ($TYPE eq SQL_DECIMAL && $op eq 'APPROX=' ) {
349 # # these values are arbitrary; better (faster?) ones welcome
350 # $sth->bind_param($bind++, $value*1.00001, { TYPE => $TYPE } );
351 # $sth->bind_param($bind++, $value*.99999, { TYPE => $TYPE } );
353 $sth->bind_param($bind++, $value, { TYPE => $TYPE } );
358 # $sth->execute( map $record->{$_},
359 # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
360 # ) or croak "Error executing \"$statement\": ". $sth->errstr;
362 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
364 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
365 @virtual_fields = "FS::$table"->virtual_fields;
367 cluck "warning: FS::$table not loaded; virtual fields not returned either";
368 @virtual_fields = ();
372 tie %result, "Tie::IxHash";
373 my @stuff = @{ $sth->fetchall_arrayref( {} ) };
374 if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
375 %result = map { $_->{$pkey}, $_ } @stuff;
377 @result{@stuff} = @stuff;
382 if ( keys(%result) and @virtual_fields ) {
384 "SELECT virtual_field.recnum, part_virtual_field.name, ".
385 "virtual_field.value ".
386 "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ".
387 "WHERE part_virtual_field.dbtable = '$table' AND ".
388 "virtual_field.recnum IN (".
389 join(',', keys(%result)). ") AND part_virtual_field.name IN ('".
390 join(q!', '!, @virtual_fields) . "')";
391 warn "[debug]$me $statement\n" if $DEBUG > 1;
392 $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement";
393 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
395 foreach (@{ $sth->fetchall_arrayref({}) }) {
396 my $recnum = $_->{recnum};
397 my $name = $_->{name};
398 my $value = $_->{value};
399 if (exists($result{$recnum})) {
400 $result{$recnum}->{$name} = $value;
405 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
406 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
407 #derivied class didn't override new method, so this optimization is safe
410 new_or_cached( "FS::$table", { %{$_} }, $cache )
414 new( "FS::$table", { %{$_} } )
418 #okay, its been tested
419 # warn "untested code (class FS::$table uses custom new method)";
421 eval 'FS::'. $table. '->new( { %{$_} } )';
425 # Check for encrypted fields and decrypt them.
426 ## only in the local copy, not the cached object
427 if ( $conf_encryption
428 && eval 'defined(@FS::'. $table . '::encrypted_fields)' ) {
429 foreach my $record (@return) {
430 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
431 # Set it directly... This may cause a problem in the future...
432 $record->setfield($field, $record->decrypt($record->getfield($field)));
437 cluck "warning: FS::$table not loaded; returning FS::Record objects";
439 FS::Record->new( $table, { %{$_} } );
445 ## makes this easier to read
447 sub get_virtual_fields {
451 my $virtual_fields = shift;
457 if ( ref($record->{$_}) ) {
458 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
459 if ( uc($op) eq 'ILIKE' ) {
461 $record->{$_}{'value'} = lc($record->{$_}{'value'});
462 $column = "LOWER($_)";
464 $record->{$_} = $record->{$_}{'value'};
467 # ... EXISTS ( SELECT name, value FROM part_virtual_field
469 # ON part_virtual_field.vfieldpart = virtual_field.vfieldpart
470 # WHERE recnum = svc_acct.svcnum
471 # AND (name, value) = ('egad', 'brain') )
473 my $value = $record->{$_};
477 $subq = ($value ? 'EXISTS ' : 'NOT EXISTS ') .
478 "( SELECT part_virtual_field.name, virtual_field.value ".
479 "FROM part_virtual_field JOIN virtual_field ".
480 "ON part_virtual_field.vfieldpart = virtual_field.vfieldpart ".
481 "WHERE virtual_field.recnum = ${table}.${pkey} ".
482 "AND part_virtual_field.name = '${column}'".
484 " AND virtual_field.value ${op} '${value}'"
488 } @{ $virtual_fields } ) ;
491 sub get_real_fields {
494 my $real_fields = shift;
496 ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability
502 my $type = dbdef->table($table)->column($column)->type;
503 my $value = $record->{$column};
504 $value = $value->{'value'} if ref($value);
505 if ( ref($record->{$_}) ) {
506 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
507 #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
508 if ( uc($op) eq 'ILIKE' ) {
510 $record->{$_}{'value'} = lc($record->{$_}{'value'});
511 $column = "LOWER($_)";
513 $record->{$_} = $record->{$_}{'value'}
516 if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
518 if ( driver_name eq 'Pg' ) {
519 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
520 qq-( $column IS NULL )-;
522 qq-( $column IS NULL OR $column = '' )-;
525 qq-( $column IS NULL OR $column = "" )-;
527 } elsif ( $op eq '!=' ) {
528 if ( driver_name eq 'Pg' ) {
529 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
530 qq-( $column IS NOT NULL )-;
532 qq-( $column IS NOT NULL AND $column != '' )-;
535 qq-( $column IS NOT NULL AND $column != "" )-;
538 if ( driver_name eq 'Pg' ) {
539 qq-( $column $op '' )-;
541 qq-( $column $op "" )-;
544 #if this needs to be re-enabled, it needs to use a custom op like
545 #"APPROX=" or something (better name?, not '=', to avoid affecting other
547 #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
548 # ( "$column <= ?", "$column >= ?" );
552 } @{ $real_fields } );
555 =item by_key PRIMARY_KEY_VALUE
557 This is a class method that returns the record with the given primary key
558 value. This method is only useful in FS::Record subclasses. For example:
560 my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
564 my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
569 my ($class, $pkey_value) = @_;
571 my $table = $class->table
572 or croak "No table for $class found";
574 my $dbdef_table = dbdef->table($table)
575 or die "No schema for table $table found - ".
576 "do you need to create it or run dbdef-create?";
577 my $pkey = $dbdef_table->primary_key
578 or die "No primary key for table $table";
580 return qsearchs($table, { $pkey => $pkey_value });
583 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
585 Experimental JOINed search method. Using this method, you can execute a
586 single SELECT spanning multiple tables, and cache the results for subsequent
587 method calls. Interface will almost definately change in an incompatible
595 my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
596 my $cache = FS::SearchCache->new( $ptable, $pkey );
599 grep { !$saw{$_->getfield($pkey)}++ }
600 qsearch($table, $record, $select, $extra_sql, $cache )
604 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
606 Same as qsearch, except that if more than one record matches, it B<carp>s but
607 returns the first. If this happens, you either made a logic error in asking
608 for a single item, or your data is corrupted.
612 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
614 my(@result) = qsearch(@_);
615 cluck "warning: Multiple records in scalar search ($table)"
616 if scalar(@result) > 1;
617 #should warn more vehemently if the search was on a primary key?
618 scalar(@result) ? ($result[0]) : ();
629 Returns the table name.
634 # cluck "warning: FS::Record::table deprecated; supply one in subclass!";
641 Returns the DBIx::DBSchema::Table object for the table.
647 my($table)=$self->table;
648 dbdef->table($table);
653 Returns the primary key for the table.
659 my $pkey = $self->dbdef_table->primary_key;
662 =item get, getfield COLUMN
664 Returns the value of the column/field/key COLUMN.
669 my($self,$field) = @_;
670 # to avoid "Use of unitialized value" errors
671 if ( defined ( $self->{Hash}->{$field} ) ) {
672 $self->{Hash}->{$field};
682 =item set, setfield COLUMN, VALUE
684 Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE.
689 my($self,$field,$value) = @_;
690 $self->{'modified'} = 1;
691 $self->{'Hash'}->{$field} = $value;
698 =item AUTLOADED METHODS
700 $record->column is a synonym for $record->get('column');
702 $record->column('value') is a synonym for $record->set('column','value');
709 my($field)=$AUTOLOAD;
711 if ( defined($value) ) {
712 confess "errant AUTOLOAD $field for $self (arg $value)"
713 unless blessed($self) && $self->can('setfield');
714 $self->setfield($field,$value);
716 confess "errant AUTOLOAD $field for $self (no args)"
717 unless blessed($self) && $self->can('getfield');
718 $self->getfield($field);
724 # my $field = $AUTOLOAD;
726 # if ( defined($_[1]) ) {
727 # $_[0]->setfield($field, $_[1]);
729 # $_[0]->getfield($field);
735 Returns a list of the column/value pairs, usually for assigning to a new hash.
737 To make a distinct duplicate of an FS::Record object, you can do:
739 $new = new FS::Record ( $old->table, { $old->hash } );
745 confess $self. ' -> hash: Hash attribute is undefined'
746 unless defined($self->{'Hash'});
747 %{ $self->{'Hash'} };
752 Returns a reference to the column/value hash. This may be deprecated in the
753 future; if there's a reason you can't just use the autoloaded or get/set
765 Returns true if any of this object's values have been modified with set (or via
766 an autoloaded method). Doesn't yet recognize when you retreive a hashref and
776 =item select_for_update
778 Selects this record with the SQL "FOR UPDATE" command. This can be useful as
783 sub select_for_update {
785 my $primary_key = $self->primary_key;
788 'table' => $self->table,
789 'hashref' => { $primary_key => $self->$primary_key() },
790 'extra_sql' => 'FOR UPDATE',
796 Locks this table with a database-driver specific lock method. This is used
797 as a mutex in order to do a duplicate search.
799 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
801 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
803 Errors are fatal; no useful return value.
805 Note: To use this method for new tables other than svc_acct and svc_phone,
806 edit freeside-upgrade and add those tables to the duplicate_lock list.
812 my $table = $self->table;
814 warn "$me locking $table table\n" if $DEBUG;
816 if ( driver_name =~ /^Pg/i ) {
818 dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
821 } elsif ( driver_name =~ /^mysql/i ) {
823 dbh->do("SELECT * FROM duplicate_lock
824 WHERE lockname = '$table'
826 ) or die dbh->errstr;
830 die "unknown database ". driver_name. "; don't know how to lock table";
834 warn "$me acquired $table table lock\n" if $DEBUG;
840 Inserts this record to the database. If there is an error, returns the error,
841 otherwise returns false.
849 warn "$self -> insert" if $DEBUG;
851 my $error = $self->check;
852 return $error if $error;
854 #single-field unique keys are given a value if false
855 #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
856 foreach ( $self->dbdef_table->unique_singles) {
857 $self->unique($_) unless $self->getfield($_);
860 #and also the primary key, if the database isn't going to
861 my $primary_key = $self->dbdef_table->primary_key;
863 if ( $primary_key ) {
864 my $col = $self->dbdef_table->column($primary_key);
867 uc($col->type) =~ /^(BIG)?SERIAL\d?/
868 || ( driver_name eq 'Pg'
869 && defined($col->default)
870 && $col->default =~ /^nextval\(/i
872 || ( driver_name eq 'mysql'
873 && defined($col->local)
874 && $col->local =~ /AUTO_INCREMENT/i
876 $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
879 my $table = $self->table;
881 # Encrypt before the database
882 if ( defined(eval '@FS::'. $table . '::encrypted_fields')
883 && scalar( eval '@FS::'. $table . '::encrypted_fields')
884 && $conf->exists('encryption')
886 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
887 $self->{'saved'} = $self->getfield($field);
888 $self->setfield($field, $self->encrypt($self->getfield($field)));
892 #false laziness w/delete
894 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
897 my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
900 my $statement = "INSERT INTO $table ";
901 if ( @real_fields ) {
904 join( ', ', @real_fields ).
906 join( ', ', @values ).
910 $statement .= 'DEFAULT VALUES';
912 warn "[debug]$me $statement\n" if $DEBUG > 1;
913 my $sth = dbh->prepare($statement) or return dbh->errstr;
915 local $SIG{HUP} = 'IGNORE';
916 local $SIG{INT} = 'IGNORE';
917 local $SIG{QUIT} = 'IGNORE';
918 local $SIG{TERM} = 'IGNORE';
919 local $SIG{TSTP} = 'IGNORE';
920 local $SIG{PIPE} = 'IGNORE';
922 $sth->execute or return $sth->errstr;
924 # get inserted id from the database, if applicable & needed
925 if ( $db_seq && ! $self->getfield($primary_key) ) {
926 warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
930 if ( driver_name eq 'Pg' ) {
932 #my $oid = $sth->{'pg_oid_status'};
933 #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
935 my $default = $self->dbdef_table->column($primary_key)->default;
936 unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
937 dbh->rollback if $FS::UID::AutoCommit;
938 return "can't parse $table.$primary_key default value".
939 " for sequence name: $default";
943 my $i_sql = "SELECT currval('$sequence')";
944 my $i_sth = dbh->prepare($i_sql) or do {
945 dbh->rollback if $FS::UID::AutoCommit;
948 $i_sth->execute() or do { #$i_sth->execute($oid)
949 dbh->rollback if $FS::UID::AutoCommit;
950 return $i_sth->errstr;
952 $insertid = $i_sth->fetchrow_arrayref->[0];
954 } elsif ( driver_name eq 'mysql' ) {
956 $insertid = dbh->{'mysql_insertid'};
957 # work around mysql_insertid being null some of the time, ala RT :/
958 unless ( $insertid ) {
959 warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
960 "using SELECT LAST_INSERT_ID();";
961 my $i_sql = "SELECT LAST_INSERT_ID()";
962 my $i_sth = dbh->prepare($i_sql) or do {
963 dbh->rollback if $FS::UID::AutoCommit;
966 $i_sth->execute or do {
967 dbh->rollback if $FS::UID::AutoCommit;
968 return $i_sth->errstr;
970 $insertid = $i_sth->fetchrow_arrayref->[0];
975 dbh->rollback if $FS::UID::AutoCommit;
976 return "don't know how to retreive inserted ids from ". driver_name.
977 ", try using counterfiles (maybe run dbdef-create?)";
981 $self->setfield($primary_key, $insertid);
986 grep defined($self->getfield($_)) && $self->getfield($_) ne "",
987 $self->virtual_fields;
988 if (@virtual_fields) {
989 my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
991 my $vfieldpart = $self->vfieldpart_hashref;
993 my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
996 my $v_sth = dbh->prepare($v_statement) or do {
997 dbh->rollback if $FS::UID::AutoCommit;
1001 foreach (keys(%v_values)) {
1002 $v_sth->execute($self->getfield($primary_key),
1006 dbh->rollback if $FS::UID::AutoCommit;
1007 return $v_sth->errstr;
1014 if ( defined dbdef->table('h_'. $table) ) {
1015 my $h_statement = $self->_h_statement('insert');
1016 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1017 $h_sth = dbh->prepare($h_statement) or do {
1018 dbh->rollback if $FS::UID::AutoCommit;
1024 $h_sth->execute or return $h_sth->errstr if $h_sth;
1026 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1028 # Now that it has been saved, reset the encrypted fields so that $new
1029 # can still be used.
1030 foreach my $field (keys %{$saved}) {
1031 $self->setfield($field, $saved->{$field});
1039 Depriciated (use insert instead).
1044 cluck "warning: FS::Record::add deprecated!";
1045 insert @_; #call method in this scope
1050 Delete this record from the database. If there is an error, returns the error,
1051 otherwise returns false.
1058 my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1060 $self->getfield($_) eq ''
1061 #? "( $_ IS NULL OR $_ = \"\" )"
1062 ? ( driver_name eq 'Pg'
1064 : "( $_ IS NULL OR $_ = \"\" )"
1066 : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1067 } ( $self->dbdef_table->primary_key )
1068 ? ( $self->dbdef_table->primary_key)
1069 : real_fields($self->table)
1071 warn "[debug]$me $statement\n" if $DEBUG > 1;
1072 my $sth = dbh->prepare($statement) or return dbh->errstr;
1075 if ( defined dbdef->table('h_'. $self->table) ) {
1076 my $h_statement = $self->_h_statement('delete');
1077 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1078 $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1083 my $primary_key = $self->dbdef_table->primary_key;
1086 my $vfp = $self->vfieldpart_hashref;
1087 foreach($self->virtual_fields) {
1088 next if $self->getfield($_) eq '';
1089 unless(@del_vfields) {
1090 my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
1091 $v_sth = dbh->prepare($st) or return dbh->errstr;
1093 push @del_vfields, $_;
1096 local $SIG{HUP} = 'IGNORE';
1097 local $SIG{INT} = 'IGNORE';
1098 local $SIG{QUIT} = 'IGNORE';
1099 local $SIG{TERM} = 'IGNORE';
1100 local $SIG{TSTP} = 'IGNORE';
1101 local $SIG{PIPE} = 'IGNORE';
1103 my $rc = $sth->execute or return $sth->errstr;
1104 #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1105 $h_sth->execute or return $h_sth->errstr if $h_sth;
1106 $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
1107 or return $v_sth->errstr
1108 foreach (@del_vfields);
1110 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1112 #no need to needlessly destoy the data either (causes problems actually)
1113 #undef $self; #no need to keep object!
1120 Depriciated (use delete instead).
1125 cluck "warning: FS::Record::del deprecated!";
1126 &delete(@_); #call method in this scope
1129 =item replace OLD_RECORD
1131 Replace the OLD_RECORD with this one in the database. If there is an error,
1132 returns the error, otherwise returns false.
1137 my ($new, $old) = (shift, shift);
1139 $old = $new->replace_old unless defined($old);
1141 warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1143 if ( $new->can('replace_check') ) {
1144 my $error = $new->replace_check($old);
1145 return $error if $error;
1148 return "Records not in same table!" unless $new->table eq $old->table;
1150 my $primary_key = $old->dbdef_table->primary_key;
1151 return "Can't change primary key $primary_key ".
1152 'from '. $old->getfield($primary_key).
1153 ' to ' . $new->getfield($primary_key)
1155 && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1157 my $error = $new->check;
1158 return $error if $error;
1160 # Encrypt for replace
1162 if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) {
1163 foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1164 $saved->{$field} = $new->getfield($field);
1165 $new->setfield($field, $new->encrypt($new->getfield($field)));
1169 #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1170 my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1171 ? ($_, $new->getfield($_)) : () } $old->fields;
1173 unless (keys(%diff) || $no_update_diff ) {
1174 carp "[warning]$me $new -> replace $old: records identical"
1175 unless $nowarn_identical;
1179 my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1181 "$_ = ". _quote($new->getfield($_),$old->table,$_)
1182 } real_fields($old->table)
1187 if ( $old->getfield($_) eq '' ) {
1189 #false laziness w/qsearch
1190 if ( driver_name eq 'Pg' ) {
1191 my $type = $old->dbdef_table->column($_)->type;
1192 if ( $type =~ /(int|(big)?serial)/i ) {
1195 qq-( $_ IS NULL OR $_ = '' )-;
1198 qq-( $_ IS NULL OR $_ = "" )-;
1202 "$_ = ". _quote($old->getfield($_),$old->table,$_);
1205 } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1208 warn "[debug]$me $statement\n" if $DEBUG > 1;
1209 my $sth = dbh->prepare($statement) or return dbh->errstr;
1212 if ( defined dbdef->table('h_'. $old->table) ) {
1213 my $h_old_statement = $old->_h_statement('replace_old');
1214 warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1215 $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1221 if ( defined dbdef->table('h_'. $new->table) ) {
1222 my $h_new_statement = $new->_h_statement('replace_new');
1223 warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1224 $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1229 # For virtual fields we have three cases with different SQL
1230 # statements: add, replace, delete
1234 my (@add_vfields, @rep_vfields, @del_vfields);
1235 my $vfp = $old->vfieldpart_hashref;
1236 foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
1237 if($diff{$_} eq '') {
1239 unless(@del_vfields) {
1240 my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
1241 "AND vfieldpart = ?";
1242 warn "[debug]$me $st\n" if $DEBUG > 2;
1243 $v_del_sth = dbh->prepare($st) or return dbh->errstr;
1245 push @del_vfields, $_;
1246 } elsif($old->getfield($_) eq '') {
1248 unless(@add_vfields) {
1249 my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
1251 warn "[debug]$me $st\n" if $DEBUG > 2;
1252 $v_add_sth = dbh->prepare($st) or return dbh->errstr;
1254 push @add_vfields, $_;
1257 unless(@rep_vfields) {
1258 my $st = "UPDATE virtual_field SET value = ? ".
1259 "WHERE recnum = ? AND vfieldpart = ?";
1260 warn "[debug]$me $st\n" if $DEBUG > 2;
1261 $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
1263 push @rep_vfields, $_;
1267 local $SIG{HUP} = 'IGNORE';
1268 local $SIG{INT} = 'IGNORE';
1269 local $SIG{QUIT} = 'IGNORE';
1270 local $SIG{TERM} = 'IGNORE';
1271 local $SIG{TSTP} = 'IGNORE';
1272 local $SIG{PIPE} = 'IGNORE';
1274 my $rc = $sth->execute or return $sth->errstr;
1275 #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1276 $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1277 $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1279 $v_del_sth->execute($old->getfield($primary_key),
1281 or return $v_del_sth->errstr
1282 foreach(@del_vfields);
1284 $v_add_sth->execute($new->getfield($_),
1285 $old->getfield($primary_key),
1287 or return $v_add_sth->errstr
1288 foreach(@add_vfields);
1290 $v_rep_sth->execute($new->getfield($_),
1291 $old->getfield($primary_key),
1293 or return $v_rep_sth->errstr
1294 foreach(@rep_vfields);
1296 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1298 # Now that it has been saved, reset the encrypted fields so that $new
1299 # can still be used.
1300 foreach my $field (keys %{$saved}) {
1301 $new->setfield($field, $saved->{$field});
1309 my( $self ) = shift;
1310 warn "[$me] replace called with no arguments; autoloading old record\n"
1313 my $primary_key = $self->dbdef_table->primary_key;
1314 if ( $primary_key ) {
1315 $self->by_key( $self->$primary_key() ) #this is what's returned
1316 or croak "can't find ". $self->table. ".$primary_key ".
1317 $self->$primary_key();
1319 croak $self->table. " has no primary key; pass old record as argument";
1326 Depriciated (use replace instead).
1331 cluck "warning: FS::Record::rep deprecated!";
1332 replace @_; #call method in this scope
1337 Checks virtual fields (using check_blocks). Subclasses should still provide
1338 a check method to validate real fields, foreign keys, etc., and call this
1339 method via $self->SUPER::check.
1341 (FIXME: Should this method try to make sure that it I<is> being called from
1342 a subclass's check method, to keep the current semantics as far as possible?)
1347 #confess "FS::Record::check not implemented; supply one in subclass!";
1350 foreach my $field ($self->virtual_fields) {
1351 for ($self->getfield($field)) {
1352 # See notes on check_block in FS::part_virtual_field.
1353 eval $self->pvf($field)->check_block;
1355 #this is bad, probably want to follow the stack backtrace up and see
1357 my $err = "Fatal error checking $field for $self";
1359 return "$err (see log for backtrace): $@";
1362 $self->setfield($field, $_);
1368 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1370 Processes a batch import as a queued JSRPC job
1372 JOB is an FS::queue entry.
1374 OPTIONS_HASHREF can have the following keys:
1380 Table name (required).
1384 Listref of field names for static fields. They will be given values from the
1385 PARAMS hashref and passed as a "params" hashref to batch_import.
1389 Formats hashref. Keys are field names, values are listrefs that define the
1392 Each listref value can be a column name or a code reference. Coderefs are run
1393 with the row object, data and a FS::Conf object as the three parameters.
1394 For example, this coderef does the same thing as using the "columnname" string:
1397 my( $record, $data, $conf ) = @_;
1398 $record->columnname( $data );
1401 Coderefs are run after all "column name" fields are assigned.
1405 Optional format hashref of types. Keys are field names, values are "csv",
1406 "xls" or "fixedlength". Overrides automatic determination of file type
1409 =item format_headers
1411 Optional format hashref of header lines. Keys are field names, values are 0
1412 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1415 =item format_sep_chars
1417 Optional format hashref of CSV sep_chars. Keys are field names, values are the
1418 CSV separation character.
1420 =item format_fixedlenth_formats
1422 Optional format hashref of fixed length format defintiions. Keys are field
1423 names, values Parse::FixedLength listrefs of field definitions.
1427 Set true to default to CSV file type if the filename does not contain a
1428 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1433 PARAMS is a base64-encoded Storable string containing the POSTed data as
1434 a hash ref. It normally contains at least one field, "uploaded files",
1435 generated by /elements/file-upload.html and containing the list of uploaded
1436 files. Currently only supports a single file named "file".
1440 use Storable qw(thaw);
1443 sub process_batch_import {
1444 my($job, $opt) = ( shift, shift );
1446 my $table = $opt->{table};
1447 my @pass_params = @{ $opt->{params} };
1448 my %formats = %{ $opt->{formats} };
1450 my $param = thaw(decode_base64(shift));
1451 warn Dumper($param) if $DEBUG;
1453 my $files = $param->{'uploaded_files'}
1454 or die "No files provided.\n";
1456 my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1458 my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1459 my $file = $dir. $files{'file'};
1462 FS::Record::batch_import( {
1465 formats => \%formats,
1466 format_types => $opt->{format_types},
1467 format_headers => $opt->{format_headers},
1468 format_sep_chars => $opt->{format_sep_chars},
1469 format_fixedlength_formats => $opt->{format_fixedlength_formats},
1474 format => $param->{format},
1475 params => { map { $_ => $param->{$_} } @pass_params },
1477 default_csv => $opt->{default_csv},
1482 die "$error\n" if $error;
1485 =item batch_import PARAM_HASHREF
1487 Class method for batch imports. Available params:
1497 =item format_headers
1499 =item format_sep_chars
1501 =item format_fixedlength_formats
1507 FS::queue object, will be updated with progress
1513 csv, xls or fixedlength
1526 warn "$me batch_import call with params: \n". Dumper($param)
1529 my $table = $param->{table};
1530 my $formats = $param->{formats};
1532 my $job = $param->{job};
1533 my $file = $param->{file};
1534 my $format = $param->{'format'};
1535 my $params = $param->{params} || {};
1537 die "unknown format $format" unless exists $formats->{ $format };
1539 my $type = $param->{'format_types'}
1540 ? $param->{'format_types'}{ $format }
1541 : $param->{type} || 'csv';
1544 if ( $file =~ /\.(\w+)$/i ) {
1548 warn "can't parse file type from filename $file; defaulting to CSV";
1552 if $param->{'default_csv'} && $type ne 'xls';
1555 my $header = $param->{'format_headers'}
1556 ? $param->{'format_headers'}{ $param->{'format'} }
1559 my $sep_char = $param->{'format_sep_chars'}
1560 ? $param->{'format_sep_chars'}{ $param->{'format'} }
1563 my $fixedlength_format =
1564 $param->{'format_fixedlength_formats'}
1565 ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1568 my @fields = @{ $formats->{ $format } };
1574 if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1576 if ( $type eq 'csv' ) {
1579 $attr{sep_char} = $sep_char if $sep_char;
1580 $parser = new Text::CSV_XS \%attr;
1582 } elsif ( $type eq 'fixedlength' ) {
1584 eval "use Parse::FixedLength;";
1586 $parser = new Parse::FixedLength $fixedlength_format;
1589 die "Unknown file type $type\n";
1592 @buffer = split(/\r?\n/, slurp($file) );
1593 splice(@buffer, 0, ($header || 0) );
1594 $count = scalar(@buffer);
1596 } elsif ( $type eq 'xls' ) {
1598 eval "use Spreadsheet::ParseExcel;";
1601 eval "use DateTime::Format::Excel;";
1602 #for now, just let the error be thrown if it is used, since only CDR
1603 # formats bill_west and troop use it, not other excel-parsing things
1606 my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
1608 $parser = $excel->{Worksheet}[0]; #first sheet
1610 $count = $parser->{MaxRow} || $parser->{MinRow};
1613 $row = $header || 0;
1616 die "Unknown file type $type\n";
1621 local $SIG{HUP} = 'IGNORE';
1622 local $SIG{INT} = 'IGNORE';
1623 local $SIG{QUIT} = 'IGNORE';
1624 local $SIG{TERM} = 'IGNORE';
1625 local $SIG{TSTP} = 'IGNORE';
1626 local $SIG{PIPE} = 'IGNORE';
1628 my $oldAutoCommit = $FS::UID::AutoCommit;
1629 local $FS::UID::AutoCommit = 0;
1634 my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
1638 if ( $type eq 'csv' ) {
1640 last unless scalar(@buffer);
1641 $line = shift(@buffer);
1643 $parser->parse($line) or do {
1644 $dbh->rollback if $oldAutoCommit;
1645 return "can't parse: ". $parser->error_input();
1647 @columns = $parser->fields();
1649 } elsif ( $type eq 'fixedlength' ) {
1651 @columns = $parser->parse($line);
1653 } elsif ( $type eq 'xls' ) {
1655 last if $row > ($parser->{MaxRow} || $parser->{MinRow})
1656 || ! $parser->{Cells}[$row];
1658 my @row = @{ $parser->{Cells}[$row] };
1659 @columns = map $_->{Val}, @row;
1662 #warn $z++. ": $_\n" for @columns;
1665 die "Unknown file type $type\n";
1669 my %hash = %$params;
1671 foreach my $field ( @fields ) {
1673 my $value = shift @columns;
1675 if ( ref($field) eq 'CODE' ) {
1676 #&{$field}(\%hash, $value);
1677 push @later, $field, $value;
1679 #??? $hash{$field} = $value if length($value);
1680 $hash{$field} = $value if defined($value) && length($value);
1685 my $class = "FS::$table";
1687 my $record = $class->new( \%hash );
1689 while ( scalar(@later) ) {
1690 my $sub = shift @later;
1691 my $data = shift @later;
1692 &{$sub}($record, $data, $conf); # $record->&{$sub}($data, $conf);
1695 my $error = $record->insert;
1698 $dbh->rollback if $oldAutoCommit;
1699 return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
1705 if ( $job && time - $min_sec > $last ) { #progress bar
1706 $job->update_statustext( int(100 * $imported / $count) );
1712 $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
1714 return "Empty file!" unless $imported || $param->{empty_ok};
1721 my( $self, $action, $time ) = @_;
1726 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1727 real_fields($self->table);
1730 # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1731 # You can see if it changed by the paymask...
1732 if ($conf && $conf->exists('encryption') ) {
1733 @fields = grep $_ ne 'payinfo' && $_ ne 'cvv2', @fields;
1735 my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1737 "INSERT INTO h_". $self->table. " ( ".
1738 join(', ', qw(history_date history_user history_action), @fields ).
1740 join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1747 B<Warning>: External use is B<deprecated>.
1749 Replaces COLUMN in record with a unique number, using counters in the
1750 filesystem. Used by the B<insert> method on single-field unique columns
1751 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1752 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1754 Returns the new value.
1759 my($self,$field) = @_;
1760 my($table)=$self->table;
1762 croak "Unique called on field $field, but it is ",
1763 $self->getfield($field),
1765 if $self->getfield($field);
1767 #warn "table $table is tainted" if is_tainted($table);
1768 #warn "field $field is tainted" if is_tainted($field);
1770 my($counter) = new File::CounterFile "$table.$field",0;
1772 # getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1774 # my($counter) = new File::CounterFile "$user/$table.$field",0;
1777 my $index = $counter->inc;
1778 $index = $counter->inc while qsearchs($table, { $field=>$index } );
1780 $index =~ /^(\d*)$/;
1783 $self->setfield($field,$index);
1787 =item ut_float COLUMN
1789 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be
1790 null. If there is an error, returns the error, otherwise returns false.
1795 my($self,$field)=@_ ;
1796 ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
1797 $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
1798 $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
1799 $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
1800 or return "Illegal or empty (float) $field: ". $self->getfield($field);
1801 $self->setfield($field,$1);
1804 =item ut_floatn COLUMN
1806 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
1807 null. If there is an error, returns the error, otherwise returns false.
1811 #false laziness w/ut_ipn
1813 my( $self, $field ) = @_;
1814 if ( $self->getfield($field) =~ /^()$/ ) {
1815 $self->setfield($field,'');
1818 $self->ut_float($field);
1822 =item ut_sfloat COLUMN
1824 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1825 May not be null. If there is an error, returns the error, otherwise returns
1831 my($self,$field)=@_ ;
1832 ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
1833 $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
1834 $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
1835 $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
1836 or return "Illegal or empty (float) $field: ". $self->getfield($field);
1837 $self->setfield($field,$1);
1840 =item ut_sfloatn COLUMN
1842 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
1843 null. If there is an error, returns the error, otherwise returns false.
1848 my( $self, $field ) = @_;
1849 if ( $self->getfield($field) =~ /^()$/ ) {
1850 $self->setfield($field,'');
1853 $self->ut_sfloat($field);
1857 =item ut_snumber COLUMN
1859 Check/untaint signed numeric data (whole numbers). If there is an error,
1860 returns the error, otherwise returns false.
1865 my($self, $field) = @_;
1866 $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
1867 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1868 $self->setfield($field, "$1$2");
1872 =item ut_snumbern COLUMN
1874 Check/untaint signed numeric data (whole numbers). If there is an error,
1875 returns the error, otherwise returns false.
1880 my($self, $field) = @_;
1881 $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
1882 or return "Illegal (numeric) $field: ". $self->getfield($field);
1884 return "Illegal (numeric) $field: ". $self->getfield($field)
1887 $self->setfield($field, "$1$2");
1891 =item ut_number COLUMN
1893 Check/untaint simple numeric data (whole numbers). May not be null. If there
1894 is an error, returns the error, otherwise returns false.
1899 my($self,$field)=@_;
1900 $self->getfield($field) =~ /^\s*(\d+)\s*$/
1901 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1902 $self->setfield($field,$1);
1906 =item ut_numbern COLUMN
1908 Check/untaint simple numeric data (whole numbers). May be null. If there is
1909 an error, returns the error, otherwise returns false.
1914 my($self,$field)=@_;
1915 $self->getfield($field) =~ /^\s*(\d*)\s*$/
1916 or return "Illegal (numeric) $field: ". $self->getfield($field);
1917 $self->setfield($field,$1);
1921 =item ut_money COLUMN
1923 Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
1924 is an error, returns the error, otherwise returns false.
1929 my($self,$field)=@_;
1930 $self->setfield($field, 0) if $self->getfield($field) eq '';
1931 $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/
1932 or return "Illegal (money) $field: ". $self->getfield($field);
1933 #$self->setfield($field, "$1$2$3" || 0);
1934 $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
1938 =item ut_text COLUMN
1940 Check/untaint text. Alphanumerics, spaces, and the following punctuation
1941 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ]
1942 May not be null. If there is an error, returns the error, otherwise returns
1948 my($self,$field)=@_;
1949 #warn "msgcat ". \&msgcat. "\n";
1950 #warn "notexist ". \¬exist. "\n";
1951 #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
1952 $self->getfield($field)
1953 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/
1954 or return gettext('illegal_or_empty_text'). " $field: ".
1955 $self->getfield($field);
1956 $self->setfield($field,$1);
1960 =item ut_textn COLUMN
1962 Check/untaint text. Alphanumerics, spaces, and the following punctuation
1963 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
1964 May be null. If there is an error, returns the error, otherwise returns false.
1969 my($self,$field)=@_;
1970 $self->getfield($field)
1971 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/
1972 or return gettext('illegal_text'). " $field: ". $self->getfield($field);
1973 $self->setfield($field,$1);
1977 =item ut_alpha COLUMN
1979 Check/untaint alphanumeric strings (no spaces). May not be null. If there is
1980 an error, returns the error, otherwise returns false.
1985 my($self,$field)=@_;
1986 $self->getfield($field) =~ /^(\w+)$/
1987 or return "Illegal or empty (alphanumeric) $field: ".
1988 $self->getfield($field);
1989 $self->setfield($field,$1);
1993 =item ut_alpha COLUMN
1995 Check/untaint alphanumeric strings (no spaces). May be null. If there is an
1996 error, returns the error, otherwise returns false.
2001 my($self,$field)=@_;
2002 $self->getfield($field) =~ /^(\w*)$/
2003 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2004 $self->setfield($field,$1);
2008 =item ut_alpha_lower COLUMN
2010 Check/untaint lowercase alphanumeric strings (no spaces). May not be null. If
2011 there is an error, returns the error, otherwise returns false.
2015 sub ut_alpha_lower {
2016 my($self,$field)=@_;
2017 $self->getfield($field) =~ /[[:upper:]]/
2018 and return "Uppercase characters are not permitted in $field";
2019 $self->ut_alpha($field);
2022 =item ut_phonen COLUMN [ COUNTRY ]
2024 Check/untaint phone numbers. May be null. If there is an error, returns
2025 the error, otherwise returns false.
2027 Takes an optional two-letter ISO country code; without it or with unsupported
2028 countries, ut_phonen simply calls ut_alphan.
2033 my( $self, $field, $country ) = @_;
2034 return $self->ut_alphan($field) unless defined $country;
2035 my $phonen = $self->getfield($field);
2036 if ( $phonen eq '' ) {
2037 $self->setfield($field,'');
2038 } elsif ( $country eq 'US' || $country eq 'CA' ) {
2040 $phonen = $conf->config('cust_main-default_areacode').$phonen
2041 if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2042 $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2043 or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2044 $phonen = "$1-$2-$3";
2045 $phonen .= " x$4" if $4;
2046 $self->setfield($field,$phonen);
2048 warn "warning: don't know how to check phone numbers for country $country";
2049 return $self->ut_textn($field);
2056 Check/untaint hexadecimal values.
2061 my($self, $field) = @_;
2062 $self->getfield($field) =~ /^([\da-fA-F]+)$/
2063 or return "Illegal (hex) $field: ". $self->getfield($field);
2064 $self->setfield($field, uc($1));
2068 =item ut_hexn COLUMN
2070 Check/untaint hexadecimal values. May be null.
2075 my($self, $field) = @_;
2076 $self->getfield($field) =~ /^([\da-fA-F]*)$/
2077 or return "Illegal (hex) $field: ". $self->getfield($field);
2078 $self->setfield($field, uc($1));
2083 Check/untaint ip addresses. IPv4 only for now.
2088 my( $self, $field ) = @_;
2089 $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2090 or return "Illegal (IP address) $field: ". $self->getfield($field);
2091 for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2092 $self->setfield($field, "$1.$2.$3.$4");
2098 Check/untaint ip addresses. IPv4 only for now. May be null.
2103 my( $self, $field ) = @_;
2104 if ( $self->getfield($field) =~ /^()$/ ) {
2105 $self->setfield($field,'');
2108 $self->ut_ip($field);
2112 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2114 Check/untaint coordinates.
2115 Accepts the following forms:
2125 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2126 The latter form (that is, the MMM are thousands of minutes) is
2127 assumed if the "MMM" is exactly three digits or two digits > 59.
2129 To be safe, just use the DDD.DDDDD form.
2131 If LOWER or UPPER are specified, then the coordinate is checked
2132 for lower and upper bounds, respectively.
2138 my ($self, $field) = (shift, shift);
2140 my $lower = shift if scalar(@_);
2141 my $upper = shift if scalar(@_);
2142 my $coord = $self->getfield($field);
2143 my $neg = $coord =~ s/^(-)//;
2145 my ($d, $m, $s) = (0, 0, 0);
2148 (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2149 (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2150 (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2152 $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2155 return "Invalid (coordinate with minutes > 59) $field: "
2156 . $self->getfield($field);
2159 $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2161 if (defined($lower) and ($coord < $lower)) {
2162 return "Invalid (coordinate < $lower) $field: "
2163 . $self->getfield($field);;
2166 if (defined($upper) and ($coord > $upper)) {
2167 return "Invalid (coordinate > $upper) $field: "
2168 . $self->getfield($field);;
2171 $self->setfield($field, $coord);
2175 return "Invalid (coordinate) $field: " . $self->getfield($field);
2179 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2181 Same as ut_coord, except optionally null.
2187 my ($self, $field) = (shift, shift);
2189 if ($self->getfield($field) =~ /^$/) {
2192 return $self->ut_coord($field, @_);
2198 =item ut_domain COLUMN
2200 Check/untaint host and domain names.
2205 my( $self, $field ) = @_;
2206 #$self->getfield($field) =~/^(\w+\.)*\w+$/
2207 $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2208 or return "Illegal (domain) $field: ". $self->getfield($field);
2209 $self->setfield($field,$1);
2213 =item ut_name COLUMN
2215 Check/untaint proper names; allows alphanumerics, spaces and the following
2216 punctuation: , . - '
2223 my( $self, $field ) = @_;
2224 $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
2225 or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2226 $self->setfield($field,$1);
2232 Check/untaint zip codes.
2236 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2239 my( $self, $field, $country ) = @_;
2241 if ( $country eq 'US' ) {
2243 $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2244 or return gettext('illegal_zip'). " $field for country $country: ".
2245 $self->getfield($field);
2246 $self->setfield($field, $1);
2248 } elsif ( $country eq 'CA' ) {
2250 $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2251 or return gettext('illegal_zip'). " $field for country $country: ".
2252 $self->getfield($field);
2253 $self->setfield($field, "$1 $2");
2257 if ( $self->getfield($field) =~ /^\s*$/
2258 && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2261 $self->setfield($field,'');
2263 $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
2264 or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2265 $self->setfield($field,$1);
2273 =item ut_country COLUMN
2275 Check/untaint country codes. Country names are changed to codes, if possible -
2276 see L<Locale::Country>.
2281 my( $self, $field ) = @_;
2282 unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2283 if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2284 && country2code($1) ) {
2285 $self->setfield($field,uc(country2code($1)));
2288 $self->getfield($field) =~ /^(\w\w)$/
2289 or return "Illegal (country) $field: ". $self->getfield($field);
2290 $self->setfield($field,uc($1));
2294 =item ut_anything COLUMN
2296 Untaints arbitrary data. Be careful.
2301 my( $self, $field ) = @_;
2302 $self->getfield($field) =~ /^(.*)$/s
2303 or return "Illegal $field: ". $self->getfield($field);
2304 $self->setfield($field,$1);
2308 =item ut_enum COLUMN CHOICES_ARRAYREF
2310 Check/untaint a column, supplying all possible choices, like the "enum" type.
2315 my( $self, $field, $choices ) = @_;
2316 foreach my $choice ( @$choices ) {
2317 if ( $self->getfield($field) eq $choice ) {
2318 $self->setfield($choice);
2322 return "Illegal (enum) field $field: ". $self->getfield($field);
2325 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2327 Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
2328 on the column first.
2332 sub ut_foreign_key {
2333 my( $self, $field, $table, $foreign ) = @_;
2334 return '' if $no_check_foreign;
2335 qsearchs($table, { $foreign => $self->getfield($field) })
2336 or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
2337 " in $table.$foreign";
2341 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2343 Like ut_foreign_key, except the null value is also allowed.
2347 sub ut_foreign_keyn {
2348 my( $self, $field, $table, $foreign ) = @_;
2349 $self->getfield($field)
2350 ? $self->ut_foreign_key($field, $table, $foreign)
2354 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
2356 Checks this column as an agentnum, taking into account the current users's
2357 ACLs. NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
2358 right or rights allowing no agentnum.
2362 sub ut_agentnum_acl {
2363 my( $self, $field ) = (shift, shift);
2364 my $null_acl = scalar(@_) ? shift : [];
2365 $null_acl = [ $null_acl ] unless ref($null_acl);
2367 my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
2368 return "Illegal agentnum: $error" if $error;
2370 my $curuser = $FS::CurrentUser::CurrentUser;
2372 if ( $self->$field() ) {
2374 return "Access denied"
2375 unless $curuser->agentnum($self->$field());
2379 return "Access denied"
2380 unless grep $curuser->access_right($_), @$null_acl;
2388 =item virtual_fields [ TABLE ]
2390 Returns a list of virtual fields defined for the table. This should not
2391 be exported, and should only be called as an instance or class method.
2395 sub virtual_fields {
2398 $table = $self->table or confess "virtual_fields called on non-table";
2400 confess "Unknown table $table" unless dbdef->table($table);
2402 return () unless dbdef->table('part_virtual_field');
2404 unless ( $virtual_fields_cache{$table} ) {
2405 my $query = 'SELECT name from part_virtual_field ' .
2406 "WHERE dbtable = '$table'";
2408 my $result = $dbh->selectcol_arrayref($query);
2409 confess "Error executing virtual fields query: $query: ". $dbh->errstr
2411 $virtual_fields_cache{$table} = $result;
2414 @{$virtual_fields_cache{$table}};
2419 =item fields [ TABLE ]
2421 This is a wrapper for real_fields and virtual_fields. Code that called
2422 fields before should probably continue to call fields.
2427 my $something = shift;
2429 if($something->isa('FS::Record')) {
2430 $table = $something->table;
2432 $table = $something;
2433 $something = "FS::$table";
2435 return (real_fields($table), $something->virtual_fields());
2438 =item pvf FIELD_NAME
2440 Returns the FS::part_virtual_field object corresponding to a field in the
2441 record (specified by FIELD_NAME).
2446 my ($self, $name) = (shift, shift);
2448 if(grep /^$name$/, $self->virtual_fields) {
2449 return qsearchs('part_virtual_field', { dbtable => $self->table,
2455 =item vfieldpart_hashref TABLE
2457 Returns a hashref of virtual field names and vfieldparts applicable to the given
2462 sub vfieldpart_hashref {
2464 my $table = $self->table;
2466 return {} unless dbdef->table('part_virtual_field');
2469 my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
2470 "dbtable = '$table'";
2471 my $sth = $dbh->prepare($statement);
2472 $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
2473 return { map { $_->{name}, $_->{vfieldpart} }
2474 @{$sth->fetchall_arrayref({})} };
2478 =item encrypt($value)
2480 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2482 Returns the encrypted string.
2484 You should generally not have to worry about calling this, as the system handles this for you.
2489 my ($self, $value) = @_;
2492 if ($conf->exists('encryption')) {
2493 if ($self->is_encrypted($value)) {
2494 # Return the original value if it isn't plaintext.
2495 $encrypted = $value;
2498 if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2499 # RSA doesn't like the empty string so let's pack it up
2500 # The database doesn't like the RSA data so uuencode it
2501 my $length = length($value)+1;
2502 $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2504 die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2511 =item is_encrypted($value)
2513 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2519 my ($self, $value) = @_;
2520 # Possible Bug - Some work may be required here....
2522 if ($value =~ /^M/ && length($value) > 80) {
2529 =item decrypt($value)
2531 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2533 You should generally not have to worry about calling this, as the system handles this for you.
2538 my ($self,$value) = @_;
2539 my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2540 if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2542 if (ref($rsa_decrypt) =~ /::RSA/) {
2543 my $encrypted = unpack ("u*", $value);
2544 $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2545 if ($@) {warn "Decryption Failed"};
2553 #Initialize the Module
2554 $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2556 if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') {
2557 $rsa_module = $conf->config('encryptionmodule');
2561 eval ("require $rsa_module"); # No need to import the namespace
2564 # Initialize Encryption
2565 if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') {
2566 my $public_key = join("\n",$conf->config('encryptionpublickey'));
2567 $rsa_encrypt = $rsa_module->new_public_key($public_key);
2570 # Intitalize Decryption
2571 if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') {
2572 my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2573 $rsa_decrypt = $rsa_module->new_private_key($private_key);
2577 =item h_search ACTION
2579 Given an ACTION, either "insert", or "delete", returns the appropriate history
2580 record corresponding to this record, if any.
2585 my( $self, $action ) = @_;
2587 my $table = $self->table;
2590 my $primary_key = dbdef->table($table)->primary_key;
2593 'table' => "h_$table",
2594 'hashref' => { $primary_key => $self->$primary_key(),
2595 'history_action' => $action,
2603 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2604 appropriate history record corresponding to this record, if any.
2609 my($self, $action) = @_;
2610 my $h = $self->h_search($action);
2611 $h ? $h->history_date : '';
2620 =item real_fields [ TABLE ]
2622 Returns a list of the real columns in the specified table. Called only by
2623 fields() and other subroutines elsewhere in FS::Record.
2630 my($table_obj) = dbdef->table($table);
2631 confess "Unknown table $table" unless $table_obj;
2632 $table_obj->columns;
2635 =item _quote VALUE, TABLE, COLUMN
2637 This is an internal function used to construct SQL statements. It returns
2638 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2639 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2644 my($value, $table, $column) = @_;
2645 my $column_obj = dbdef->table($table)->column($column);
2646 my $column_type = $column_obj->type;
2647 my $nullable = $column_obj->null;
2649 warn " $table.$column: $value ($column_type".
2650 ( $nullable ? ' NULL' : ' NOT NULL' ).
2651 ")\n" if $DEBUG > 2;
2653 if ( $value eq '' && $nullable ) {
2655 } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2656 cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2659 } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2660 ! $column_type =~ /(char|binary|text)$/i ) {
2669 This is deprecated. Don't use it.
2671 It returns a hash-type list with the fields of this record's table set true.
2676 carp "warning: hfields is deprecated";
2679 foreach (fields($table)) {
2688 "$_: ". $self->getfield($_). "|"
2689 } (fields($self->table)) );
2692 sub DESTROY { return; }
2696 # #use Carp qw(cluck);
2697 # #cluck "DESTROYING $self";
2698 # warn "DESTROYING $self";
2702 # return ! eval { join('',@_), kill 0; 1; };
2705 =item str2time_sql [ DRIVER_NAME ]
2707 Returns a function to convert to unix time based on database type, such as
2708 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql. See
2709 the str2time_sql_closing method to return a closing string rather than just
2710 using a closing parenthesis as previously suggested.
2712 You can pass an optional driver name such as "Pg", "mysql" or
2713 $dbh->{Driver}->{Name} to return a function for that database instead of
2714 the current database.
2719 my $driver = shift || driver_name;
2721 return 'UNIX_TIMESTAMP(' if $driver =~ /^mysql/i;
2722 return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
2724 warn "warning: unknown database type $driver; guessing how to convert ".
2725 "dates to UNIX timestamps";
2726 return 'EXTRACT(EPOCH FROM ';
2730 =item str2time_sql_closing [ DRIVER_NAME ]
2732 Returns the closing suffix of a function to convert to unix time based on
2733 database type, such as ")::integer" for Pg or ")" for mysql.
2735 You can pass an optional driver name such as "Pg", "mysql" or
2736 $dbh->{Driver}->{Name} to return a function for that database instead of
2737 the current database.
2741 sub str2time_sql_closing {
2742 my $driver = shift || driver_name;
2744 return ' )::INTEGER ' if $driver =~ /^Pg/i;
2752 This module should probably be renamed, since much of the functionality is
2753 of general use. It is not completely unlike Adapter::DBI (see below).
2755 Exported qsearch and qsearchs should be deprecated in favor of method calls
2756 (against an FS::Record object like the old search and searchs that qsearch
2757 and qsearchs were on top of.)
2759 The whole fields / hfields mess should be removed.
2761 The various WHERE clauses should be subroutined.
2763 table string should be deprecated in favor of DBIx::DBSchema::Table.
2765 No doubt we could benefit from a Tied hash. Documenting how exists / defined
2766 true maps to the database (and WHERE clauses) would also help.
2768 The ut_ methods should ask the dbdef for a default length.
2770 ut_sqltype (like ut_varchar) should all be defined
2772 A fallback check method should be provided which uses the dbdef.
2774 The ut_money method assumes money has two decimal digits.
2776 The Pg money kludge in the new method only strips `$'.
2778 The ut_phonen method only checks US-style phone numbers.
2780 The _quote function should probably use ut_float instead of a regex.
2782 All the subroutines probably should be methods, here or elsewhere.
2784 Probably should borrow/use some dbdef methods where appropriate (like sub
2787 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
2788 or allow it to be set. Working around it is ugly any way around - DBI should
2789 be fixed. (only affects RDBMS which return uppercase column names)
2791 ut_zip should take an optional country like ut_phone.
2795 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
2797 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.