2 use base qw( Exporter );
6 %virtual_fields_cache %fk_method_cache
7 $money_char $lat_lower $lon_upper
9 use Carp qw(carp cluck croak confess);
10 use Scalar::Util qw( blessed );
11 use File::Slurp qw( slurp );
12 use File::CounterFile;
14 use DBI qw(:sql_types);
15 use DBIx::DBSchema 0.43; #0.43 for foreign keys
18 use NetAddr::IP; # for validation
19 use FS::UID qw(dbh 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;
30 our @encrypt_payby = qw( CARD DCRD CHEK DCHK );
32 #export dbdef for now... everything else expects to find it here
34 dbh fields hfields qsearch qsearchs dbdef jsearch
35 str2time_sql str2time_sql_closing regexp_sql not_regexp_sql
36 concat_sql group_concat_sql
41 our $me = '[FS::Record]';
43 our $nowarn_identical = 0;
44 our $nowarn_classload = 0;
45 our $no_update_diff = 0;
48 our $qsearch_qualify_columns = 1;
50 our $no_check_foreign = 1; #well, not inefficiently in perl by default anymore
58 our $conf_encryption = '';
59 FS::UID->install_callback( sub {
63 $conf = FS::Conf->new;
64 $conf_encryption = $conf->exists('encryption');
65 $money_char = $conf->config('money_char') || '$';
66 my $nw_coords = $conf->exists('geocode-require_nw_coordinates');
67 $lat_lower = $nw_coords ? 1 : -90;
68 $lon_upper = $nw_coords ? -1 : 180;
70 $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
72 if ( driver_name eq 'Pg' ) {
73 eval "use DBD::Pg ':pg_types'";
76 eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }";
79 foreach my $table ( dbdef->tables ) {
80 $fk_method_cache{$table} = fk_methods($table);
87 FS::Record - Database record objects
92 use FS::Record qw(dbh fields qsearch qsearchs);
94 $record = new FS::Record 'table', \%hash;
95 $record = new FS::Record 'table', { 'column' => 'value', ... };
97 $record = qsearchs FS::Record 'table', \%hash;
98 $record = qsearchs FS::Record 'table', { 'column' => 'value', ... };
99 @records = qsearch FS::Record 'table', \%hash;
100 @records = qsearch FS::Record 'table', { 'column' => 'value', ... };
102 $table = $record->table;
103 $dbdef_table = $record->dbdef_table;
105 $value = $record->get('column');
106 $value = $record->getfield('column');
107 $value = $record->column;
109 $record->set( 'column' => 'value' );
110 $record->setfield( 'column' => 'value' );
111 $record->column('value');
113 %hash = $record->hash;
115 $hashref = $record->hashref;
117 $error = $record->insert;
119 $error = $record->delete;
121 $error = $new_record->replace($old_record);
123 # external use deprecated - handled by the database (at least for Pg, mysql)
124 $value = $record->unique('column');
126 $error = $record->ut_float('column');
127 $error = $record->ut_floatn('column');
128 $error = $record->ut_number('column');
129 $error = $record->ut_numbern('column');
130 $error = $record->ut_decimal('column');
131 $error = $record->ut_decimaln('column');
132 $error = $record->ut_snumber('column');
133 $error = $record->ut_snumbern('column');
134 $error = $record->ut_money('column');
135 $error = $record->ut_text('column');
136 $error = $record->ut_textn('column');
137 $error = $record->ut_alpha('column');
138 $error = $record->ut_alphan('column');
139 $error = $record->ut_phonen('column');
140 $error = $record->ut_anything('column');
141 $error = $record->ut_name('column');
143 $quoted_value = _quote($value,'table','field');
146 $fields = hfields('table');
147 if ( $fields->{Field} ) { # etc.
149 @fields = fields 'table'; #as a subroutine
150 @fields = $record->fields; #as a method call
155 (Mostly) object-oriented interface to database records. Records are currently
156 implemented on top of DBI. FS::Record is intended as a base class for
157 table-specific classes to inherit from, i.e. FS::cust_main.
163 =item new [ TABLE, ] HASHREF
165 Creates a new record. It doesn't store it in the database, though. See
166 L<"insert"> for that.
168 Note that the object stores this hash reference, not a distinct copy of the
169 hash it points to. You can ask the object for a copy with the I<hash>
172 TABLE can only be omitted when a dervived class overrides the table method.
178 my $class = ref($proto) || $proto;
180 bless ($self, $class);
182 unless ( defined ( $self->table ) ) {
183 $self->{'Table'} = shift;
184 carp "warning: FS::Record::new called with table name ". $self->{'Table'}
185 unless $nowarn_classload;
188 $self->{'Hash'} = shift;
190 foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
191 $self->{'Hash'}{$field}='';
194 $self->_rebless if $self->can('_rebless');
196 $self->{'modified'} = 0;
198 $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
205 my $class = ref($proto) || $proto;
207 bless ($self, $class);
209 $self->{'Table'} = shift unless defined ( $self->table );
211 my $hashref = $self->{'Hash'} = shift;
213 if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
214 my $obj = $cache->cache->{$hashref->{$cache->key}};
215 $obj->_cache($hashref, $cache) if $obj->can('_cache');
218 $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
225 my $class = ref($proto) || $proto;
227 bless ($self, $class);
228 if ( defined $self->table ) {
229 cluck "create constructor is deprecated, use new!";
232 croak "FS::Record::create called (not from a subclass)!";
236 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
238 Searches the database for all records matching (at least) the key/value pairs
239 in HASHREF. Returns all the records found as `FS::TABLE' objects if that
240 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
243 The preferred usage is to pass a hash reference of named parameters:
245 @records = qsearch( {
246 'table' => 'table_name',
247 'hashref' => { 'field' => 'value'
248 'field' => { 'op' => '<',
253 #these are optional...
255 'extra_sql' => 'AND field = ? AND intfield = ?',
256 'extra_param' => [ 'value', [ 5, 'int' ] ],
257 'order_by' => 'ORDER BY something',
258 #'cache_obj' => '', #optional
259 'addl_from' => 'LEFT JOIN othtable USING ( field )',
264 Much code still uses old-style positional parameters, this is also probably
265 fine in the common case where there are only two parameters:
267 my @records = qsearch( 'table', { 'field' => 'value' } );
269 Also possible is an experimental LISTREF of PARAMS_HASHREFs for a UNION of
270 the individual PARAMS_HASHREF queries
272 ###oops, argh, FS::Record::new only lets us create database fields.
273 #Normal behaviour if SELECT is not specified is `*', as in
274 #C<SELECT * FROM table WHERE ...>. However, there is an experimental new
275 #feature where you can specify SELECT - remember, the objects returned,
276 #although blessed into the appropriate `FS::TABLE' package, will only have the
277 #fields you specify. This might have unwanted results if you then go calling
278 #regular FS::TABLE methods
283 my %TYPE = (); #for debugging
286 my($type, $value) = @_;
288 my $bind_type = { TYPE => SQL_VARCHAR };
290 if ( $type =~ /(big)?(int|serial)/i && $value =~ /^-?\d+(\.\d+)?$/ ) {
292 $bind_type = { TYPE => SQL_INTEGER };
294 } elsif ( $type =~ /^bytea$/i || $type =~ /(blob|varbinary)/i ) {
296 if ( driver_name eq 'Pg' ) {
298 $bind_type = { pg_type => PG_BYTEA };
300 # $bind_type = ? #SQL_VARCHAR could be fine?
303 #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT
304 #fixed by DBD::Pg 2.11.8
305 #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded
306 #(make a Tron test first)
307 } elsif ( _is_fs_float( $type, $value ) ) {
309 $bind_type = { TYPE => SQL_DECIMAL };
318 my($type, $value) = @_;
319 if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) ||
320 ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/)
328 my( @stable, @record, @cache );
329 my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
331 my %union_options = ();
332 if ( ref($_[0]) eq 'ARRAY' ) {
335 foreach my $href ( @$optlist ) {
336 push @stable, ( $href->{'table'} or die "table name is required" );
337 push @record, ( $href->{'hashref'} || {} );
338 push @select, ( $href->{'select'} || '*' );
339 push @extra_sql, ( $href->{'extra_sql'} || '' );
340 push @extra_param, ( $href->{'extra_param'} || [] );
341 push @order_by, ( $href->{'order_by'} || '' );
342 push @cache, ( $href->{'cache_obj'} || '' );
343 push @addl_from, ( $href->{'addl_from'} || '' );
344 push @debug, ( $href->{'debug'} || '' );
346 die "at least one hashref is required" unless scalar(@stable);
347 } elsif ( ref($_[0]) eq 'HASH' ) {
349 $stable[0] = $opt->{'table'} or die "table name is required";
350 $record[0] = $opt->{'hashref'} || {};
351 $select[0] = $opt->{'select'} || '*';
352 $extra_sql[0] = $opt->{'extra_sql'} || '';
353 $extra_param[0] = $opt->{'extra_param'} || [];
354 $order_by[0] = $opt->{'order_by'} || '';
355 $cache[0] = $opt->{'cache_obj'} || '';
356 $addl_from[0] = $opt->{'addl_from'} || '';
357 $debug[0] = $opt->{'debug'} || '';
368 my $cache = $cache[0];
374 foreach my $stable ( @stable ) {
376 carp '->qsearch on cust_main called' if $stable eq 'cust_main' && $DEBUG;
378 #stop altering the caller's hashref
379 my $record = { %{ shift(@record) || {} } };#and be liberal in receipt
380 my $select = shift @select;
381 my $extra_sql = shift @extra_sql;
382 my $extra_param = shift @extra_param;
383 my $order_by = shift @order_by;
384 my $cache = shift @cache;
385 my $addl_from = shift @addl_from;
386 my $debug = shift @debug;
388 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
390 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
393 my $table = $cache ? $cache->table : $stable;
394 my $dbdef_table = dbdef->table($table)
395 or die "No schema for table $table found - ".
396 "do you need to run freeside-upgrade?";
397 my $pkey = $dbdef_table->primary_key;
399 my @real_fields = grep exists($record->{$_}), real_fields($table);
401 my $statement .= "SELECT $select FROM $stable";
402 $statement .= " $addl_from" if $addl_from;
403 if ( @real_fields ) {
404 $statement .= ' WHERE '. join(' AND ',
405 get_real_fields($table, $record, \@real_fields));
408 $statement .= " $extra_sql" if defined($extra_sql);
409 $statement .= " $order_by" if defined($order_by);
411 push @statement, $statement;
413 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
416 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
419 my $value = $record->{$field};
420 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
421 $value = $value->{'value'} if ref($value);
422 my $type = dbdef->table($table)->column($field)->type;
424 my $bind_type = _bind_type($type, $value);
428 # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
430 # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
434 push @bind_type, $bind_type;
438 foreach my $param ( @$extra_param ) {
439 my $bind_type = { TYPE => SQL_VARCHAR };
442 $value = $param->[0];
443 my $type = $param->[1];
444 $bind_type = _bind_type($type, $value);
447 push @bind_type, $bind_type;
451 my $statement = join( ' ) UNION ( ', @statement );
452 $statement = "( $statement )" if scalar(@statement) > 1;
453 $statement .= " $union_options{order_by}" if $union_options{order_by};
455 my $sth = $dbh->prepare($statement)
456 or croak "$dbh->errstr doing $statement";
459 foreach my $value ( @value ) {
460 my $bind_type = shift @bind_type;
461 $sth->bind_param($bind++, $value, $bind_type );
464 # $sth->execute( map $record->{$_},
465 # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
466 # ) or croak "Error executing \"$statement\": ". $sth->errstr;
468 my $ok = $sth->execute;
470 my $error = "Error executing \"$statement\"";
471 $error .= ' (' . join(', ', map {"'$_'"} @value) . ')' if @value;
472 $error .= ': '. $sth->errstr;
476 my $table = $stable[0];
478 $table = '' if grep { $_ ne $table } @stable;
479 $pkey = dbdef->table($table)->primary_key if $table;
482 tie %result, "Tie::IxHash";
483 my @stuff = @{ $sth->fetchall_arrayref( {} ) };
484 if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
485 %result = map { $_->{$pkey}, $_ } @stuff;
487 @result{@stuff} = @stuff;
493 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
494 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
495 #derivied class didn't override new method, so this optimization is safe
498 new_or_cached( "FS::$table", { %{$_} }, $cache )
502 new( "FS::$table", { %{$_} } )
506 #okay, its been tested
507 # warn "untested code (class FS::$table uses custom new method)";
509 eval 'FS::'. $table. '->new( { %{$_} } )';
513 # Check for encrypted fields and decrypt them.
514 ## only in the local copy, not the cached object
515 if ( $conf_encryption
516 && eval '@FS::'. $table . '::encrypted_fields' ) {
517 foreach my $record (@return) {
518 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
519 next if $field eq 'payinfo'
520 && ($record->isa('FS::payinfo_transaction_Mixin')
521 || $record->isa('FS::payinfo_Mixin') )
523 && !grep { $record->payby eq $_ } @encrypt_payby;
524 # Set it directly... This may cause a problem in the future...
525 $record->setfield($field, $record->decrypt($record->getfield($field)));
530 cluck "warning: FS::$table not loaded; returning FS::Record objects"
531 unless $nowarn_classload;
533 FS::Record->new( $table, { %{$_} } );
541 Construct the SQL statement and parameter-binding list for qsearch. Takes
542 the qsearch parameters.
544 Returns a hash containing:
545 'table': The primary table name (if there is one).
546 'statement': The SQL statement itself.
547 'bind_type': An arrayref of bind types.
548 'value': An arrayref of parameter values.
549 'cache': The cache object, if one was passed.
554 my( @stable, @record, @cache );
555 my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
558 my %union_options = ();
559 if ( ref($_[0]) eq 'ARRAY' ) {
562 foreach my $href ( @$optlist ) {
563 push @stable, ( $href->{'table'} or die "table name is required" );
564 push @record, ( $href->{'hashref'} || {} );
565 push @select, ( $href->{'select'} || '*' );
566 push @extra_sql, ( $href->{'extra_sql'} || '' );
567 push @extra_param, ( $href->{'extra_param'} || [] );
568 push @order_by, ( $href->{'order_by'} || '' );
569 push @cache, ( $href->{'cache_obj'} || '' );
570 push @addl_from, ( $href->{'addl_from'} || '' );
571 push @debug, ( $href->{'debug'} || '' );
573 die "at least one hashref is required" unless scalar(@stable);
574 } elsif ( ref($_[0]) eq 'HASH' ) {
576 $stable[0] = $opt->{'table'} or die "table name is required";
577 $record[0] = $opt->{'hashref'} || {};
578 $select[0] = $opt->{'select'} || '*';
579 $extra_sql[0] = $opt->{'extra_sql'} || '';
580 $extra_param[0] = $opt->{'extra_param'} || [];
581 $order_by[0] = $opt->{'order_by'} || '';
582 $cache[0] = $opt->{'cache_obj'} || '';
583 $addl_from[0] = $opt->{'addl_from'} || '';
584 $debug[0] = $opt->{'debug'} || '';
595 my $cache = $cache[0];
601 my $result_table = $stable[0];
602 foreach my $stable ( @stable ) {
603 #stop altering the caller's hashref
604 my $record = { %{ shift(@record) || {} } };#and be liberal in receipt
605 my $select = shift @select;
606 my $extra_sql = shift @extra_sql;
607 my $extra_param = shift @extra_param;
608 my $order_by = shift @order_by;
609 my $cache = shift @cache;
610 my $addl_from = shift @addl_from;
611 my $debug = shift @debug;
613 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
615 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
618 $result_table = '' if $result_table ne $stable;
620 my $table = $cache ? $cache->table : $stable;
621 my $dbdef_table = dbdef->table($table)
622 or die "No schema for table $table found - ".
623 "do you need to run freeside-upgrade?";
624 my $pkey = $dbdef_table->primary_key;
626 my @real_fields = grep exists($record->{$_}), real_fields($table);
628 my $statement .= "SELECT $select FROM $stable";
629 $statement .= " $addl_from" if $addl_from;
630 if ( @real_fields ) {
631 $statement .= ' WHERE '. join(' AND ',
632 get_real_fields($table, $record, \@real_fields));
635 $statement .= " $extra_sql" if defined($extra_sql);
636 $statement .= " $order_by" if defined($order_by);
638 push @statement, $statement;
640 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
644 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
647 my $value = $record->{$field};
648 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
649 $value = $value->{'value'} if ref($value);
650 my $type = dbdef->table($table)->column($field)->type;
652 my $bind_type = _bind_type($type, $value);
656 # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
658 # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
662 push @bind_type, $bind_type;
666 foreach my $param ( @$extra_param ) {
667 my $bind_type = { TYPE => SQL_VARCHAR };
670 $value = $param->[0];
671 my $type = $param->[1];
672 $bind_type = _bind_type($type, $value);
675 push @bind_type, $bind_type;
679 my $statement = join( ' ) UNION ( ', @statement );
680 $statement = "( $statement )" if scalar(@statement) > 1;
681 $statement .= " $union_options{order_by}" if $union_options{order_by};
684 statement => $statement,
685 bind_type => \@bind_type,
687 table => $result_table,
692 # qsearch should eventually use this
694 my ($table, $cache, @hashrefs) = @_;
696 # XXX get rid of these string evals at some point
697 # (when we have time to test it)
698 # my $class = "FS::$table" if $table;
699 # if ( $class and $class->isa('FS::Record') )
700 # if ( $class->can('new') eq \&new )
702 if ( $table && eval 'scalar(@FS::'. $table. '::ISA);' ) {
703 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
704 #derivied class didn't override new method, so this optimization is safe
707 new_or_cached( "FS::$table", { %{$_} }, $cache )
711 new( "FS::$table", { %{$_} } )
715 #okay, its been tested
716 # warn "untested code (class FS::$table uses custom new method)";
718 eval 'FS::'. $table. '->new( { %{$_} } )';
722 # Check for encrypted fields and decrypt them.
723 ## only in the local copy, not the cached object
724 if ( $conf_encryption
725 && eval '@FS::'. $table . '::encrypted_fields' ) {
726 foreach my $record (@return) {
727 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
728 next if $field eq 'payinfo'
729 && ($record->isa('FS::payinfo_transaction_Mixin')
730 || $record->isa('FS::payinfo_Mixin') )
732 && !grep { $record->payby eq $_ } @encrypt_payby;
733 # Set it directly... This may cause a problem in the future...
734 $record->setfield($field, $record->decrypt($record->getfield($field)));
739 cluck "warning: FS::$table not loaded; returning FS::Record objects"
740 unless $nowarn_classload;
742 FS::Record->new( $table, { %{$_} } );
748 sub get_real_fields {
751 my $real_fields = shift;
753 ## could be optimized more for readability
759 my $table_column = $qsearch_qualify_columns ? "$table.$column" : $column;
760 my $type = dbdef->table($table)->column($column)->type;
761 my $value = $record->{$column};
762 $value = $value->{'value'} if ref($value);
764 if ( ref($record->{$column}) ) {
765 $op = $record->{$column}{'op'} if $record->{$column}{'op'};
766 #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
767 if ( uc($op) eq 'ILIKE' ) {
769 $record->{$column}{'value'} = lc($record->{$column}{'value'});
770 $table_column = "LOWER($table_column)";
772 $record->{$column} = $record->{$column}{'value'}
775 if ( ! defined( $record->{$column} ) || $record->{$column} eq '' ) {
777 if ( driver_name eq 'Pg' ) {
778 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
779 qq-( $table_column IS NULL )-;
781 qq-( $table_column IS NULL OR $table_column = '' )-;
784 qq-( $table_column IS NULL OR $table_column = "" )-;
786 } elsif ( $op eq '!=' ) {
787 if ( driver_name eq 'Pg' ) {
788 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
789 qq-( $table_column IS NOT NULL )-;
791 qq-( $table_column IS NOT NULL AND $table_column != '' )-;
794 qq-( $table_column IS NOT NULL AND $table_column != "" )-;
797 if ( driver_name eq 'Pg' ) {
798 qq-( $table_column $op '' )-;
800 qq-( $table_column $op "" )-;
803 } elsif ( $op eq '!=' ) {
804 qq-( $table_column IS NULL OR $table_column != ? )-;
805 #if this needs to be re-enabled, it needs to use a custom op like
806 #"APPROX=" or something (better name?, not '=', to avoid affecting other
808 #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
809 # ( "$table_column <= ?", "$table_column >= ?" );
811 "$table_column $op ?";
818 =item by_key PRIMARY_KEY_VALUE
820 This is a class method that returns the record with the given primary key
821 value. This method is only useful in FS::Record subclasses. For example:
823 my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
827 my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
832 my ($class, $pkey_value) = @_;
834 my $table = $class->table
835 or croak "No table for $class found";
837 my $dbdef_table = dbdef->table($table)
838 or die "No schema for table $table found - ".
839 "do you need to create it or run dbdef-create?";
840 my $pkey = $dbdef_table->primary_key
841 or die "No primary key for table $table";
843 return qsearchs($table, { $pkey => $pkey_value });
846 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
848 Experimental JOINed search method. Using this method, you can execute a
849 single SELECT spanning multiple tables, and cache the results for subsequent
850 method calls. Interface will almost definately change in an incompatible
858 my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
859 my $cache = FS::SearchCache->new( $ptable, $pkey );
862 grep { !$saw{$_->getfield($pkey)}++ }
863 qsearch($table, $record, $select, $extra_sql, $cache )
867 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
869 Same as qsearch, except that if more than one record matches, it B<carp>s but
870 returns the first. If this happens, you either made a logic error in asking
871 for a single item, or your data is corrupted.
875 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
877 my(@result) = qsearch(@_);
878 cluck "warning: Multiple records in scalar search ($table)"
879 #.join(' / ', map "$_=>".$_[1]->{$_}, keys %{ $_[1] } )
880 if scalar(@result) > 1;
881 #should warn more vehemently if the search was on a primary key?
882 scalar(@result) ? ($result[0]) : ();
893 Returns the table name.
898 # cluck "warning: FS::Record::table deprecated; supply one in subclass!";
905 Returns the DBIx::DBSchema::Table object for the table.
911 my($table)=$self->table;
912 dbdef->table($table);
917 Returns the primary key for the table.
923 my $pkey = $self->dbdef_table->primary_key;
926 =item get, getfield COLUMN
928 Returns the value of the column/field/key COLUMN.
933 my($self,$field) = @_;
934 # to avoid "Use of unitialized value" errors
935 if ( defined ( $self->{Hash}->{$field} ) ) {
936 $self->{Hash}->{$field};
946 =item set, setfield COLUMN, VALUE
948 Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE.
953 my($self,$field,$value) = @_;
954 $self->{'modified'} = 1;
955 $self->{'Hash'}->{$field} = $value;
964 Returns true if the column/field/key COLUMN exists.
969 my($self,$field) = @_;
970 exists($self->{Hash}->{$field});
973 =item AUTLOADED METHODS
975 $record->column is a synonym for $record->get('column');
977 $record->column('value') is a synonym for $record->set('column','value');
979 $record->foreign_table_name calls qsearchs and returns a single
980 FS::foreign_table record (for tables referenced by a column of this table) or
981 qsearch and returns an array of FS::foreign_table records (for tables
982 referenced by a column in the foreign table).
989 my($field)=$AUTOLOAD;
992 confess "errant AUTOLOAD $field for $self (arg $value)"
993 unless blessed($self) && $self->can('setfield');
995 #$fk_method_cache{$self->table} ||= fk_methods($self->table);
996 if ( exists($fk_method_cache{$self->table}->{$field}) ) {
998 my $fk_info = $fk_method_cache{$self->table}->{$field};
999 my $method = $fk_info->{method} || 'qsearchs';
1000 my $table = $fk_info->{table} || $field;
1001 my $column = $fk_info->{column};
1002 my $foreign_column = $fk_info->{references} || $column;
1004 eval "use FS::$table";
1007 carp '->cust_main called' if $table eq 'cust_main' && $DEBUG;
1009 my $pkey_value = $self->$column();
1010 my %search = ( $foreign_column => $pkey_value );
1012 # FS::Record->$method() ? they're actually just subs :/
1013 if ( $method eq 'qsearchs' ) {
1014 return $pkey_value ? qsearchs( $table, \%search ) : '';
1015 } elsif ( $method eq 'qsearch' ) {
1016 return $pkey_value ? qsearch( $table, \%search ) : ();
1018 die "unknown method $method";
1023 if ( defined($value) ) {
1024 $self->setfield($field,$value);
1026 $self->getfield($field);
1030 # efficient (also, old, doesn't support FK stuff)
1032 # my $field = $AUTOLOAD;
1033 # $field =~ s/.*://;
1034 # if ( defined($_[1]) ) {
1035 # $_[0]->setfield($field, $_[1]);
1037 # $_[0]->getfield($field);
1046 # foreign keys we reference in other tables
1047 foreach my $fk (dbdef->table($table)->foreign_keys) {
1050 if ( scalar( @{$fk->columns} ) == 1 ) {
1051 if ( ! defined($fk->references)
1052 || ! @{$fk->references}
1053 || $fk->columns->[0] eq $fk->references->[0]
1055 $method = $fk->table;
1057 #some sort of hint in the table.pm or schema for methods not named
1058 # after their foreign table (well, not a whole lot different than
1059 # just providing a small subroutine...)
1063 $hash{$method} = { #fk_info
1064 'method' => 'qsearchs',
1065 'column' => $fk->columns->[0],
1066 #'references' => $fk->references->[0],
1074 # foreign keys referenced in other tables to us
1075 # (alas. why we're cached. still, might this loop better be done once at
1076 # schema load time insetad of every time we AUTOLOAD a method on a new
1078 foreach my $f_table ( dbdef->tables ) {
1079 foreach my $fk (dbdef->table($f_table)->foreign_keys) {
1081 next unless $fk->table eq $table;
1084 if ( scalar( @{$fk->columns} ) == 1 ) {
1085 if ( ! defined($fk->references)
1086 || ! @{$fk->references}
1087 || $fk->columns->[0] eq $fk->references->[0]
1091 #some sort of hint in the table.pm or schema for methods not named
1092 # after their foreign table (well, not a whole lot different than
1093 # just providing a small subroutine...)
1097 $hash{$method} = { #fk_info
1098 'method' => 'qsearch',
1099 'column' => $fk->columns->[0], #references||column
1100 #'references' => $fk->column->[0],
1115 Returns a list of the column/value pairs, usually for assigning to a new hash.
1117 To make a distinct duplicate of an FS::Record object, you can do:
1119 $new = new FS::Record ( $old->table, { $old->hash } );
1125 confess $self. ' -> hash: Hash attribute is undefined'
1126 unless defined($self->{'Hash'});
1127 %{ $self->{'Hash'} };
1132 Returns a reference to the column/value hash. This may be deprecated in the
1133 future; if there's a reason you can't just use the autoloaded or get/set
1147 +{ ( map { $_=>$self->$_ } $self->fields ),
1152 my( $class, %opt ) = @_;
1153 my $table = $class->table;
1154 my $self = $class->new( { map { $_ => $opt{$_} } fields($table) } );
1155 my $error = $self->insert;
1156 return +{ 'error' => $error } if $error;
1157 my $pkey = $self->pkey;
1158 return +{ 'error' => '',
1159 'primary_key' => $pkey,
1160 $pkey => $self->$pkey,
1166 Returns true if any of this object's values have been modified with set (or via
1167 an autoloaded method). Doesn't yet recognize when you retreive a hashref and
1174 $self->{'modified'};
1177 =item select_for_update
1179 Selects this record with the SQL "FOR UPDATE" command. This can be useful as
1184 sub select_for_update {
1186 my $primary_key = $self->primary_key;
1189 'table' => $self->table,
1190 'hashref' => { $primary_key => $self->$primary_key() },
1191 'extra_sql' => 'FOR UPDATE',
1197 Locks this table with a database-driver specific lock method. This is used
1198 as a mutex in order to do a duplicate search.
1200 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
1202 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
1204 Errors are fatal; no useful return value.
1206 Note: To use this method for new tables other than svc_acct and svc_phone,
1207 edit freeside-upgrade and add those tables to the duplicate_lock list.
1213 my $table = $self->table;
1215 warn "$me locking $table table\n" if $DEBUG;
1217 if ( driver_name =~ /^Pg/i ) {
1219 dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
1222 } elsif ( driver_name =~ /^mysql/i ) {
1224 dbh->do("SELECT * FROM duplicate_lock
1225 WHERE lockname = '$table'
1227 ) or die dbh->errstr;
1231 die "unknown database ". driver_name. "; don't know how to lock table";
1235 warn "$me acquired $table table lock\n" if $DEBUG;
1241 Inserts this record to the database. If there is an error, returns the error,
1242 otherwise returns false.
1250 warn "$self -> insert" if $DEBUG;
1252 my $error = $self->check;
1253 return $error if $error;
1255 #single-field non-null unique keys are given a value if empty
1256 #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
1257 foreach ( $self->dbdef_table->unique_singles) {
1258 next if $self->getfield($_);
1259 next if $self->dbdef_table->column($_)->null eq 'NULL';
1263 #and also the primary key, if the database isn't going to
1264 my $primary_key = $self->dbdef_table->primary_key;
1266 if ( $primary_key ) {
1267 my $col = $self->dbdef_table->column($primary_key);
1270 uc($col->type) =~ /^(BIG)?SERIAL\d?/
1271 || ( driver_name eq 'Pg'
1272 && defined($col->default)
1273 && $col->quoted_default =~ /^nextval\(/i
1275 || ( driver_name eq 'mysql'
1276 && defined($col->local)
1277 && $col->local =~ /AUTO_INCREMENT/i
1279 $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
1282 my $table = $self->table;
1284 # Encrypt before the database
1285 if ( defined(eval '@FS::'. $table . '::encrypted_fields')
1286 && scalar( eval '@FS::'. $table . '::encrypted_fields')
1287 && $conf->exists('encryption')
1289 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
1290 next if $field eq 'payinfo'
1291 && ($self->isa('FS::payinfo_transaction_Mixin')
1292 || $self->isa('FS::payinfo_Mixin') )
1294 && !grep { $self->payby eq $_ } @encrypt_payby;
1295 $saved->{$field} = $self->getfield($field);
1296 $self->setfield($field, $self->encrypt($self->getfield($field)));
1300 #false laziness w/delete
1302 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1305 my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
1308 my $statement = "INSERT INTO $table ";
1309 if ( @real_fields ) {
1312 join( ', ', @real_fields ).
1314 join( ', ', @values ).
1318 $statement .= 'DEFAULT VALUES';
1320 warn "[debug]$me $statement\n" if $DEBUG > 1;
1321 my $sth = dbh->prepare($statement) or return dbh->errstr;
1323 local $SIG{HUP} = 'IGNORE';
1324 local $SIG{INT} = 'IGNORE';
1325 local $SIG{QUIT} = 'IGNORE';
1326 local $SIG{TERM} = 'IGNORE';
1327 local $SIG{TSTP} = 'IGNORE';
1328 local $SIG{PIPE} = 'IGNORE';
1330 $sth->execute or return $sth->errstr;
1332 # get inserted id from the database, if applicable & needed
1333 if ( $db_seq && ! $self->getfield($primary_key) ) {
1334 warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
1338 if ( driver_name eq 'Pg' ) {
1340 #my $oid = $sth->{'pg_oid_status'};
1341 #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
1343 my $default = $self->dbdef_table->column($primary_key)->quoted_default;
1344 unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
1345 dbh->rollback if $FS::UID::AutoCommit;
1346 return "can't parse $table.$primary_key default value".
1347 " for sequence name: $default";
1351 my $i_sql = "SELECT currval('$sequence')";
1352 my $i_sth = dbh->prepare($i_sql) or do {
1353 dbh->rollback if $FS::UID::AutoCommit;
1356 $i_sth->execute() or do { #$i_sth->execute($oid)
1357 dbh->rollback if $FS::UID::AutoCommit;
1358 return $i_sth->errstr;
1360 $insertid = $i_sth->fetchrow_arrayref->[0];
1362 } elsif ( driver_name eq 'mysql' ) {
1364 $insertid = dbh->{'mysql_insertid'};
1365 # work around mysql_insertid being null some of the time, ala RT :/
1366 unless ( $insertid ) {
1367 warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
1368 "using SELECT LAST_INSERT_ID();";
1369 my $i_sql = "SELECT LAST_INSERT_ID()";
1370 my $i_sth = dbh->prepare($i_sql) or do {
1371 dbh->rollback if $FS::UID::AutoCommit;
1374 $i_sth->execute or do {
1375 dbh->rollback if $FS::UID::AutoCommit;
1376 return $i_sth->errstr;
1378 $insertid = $i_sth->fetchrow_arrayref->[0];
1383 dbh->rollback if $FS::UID::AutoCommit;
1384 return "don't know how to retreive inserted ids from ". driver_name.
1385 ", try using counterfiles (maybe run dbdef-create?)";
1389 $self->setfield($primary_key, $insertid);
1394 if ( defined( dbdef->table('h_'. $table) ) && ! $no_history ) {
1395 my $h_statement = $self->_h_statement('insert');
1396 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1397 $h_sth = dbh->prepare($h_statement) or do {
1398 dbh->rollback if $FS::UID::AutoCommit;
1404 $h_sth->execute or return $h_sth->errstr if $h_sth;
1406 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1408 # Now that it has been saved, reset the encrypted fields so that $new
1409 # can still be used.
1410 foreach my $field (keys %{$saved}) {
1411 $self->setfield($field, $saved->{$field});
1419 Depriciated (use insert instead).
1424 cluck "warning: FS::Record::add deprecated!";
1425 insert @_; #call method in this scope
1430 Delete this record from the database. If there is an error, returns the error,
1431 otherwise returns false.
1438 my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1440 $self->getfield($_) eq ''
1441 #? "( $_ IS NULL OR $_ = \"\" )"
1442 ? ( driver_name eq 'Pg'
1444 : "( $_ IS NULL OR $_ = \"\" )"
1446 : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1447 } ( $self->dbdef_table->primary_key )
1448 ? ( $self->dbdef_table->primary_key)
1449 : real_fields($self->table)
1451 warn "[debug]$me $statement\n" if $DEBUG > 1;
1452 my $sth = dbh->prepare($statement) or return dbh->errstr;
1455 if ( defined dbdef->table('h_'. $self->table) ) {
1456 my $h_statement = $self->_h_statement('delete');
1457 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1458 $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1463 my $primary_key = $self->dbdef_table->primary_key;
1465 local $SIG{HUP} = 'IGNORE';
1466 local $SIG{INT} = 'IGNORE';
1467 local $SIG{QUIT} = 'IGNORE';
1468 local $SIG{TERM} = 'IGNORE';
1469 local $SIG{TSTP} = 'IGNORE';
1470 local $SIG{PIPE} = 'IGNORE';
1472 my $rc = $sth->execute or return $sth->errstr;
1473 #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1474 $h_sth->execute or return $h_sth->errstr if $h_sth;
1476 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1478 #no need to needlessly destoy the data either (causes problems actually)
1479 #undef $self; #no need to keep object!
1486 Depriciated (use delete instead).
1491 cluck "warning: FS::Record::del deprecated!";
1492 &delete(@_); #call method in this scope
1495 =item replace OLD_RECORD
1497 Replace the OLD_RECORD with this one in the database. If there is an error,
1498 returns the error, otherwise returns false.
1503 my ($new, $old) = (shift, shift);
1505 $old = $new->replace_old unless defined($old);
1507 warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1509 if ( $new->can('replace_check') ) {
1510 my $error = $new->replace_check($old);
1511 return $error if $error;
1514 return "Records not in same table!" unless $new->table eq $old->table;
1516 my $primary_key = $old->dbdef_table->primary_key;
1517 return "Can't change primary key $primary_key ".
1518 'from '. $old->getfield($primary_key).
1519 ' to ' . $new->getfield($primary_key)
1521 && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1523 my $error = $new->check;
1524 return $error if $error;
1526 # Encrypt for replace
1528 if ( $conf->exists('encryption')
1529 && defined(eval '@FS::'. $new->table . '::encrypted_fields')
1530 && scalar( eval '@FS::'. $new->table . '::encrypted_fields')
1532 foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1533 next if $field eq 'payinfo'
1534 && ($new->isa('FS::payinfo_transaction_Mixin')
1535 || $new->isa('FS::payinfo_Mixin') )
1537 && !grep { $new->payby eq $_ } @encrypt_payby;
1538 $saved->{$field} = $new->getfield($field);
1539 $new->setfield($field, $new->encrypt($new->getfield($field)));
1543 #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1544 my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1545 ? ($_, $new->getfield($_)) : () } $old->fields;
1547 unless (keys(%diff) || $no_update_diff ) {
1548 carp "[warning]$me ". ref($new)."->replace ".
1549 ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
1550 ": records identical"
1551 unless $nowarn_identical;
1555 my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1557 "$_ = ". _quote($new->getfield($_),$old->table,$_)
1558 } real_fields($old->table)
1563 if ( $old->getfield($_) eq '' ) {
1565 #false laziness w/qsearch
1566 if ( driver_name eq 'Pg' ) {
1567 my $type = $old->dbdef_table->column($_)->type;
1568 if ( $type =~ /(int|(big)?serial)/i ) {
1571 qq-( $_ IS NULL OR $_ = '' )-;
1574 qq-( $_ IS NULL OR $_ = "" )-;
1578 "$_ = ". _quote($old->getfield($_),$old->table,$_);
1581 } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1584 warn "[debug]$me $statement\n" if $DEBUG > 1;
1585 my $sth = dbh->prepare($statement) or return dbh->errstr;
1588 if ( defined dbdef->table('h_'. $old->table) ) {
1589 my $h_old_statement = $old->_h_statement('replace_old');
1590 warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1591 $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1597 if ( defined dbdef->table('h_'. $new->table) ) {
1598 my $h_new_statement = $new->_h_statement('replace_new');
1599 warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1600 $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1605 local $SIG{HUP} = 'IGNORE';
1606 local $SIG{INT} = 'IGNORE';
1607 local $SIG{QUIT} = 'IGNORE';
1608 local $SIG{TERM} = 'IGNORE';
1609 local $SIG{TSTP} = 'IGNORE';
1610 local $SIG{PIPE} = 'IGNORE';
1612 my $rc = $sth->execute or return $sth->errstr;
1613 #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1614 $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1615 $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1617 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1619 # Now that it has been saved, reset the encrypted fields so that $new
1620 # can still be used.
1621 foreach my $field (keys %{$saved}) {
1622 $new->setfield($field, $saved->{$field});
1630 my( $self ) = shift;
1631 warn "[$me] replace called with no arguments; autoloading old record\n"
1634 my $primary_key = $self->dbdef_table->primary_key;
1635 if ( $primary_key ) {
1636 $self->by_key( $self->$primary_key() ) #this is what's returned
1637 or croak "can't find ". $self->table. ".$primary_key ".
1638 $self->$primary_key();
1640 croak $self->table. " has no primary key; pass old record as argument";
1647 Depriciated (use replace instead).
1652 cluck "warning: FS::Record::rep deprecated!";
1653 replace @_; #call method in this scope
1658 Checks custom fields. Subclasses should still provide a check method to validate
1659 non-custom fields, etc., and call this method via $self->SUPER::check.
1665 foreach my $field ($self->virtual_fields) {
1666 my $error = $self->ut_textn($field);
1667 return $error if $error;
1672 =item virtual_fields [ TABLE ]
1674 Returns a list of virtual fields defined for the table. This should not
1675 be exported, and should only be called as an instance or class method.
1679 sub virtual_fields {
1682 $table = $self->table or confess "virtual_fields called on non-table";
1684 confess "Unknown table $table" unless dbdef->table($table);
1686 return () unless dbdef->table('part_virtual_field');
1688 unless ( $virtual_fields_cache{$table} ) {
1689 my $concat = [ "'cf_'", "name" ];
1690 my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' .
1691 "WHERE dbtable = '$table'";
1693 my $result = $dbh->selectcol_arrayref($query);
1694 confess "Error executing virtual fields query: $query: ". $dbh->errstr
1696 $virtual_fields_cache{$table} = $result;
1699 @{$virtual_fields_cache{$table}};
1703 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1705 Processes a batch import as a queued JSRPC job
1707 JOB is an FS::queue entry.
1709 OPTIONS_HASHREF can have the following keys:
1715 Table name (required).
1719 Arrayref of field names for static fields. They will be given values from the
1720 PARAMS hashref and passed as a "params" hashref to batch_import.
1724 Formats hashref. Keys are field names, values are listrefs that define the
1727 Each listref value can be a column name or a code reference. Coderefs are run
1728 with the row object, data and a FS::Conf object as the three parameters.
1729 For example, this coderef does the same thing as using the "columnname" string:
1732 my( $record, $data, $conf ) = @_;
1733 $record->columnname( $data );
1736 Coderefs are run after all "column name" fields are assigned.
1740 Optional format hashref of types. Keys are field names, values are "csv",
1741 "xls" or "fixedlength". Overrides automatic determination of file type
1744 =item format_headers
1746 Optional format hashref of header lines. Keys are field names, values are 0
1747 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1750 =item format_sep_chars
1752 Optional format hashref of CSV sep_chars. Keys are field names, values are the
1753 CSV separation character.
1755 =item format_fixedlenth_formats
1757 Optional format hashref of fixed length format defintiions. Keys are field
1758 names, values Parse::FixedLength listrefs of field definitions.
1762 Set true to default to CSV file type if the filename does not contain a
1763 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1768 PARAMS is a hashref (or base64-encoded Storable hashref) containing the
1769 POSTed data. It must contain the field "uploaded files", generated by
1770 /elements/file-upload.html and containing the list of uploaded files.
1771 Currently only supports a single file named "file".
1776 sub process_batch_import {
1777 my($job, $opt, $param) = @_;
1779 my $table = $opt->{table};
1780 my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1781 my %formats = %{ $opt->{formats} };
1783 warn Dumper($param) if $DEBUG;
1785 my $files = $param->{'uploaded_files'}
1786 or die "No files provided.\n";
1788 my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1790 my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1791 my $file = $dir. $files{'file'};
1796 formats => \%formats,
1797 format_types => $opt->{format_types},
1798 format_headers => $opt->{format_headers},
1799 format_sep_chars => $opt->{format_sep_chars},
1800 format_fixedlength_formats => $opt->{format_fixedlength_formats},
1801 format_xml_formats => $opt->{format_xml_formats},
1802 format_asn_formats => $opt->{format_asn_formats},
1803 format_row_callbacks => $opt->{format_row_callbacks},
1808 format => $param->{format},
1809 params => { map { $_ => $param->{$_} } @pass_params },
1811 default_csv => $opt->{default_csv},
1812 postinsert_callback => $opt->{postinsert_callback},
1813 insert_args_callback => $opt->{insert_args_callback},
1816 if ( $opt->{'batch_namecol'} ) {
1817 $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1818 $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1821 my $error = FS::Record::batch_import( \%iopt );
1825 die "$error\n" if $error;
1828 =item batch_import PARAM_HASHREF
1830 Class method for batch imports. Available params:
1836 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1842 =item format_headers
1844 =item format_sep_chars
1846 =item format_fixedlength_formats
1848 =item format_row_callbacks
1850 =item fields - Alternate way to specify import, specifying import fields directly as a listref
1852 =item preinsert_callback
1854 =item postinsert_callback
1860 FS::queue object, will be updated with progress
1866 csv, xls, fixedlength, xml
1878 warn "$me batch_import call with params: \n". Dumper($param)
1881 my $table = $param->{table};
1883 my $job = $param->{job};
1884 my $file = $param->{file};
1885 my $params = $param->{params} || {};
1887 my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
1888 my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
1890 my( $type, $header, $sep_char,
1891 $fixedlength_format, $xml_format, $asn_format,
1892 $parser_opt, $row_callback, @fields );
1894 my $postinsert_callback = '';
1895 $postinsert_callback = $param->{'postinsert_callback'}
1896 if $param->{'postinsert_callback'};
1897 my $preinsert_callback = '';
1898 $preinsert_callback = $param->{'preinsert_callback'}
1899 if $param->{'preinsert_callback'};
1900 my $insert_args_callback = '';
1901 $insert_args_callback = $param->{'insert_args_callback'}
1902 if $param->{'insert_args_callback'};
1904 if ( $param->{'format'} ) {
1906 my $format = $param->{'format'};
1907 my $formats = $param->{formats};
1908 die "unknown format $format" unless exists $formats->{ $format };
1910 $type = $param->{'format_types'}
1911 ? $param->{'format_types'}{ $format }
1912 : $param->{type} || 'csv';
1915 $header = $param->{'format_headers'}
1916 ? $param->{'format_headers'}{ $param->{'format'} }
1919 $sep_char = $param->{'format_sep_chars'}
1920 ? $param->{'format_sep_chars'}{ $param->{'format'} }
1923 $fixedlength_format =
1924 $param->{'format_fixedlength_formats'}
1925 ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1929 $param->{'format_parser_opts'}
1930 ? $param->{'format_parser_opts'}{ $param->{'format'} }
1934 $param->{'format_xml_formats'}
1935 ? $param->{'format_xml_formats'}{ $param->{'format'} }
1939 $param->{'format_asn_formats'}
1940 ? $param->{'format_asn_formats'}{ $param->{'format'} }
1944 $param->{'format_row_callbacks'}
1945 ? $param->{'format_row_callbacks'}{ $param->{'format'} }
1948 @fields = @{ $formats->{ $format } };
1950 } elsif ( $param->{'fields'} ) {
1952 $type = ''; #infer from filename
1955 $fixedlength_format = '';
1957 @fields = @{ $param->{'fields'} };
1960 die "neither format nor fields specified";
1963 #my $file = $param->{file};
1966 if ( $file =~ /\.(\w+)$/i ) {
1970 warn "can't parse file type from filename $file; defaulting to CSV";
1974 if $param->{'default_csv'} && $type ne 'xls';
1982 my $asn_header_buffer;
1983 if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1985 if ( $type eq 'csv' ) {
1987 $parser_opt->{'binary'} = 1;
1988 $parser_opt->{'sep_char'} = $sep_char if $sep_char;
1989 $parser = Text::CSV_XS->new($parser_opt);
1991 } elsif ( $type eq 'fixedlength' ) {
1993 eval "use Parse::FixedLength;";
1995 $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
1998 die "Unknown file type $type\n";
2001 @buffer = split(/\r?\n/, slurp($file) );
2002 splice(@buffer, 0, ($header || 0) );
2003 $count = scalar(@buffer);
2005 } elsif ( $type eq 'xls' ) {
2007 eval "use Spreadsheet::ParseExcel;";
2010 eval "use DateTime::Format::Excel;";
2011 #for now, just let the error be thrown if it is used, since only CDR
2012 # formats bill_west and troop use it, not other excel-parsing things
2015 my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
2017 $parser = $excel->{Worksheet}[0]; #first sheet
2019 $count = $parser->{MaxRow} || $parser->{MinRow};
2022 $row = $header || 0;
2024 } elsif ( $type eq 'xml' ) {
2027 eval "use XML::Simple;";
2029 my $xmlrow = $xml_format->{'xmlrow'};
2030 $parser = $xml_format->{'xmlkeys'};
2031 die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
2032 my $data = XML::Simple::XMLin(
2034 'SuppressEmpty' => '', #sets empty values to ''
2038 $rows = $rows->{$_} foreach @$xmlrow;
2039 $rows = [ $rows ] if ref($rows) ne 'ARRAY';
2040 $count = @buffer = @$rows;
2042 } elsif ( $type eq 'asn.1' ) {
2044 eval "use Convert::ASN1";
2047 my $asn = Convert::ASN1->new;
2048 $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
2050 $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
2052 my $data = slurp($file);
2053 my $asn_output = $parser->decode( $data )
2054 or return "No ". $asn_format->{'macro'}. " found\n";
2056 $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
2058 my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
2059 $count = @buffer = @$rows;
2062 die "Unknown file type $type\n";
2067 local $SIG{HUP} = 'IGNORE';
2068 local $SIG{INT} = 'IGNORE';
2069 local $SIG{QUIT} = 'IGNORE';
2070 local $SIG{TERM} = 'IGNORE';
2071 local $SIG{TSTP} = 'IGNORE';
2072 local $SIG{PIPE} = 'IGNORE';
2074 my $oldAutoCommit = $FS::UID::AutoCommit;
2075 local $FS::UID::AutoCommit = 0;
2078 #my $params = $param->{params} || {};
2079 if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
2080 my $batch_col = $param->{'batch_keycol'};
2082 my $batch_class = 'FS::'. $param->{'batch_table'};
2083 my $batch = $batch_class->new({
2084 $param->{'batch_namecol'} => $param->{'batch_namevalue'}
2086 my $error = $batch->insert;
2088 $dbh->rollback if $oldAutoCommit;
2089 return "can't insert batch record: $error";
2091 #primary key via dbdef? (so the column names don't have to match)
2092 my $batch_value = $batch->get( $param->{'batch_keycol'} );
2094 $params->{ $batch_col } = $batch_value;
2097 #my $job = $param->{job};
2100 my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
2104 my %hash = %$params;
2105 if ( $type eq 'csv' ) {
2107 last unless scalar(@buffer);
2108 $line = shift(@buffer);
2110 next if $line =~ /^\s*$/; #skip empty lines
2112 $line = &{$row_callback}($line) if $row_callback;
2114 next if $line =~ /^\s*$/; #skip empty lines
2116 $parser->parse($line) or do {
2117 $dbh->rollback if $oldAutoCommit;
2118 return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
2120 @columns = $parser->fields();
2122 } elsif ( $type eq 'fixedlength' ) {
2124 last unless scalar(@buffer);
2125 $line = shift(@buffer);
2127 @columns = $parser->parse($line);
2129 } elsif ( $type eq 'xls' ) {
2131 last if $row > ($parser->{MaxRow} || $parser->{MinRow})
2132 || ! $parser->{Cells}[$row];
2134 my @row = @{ $parser->{Cells}[$row] };
2135 @columns = map $_->{Val}, @row;
2138 #warn $z++. ": $_\n" for @columns;
2140 } elsif ( $type eq 'xml' ) {
2142 # $parser = [ 'Column0Key', 'Column1Key' ... ]
2143 last unless scalar(@buffer);
2144 my $row = shift @buffer;
2145 @columns = @{ $row }{ @$parser };
2147 } elsif ( $type eq 'asn.1' ) {
2149 last unless scalar(@buffer);
2150 my $row = shift @buffer;
2151 &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2152 if $asn_format->{row_callback};
2153 foreach my $key ( keys %{ $asn_format->{map} } ) {
2154 $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2158 die "Unknown file type $type\n";
2163 foreach my $field ( @fields ) {
2165 my $value = shift @columns;
2167 if ( ref($field) eq 'CODE' ) {
2168 #&{$field}(\%hash, $value);
2169 push @later, $field, $value;
2171 #??? $hash{$field} = $value if length($value);
2172 $hash{$field} = $value if defined($value) && length($value);
2177 if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
2178 && length($1) == $custnum_length ) {
2179 $hash{custnum} = $2;
2182 #my $table = $param->{table};
2183 my $class = "FS::$table";
2185 my $record = $class->new( \%hash );
2188 while ( scalar(@later) ) {
2189 my $sub = shift @later;
2190 my $data = shift @later;
2192 &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2195 $dbh->rollback if $oldAutoCommit;
2196 return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2198 last if exists( $param->{skiprow} );
2200 next if exists( $param->{skiprow} );
2202 if ( $preinsert_callback ) {
2203 my $error = &{$preinsert_callback}($record, $param);
2205 $dbh->rollback if $oldAutoCommit;
2206 return "preinsert_callback error". ( $line ? " for $line" : '' ).
2209 next if exists $param->{skiprow} && $param->{skiprow};
2212 my @insert_args = ();
2213 if ( $insert_args_callback ) {
2214 @insert_args = &{$insert_args_callback}($record, $param);
2217 my $error = $record->insert(@insert_args);
2220 $dbh->rollback if $oldAutoCommit;
2221 return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2227 if ( $postinsert_callback ) {
2228 my $error = &{$postinsert_callback}($record, $param);
2230 $dbh->rollback if $oldAutoCommit;
2231 return "postinsert_callback error". ( $line ? " for $line" : '' ).
2236 if ( $job && time - $min_sec > $last ) { #progress bar
2237 $job->update_statustext( int(100 * $imported / $count) );
2243 unless ( $imported || $param->{empty_ok} ) {
2244 $dbh->rollback if $oldAutoCommit;
2245 return "Empty file!";
2248 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2255 my( $self, $action, $time ) = @_;
2259 my %nohistory = map { $_=>1 } $self->nohistory_fields;
2262 grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2263 real_fields($self->table);
2266 # If we're encrypting then don't store the payinfo in the history
2267 if ( $conf && $conf->exists('encryption') && $self->table ne 'banned_pay' ) {
2268 @fields = grep { $_ ne 'payinfo' } @fields;
2271 my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2273 "INSERT INTO h_". $self->table. " ( ".
2274 join(', ', qw(history_date history_usernum history_action), @fields ).
2277 $FS::CurrentUser::CurrentUser->usernum,
2278 dbh->quote($action),
2287 B<Warning>: External use is B<deprecated>.
2289 Replaces COLUMN in record with a unique number, using counters in the
2290 filesystem. Used by the B<insert> method on single-field unique columns
2291 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2292 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2294 Returns the new value.
2299 my($self,$field) = @_;
2300 my($table)=$self->table;
2302 croak "Unique called on field $field, but it is ",
2303 $self->getfield($field),
2305 if $self->getfield($field);
2307 #warn "table $table is tainted" if is_tainted($table);
2308 #warn "field $field is tainted" if is_tainted($field);
2310 my($counter) = new File::CounterFile "$table.$field",0;
2312 my $index = $counter->inc;
2313 $index = $counter->inc while qsearchs($table, { $field=>$index } );
2315 $index =~ /^(\d*)$/;
2318 $self->setfield($field,$index);
2322 =item ut_float COLUMN
2324 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be
2325 null. If there is an error, returns the error, otherwise returns false.
2330 my($self,$field)=@_ ;
2331 ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2332 $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2333 $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2334 $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2335 or return "Illegal or empty (float) $field: ". $self->getfield($field);
2336 $self->setfield($field,$1);
2339 =item ut_floatn COLUMN
2341 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
2342 null. If there is an error, returns the error, otherwise returns false.
2346 #false laziness w/ut_ipn
2348 my( $self, $field ) = @_;
2349 if ( $self->getfield($field) =~ /^()$/ ) {
2350 $self->setfield($field,'');
2353 $self->ut_float($field);
2357 =item ut_sfloat COLUMN
2359 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2360 May not be null. If there is an error, returns the error, otherwise returns
2366 my($self,$field)=@_ ;
2367 ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2368 $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2369 $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2370 $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2371 or return "Illegal or empty (float) $field: ". $self->getfield($field);
2372 $self->setfield($field,$1);
2375 =item ut_sfloatn COLUMN
2377 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
2378 null. If there is an error, returns the error, otherwise returns false.
2383 my( $self, $field ) = @_;
2384 if ( $self->getfield($field) =~ /^()$/ ) {
2385 $self->setfield($field,'');
2388 $self->ut_sfloat($field);
2392 =item ut_snumber COLUMN
2394 Check/untaint signed numeric data (whole numbers). If there is an error,
2395 returns the error, otherwise returns false.
2400 my($self, $field) = @_;
2401 $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2402 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2403 $self->setfield($field, "$1$2");
2407 =item ut_snumbern COLUMN
2409 Check/untaint signed numeric data (whole numbers). If there is an error,
2410 returns the error, otherwise returns false.
2415 my($self, $field) = @_;
2416 $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2417 or return "Illegal (numeric) $field: ". $self->getfield($field);
2419 return "Illegal (numeric) $field: ". $self->getfield($field)
2422 $self->setfield($field, "$1$2");
2426 =item ut_number COLUMN
2428 Check/untaint simple numeric data (whole numbers). May not be null. If there
2429 is an error, returns the error, otherwise returns false.
2434 my($self,$field)=@_;
2435 $self->getfield($field) =~ /^\s*(\d+)\s*$/
2436 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2437 $self->setfield($field,$1);
2441 =item ut_numbern COLUMN
2443 Check/untaint simple numeric data (whole numbers). May be null. If there is
2444 an error, returns the error, otherwise returns false.
2449 my($self,$field)=@_;
2450 $self->getfield($field) =~ /^\s*(\d*)\s*$/
2451 or return "Illegal (numeric) $field: ". $self->getfield($field);
2452 $self->setfield($field,$1);
2456 =item ut_decimal COLUMN[, DIGITS]
2458 Check/untaint decimal numbers (up to DIGITS decimal places. If there is an
2459 error, returns the error, otherwise returns false.
2461 =item ut_decimaln COLUMN[, DIGITS]
2463 Check/untaint decimal numbers. May be null. If there is an error, returns
2464 the error, otherwise returns false.
2469 my($self, $field, $digits) = @_;
2471 $self->getfield($field) =~ /^\s*(\d+(\.\d{0,$digits})?)\s*$/
2472 or return "Illegal or empty (decimal) $field: ".$self->getfield($field);
2473 $self->setfield($field, $1);
2478 my($self, $field, $digits) = @_;
2479 $self->getfield($field) =~ /^\s*(\d*(\.\d{0,$digits})?)\s*$/
2480 or return "Illegal (decimal) $field: ".$self->getfield($field);
2481 $self->setfield($field, $1);
2485 =item ut_money COLUMN
2487 Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
2488 is an error, returns the error, otherwise returns false.
2493 my($self,$field)=@_;
2495 if ( $self->getfield($field) eq '' ) {
2496 $self->setfield($field, 0);
2497 } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2498 #handle one decimal place without barfing out
2499 $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2500 } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2501 $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2503 return "Illegal (money) $field: ". $self->getfield($field);
2509 =item ut_moneyn COLUMN
2511 Check/untaint monetary numbers. May be negative. If there
2512 is an error, returns the error, otherwise returns false.
2517 my($self,$field)=@_;
2518 if ($self->getfield($field) eq '') {
2519 $self->setfield($field, '');
2522 $self->ut_money($field);
2525 =item ut_currencyn COLUMN
2527 Check/untaint currency indicators, such as USD or EUR. May be null. If there
2528 is an error, returns the error, otherwise returns false.
2533 my($self, $field) = @_;
2534 if ($self->getfield($field) eq '') { #can be null
2535 $self->setfield($field, '');
2538 $self->ut_currency($field);
2541 =item ut_currency COLUMN
2543 Check/untaint currency indicators, such as USD or EUR. May not be null. If
2544 there is an error, returns the error, otherwise returns false.
2549 my($self, $field) = @_;
2550 my $value = uc( $self->getfield($field) );
2551 if ( code2currency($value) ) {
2552 $self->setfield($value);
2554 return "Unknown currency $value";
2560 =item ut_text COLUMN
2562 Check/untaint text. Alphanumerics, spaces, and the following punctuation
2563 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2564 May not be null. If there is an error, returns the error, otherwise returns
2570 my($self,$field)=@_;
2571 #warn "msgcat ". \&msgcat. "\n";
2572 #warn "notexist ". \¬exist. "\n";
2573 #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2574 # \p{Word} = alphanumerics, marks (diacritics), and connectors
2575 # see perldoc perluniprops
2576 $self->getfield($field)
2577 =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
2578 or return gettext('illegal_or_empty_text'). " $field: ".
2579 $self->getfield($field);
2580 $self->setfield($field,$1);
2584 =item ut_textn COLUMN
2586 Check/untaint text. Alphanumerics, spaces, and the following punctuation
2587 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2588 May be null. If there is an error, returns the error, otherwise returns false.
2593 my($self,$field)=@_;
2594 return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2595 $self->ut_text($field);
2598 =item ut_alpha COLUMN
2600 Check/untaint alphanumeric strings (no spaces). May not be null. If there is
2601 an error, returns the error, otherwise returns false.
2606 my($self,$field)=@_;
2607 $self->getfield($field) =~ /^(\w+)$/
2608 or return "Illegal or empty (alphanumeric) $field: ".
2609 $self->getfield($field);
2610 $self->setfield($field,$1);
2614 =item ut_alphan COLUMN
2616 Check/untaint alphanumeric strings (no spaces). May be null. If there is an
2617 error, returns the error, otherwise returns false.
2622 my($self,$field)=@_;
2623 $self->getfield($field) =~ /^(\w*)$/
2624 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2625 $self->setfield($field,$1);
2629 =item ut_alphasn COLUMN
2631 Check/untaint alphanumeric strings, spaces allowed. May be null. If there is
2632 an error, returns the error, otherwise returns false.
2637 my($self,$field)=@_;
2638 $self->getfield($field) =~ /^([\w ]*)$/
2639 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2640 $self->setfield($field,$1);
2645 =item ut_alpha_lower COLUMN
2647 Check/untaint lowercase alphanumeric strings (no spaces). May not be null. If
2648 there is an error, returns the error, otherwise returns false.
2652 sub ut_alpha_lower {
2653 my($self,$field)=@_;
2654 $self->getfield($field) =~ /[[:upper:]]/
2655 and return "Uppercase characters are not permitted in $field";
2656 $self->ut_alpha($field);
2659 =item ut_phonen COLUMN [ COUNTRY ]
2661 Check/untaint phone numbers. May be null. If there is an error, returns
2662 the error, otherwise returns false.
2664 Takes an optional two-letter ISO 3166-1 alpha-2 country code; without
2665 it or with unsupported countries, ut_phonen simply calls ut_alphan.
2670 my( $self, $field, $country ) = @_;
2671 return $self->ut_alphan($field) unless defined $country;
2672 my $phonen = $self->getfield($field);
2673 if ( $phonen eq '' ) {
2674 $self->setfield($field,'');
2675 } elsif ( $country eq 'US' || $country eq 'CA' ) {
2677 $phonen = $conf->config('cust_main-default_areacode').$phonen
2678 if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2679 $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2680 or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2681 $phonen = "$1-$2-$3";
2682 $phonen .= " x$4" if $4;
2683 $self->setfield($field,$phonen);
2685 warn "warning: don't know how to check phone numbers for country $country";
2686 return $self->ut_textn($field);
2693 Check/untaint hexadecimal values.
2698 my($self, $field) = @_;
2699 $self->getfield($field) =~ /^([\da-fA-F]+)$/
2700 or return "Illegal (hex) $field: ". $self->getfield($field);
2701 $self->setfield($field, uc($1));
2705 =item ut_hexn COLUMN
2707 Check/untaint hexadecimal values. May be null.
2712 my($self, $field) = @_;
2713 $self->getfield($field) =~ /^([\da-fA-F]*)$/
2714 or return "Illegal (hex) $field: ". $self->getfield($field);
2715 $self->setfield($field, uc($1));
2719 =item ut_mac_addr COLUMN
2721 Check/untaint mac addresses. May be null.
2726 my($self, $field) = @_;
2728 my $mac = $self->get($field);
2731 $self->set($field, $mac);
2733 my $e = $self->ut_hex($field);
2736 return "Illegal (mac address) $field: ". $self->getfield($field)
2737 unless length($self->getfield($field)) == 12;
2743 =item ut_mac_addrn COLUMN
2745 Check/untaint mac addresses. May be null.
2750 my($self, $field) = @_;
2751 ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2756 Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
2762 my( $self, $field ) = @_;
2763 $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2764 $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2765 or return "Illegal (IP address) $field: ". $self->getfield($field);
2766 for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2767 $self->setfield($field, "$1.$2.$3.$4");
2773 Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
2774 to 127.0.0.1. May be null.
2779 my( $self, $field ) = @_;
2780 if ( $self->getfield($field) =~ /^()$/ ) {
2781 $self->setfield($field,'');
2784 $self->ut_ip($field);
2788 =item ut_ip46 COLUMN
2790 Check/untaint IPv4 or IPv6 address.
2795 my( $self, $field ) = @_;
2796 my $ip = NetAddr::IP->new($self->getfield($field))
2797 or return "Illegal (IP address) $field: ".$self->getfield($field);
2798 $self->setfield($field, lc($ip->addr));
2804 Check/untaint IPv6 or IPv6 address. May be null.
2809 my( $self, $field ) = @_;
2810 if ( $self->getfield($field) =~ /^$/ ) {
2811 $self->setfield($field, '');
2814 $self->ut_ip46($field);
2817 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2819 Check/untaint coordinates.
2820 Accepts the following forms:
2830 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2831 The latter form (that is, the MMM are thousands of minutes) is
2832 assumed if the "MMM" is exactly three digits or two digits > 59.
2834 To be safe, just use the DDD.DDDDD form.
2836 If LOWER or UPPER are specified, then the coordinate is checked
2837 for lower and upper bounds, respectively.
2842 my ($self, $field) = (shift, shift);
2845 if ( $field =~ /latitude/ ) {
2846 $lower = $lat_lower;
2848 } elsif ( $field =~ /longitude/ ) {
2850 $upper = $lon_upper;
2853 my $coord = $self->getfield($field);
2854 my $neg = $coord =~ s/^(-)//;
2856 my ($d, $m, $s) = (0, 0, 0);
2859 (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2860 (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2861 (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2863 $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2866 return "Invalid (coordinate with minutes > 59) $field: "
2867 . $self->getfield($field);
2870 $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2872 if (defined($lower) and ($coord < $lower)) {
2873 return "Invalid (coordinate < $lower) $field: "
2874 . $self->getfield($field);;
2877 if (defined($upper) and ($coord > $upper)) {
2878 return "Invalid (coordinate > $upper) $field: "
2879 . $self->getfield($field);;
2882 $self->setfield($field, $coord);
2886 return "Invalid (coordinate) $field: " . $self->getfield($field);
2890 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2892 Same as ut_coord, except optionally null.
2898 my ($self, $field) = (shift, shift);
2900 if ($self->getfield($field) =~ /^\s*$/) {
2903 return $self->ut_coord($field, @_);
2908 =item ut_domain COLUMN
2910 Check/untaint host and domain names. May not be null.
2915 my( $self, $field ) = @_;
2916 #$self->getfield($field) =~/^(\w+\.)*\w+$/
2917 $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2918 or return "Illegal (hostname) $field: ". $self->getfield($field);
2919 $self->setfield($field,$1);
2923 =item ut_domainn COLUMN
2925 Check/untaint host and domain names. May be null.
2930 my( $self, $field ) = @_;
2931 if ( $self->getfield($field) =~ /^()$/ ) {
2932 $self->setfield($field,'');
2935 $self->ut_domain($field);
2939 =item ut_name COLUMN
2941 Check/untaint proper names; allows alphanumerics, spaces and the following
2942 punctuation: , . - '
2949 my( $self, $field ) = @_;
2950 # warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
2951 $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
2952 or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2957 $self->setfield($field, $name);
2961 =item ut_namen COLUMN
2963 Check/untaint proper names; allows alphanumerics, spaces and the following
2964 punctuation: , . - '
2971 my( $self, $field ) = @_;
2972 return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2973 $self->ut_name($field);
2978 Check/untaint zip codes.
2982 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2985 my( $self, $field, $country ) = @_;
2987 if ( $country eq 'US' ) {
2989 $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2990 or return gettext('illegal_zip'). " $field for country $country: ".
2991 $self->getfield($field);
2992 $self->setfield($field, $1);
2994 } elsif ( $country eq 'CA' ) {
2996 $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2997 or return gettext('illegal_zip'). " $field for country $country: ".
2998 $self->getfield($field);
2999 $self->setfield($field, "$1 $2");
3003 if ( $self->getfield($field) =~ /^\s*$/
3004 && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
3007 $self->setfield($field,'');
3009 $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
3010 or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
3011 $self->setfield($field,$1);
3019 =item ut_country COLUMN
3021 Check/untaint country codes. Country names are changed to codes, if possible -
3022 see L<Locale::Country>.
3027 my( $self, $field ) = @_;
3028 unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
3029 if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
3030 && country2code($1) ) {
3031 $self->setfield($field,uc(country2code($1)));
3034 $self->getfield($field) =~ /^(\w\w)$/
3035 or return "Illegal (country) $field: ". $self->getfield($field);
3036 $self->setfield($field,uc($1));
3040 =item ut_anything COLUMN
3042 Untaints arbitrary data. Be careful.
3047 my( $self, $field ) = @_;
3048 $self->getfield($field) =~ /^(.*)$/s
3049 or return "Illegal $field: ". $self->getfield($field);
3050 $self->setfield($field,$1);
3054 =item ut_enum COLUMN CHOICES_ARRAYREF
3056 Check/untaint a column, supplying all possible choices, like the "enum" type.
3061 my( $self, $field, $choices ) = @_;
3062 foreach my $choice ( @$choices ) {
3063 if ( $self->getfield($field) eq $choice ) {
3064 $self->setfield($field, $choice);
3068 return "Illegal (enum) field $field: ". $self->getfield($field);
3071 =item ut_enumn COLUMN CHOICES_ARRAYREF
3073 Like ut_enum, except the null value is also allowed.
3078 my( $self, $field, $choices ) = @_;
3079 $self->getfield($field)
3080 ? $self->ut_enum($field, $choices)
3084 =item ut_flag COLUMN
3086 Check/untaint a column if it contains either an empty string or 'Y'. This
3087 is the standard form for boolean flags in Freeside.
3092 my( $self, $field ) = @_;
3093 my $value = uc($self->getfield($field));
3094 if ( $value eq '' or $value eq 'Y' ) {
3095 $self->setfield($field, $value);
3098 return "Illegal (flag) field $field: $value";
3101 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3103 Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
3104 on the column first.
3108 sub ut_foreign_key {
3109 my( $self, $field, $table, $foreign ) = @_;
3110 return $self->ut_number($field) if $no_check_foreign;
3111 qsearchs($table, { $foreign => $self->getfield($field) })
3112 or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
3113 " in $table.$foreign";
3117 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3119 Like ut_foreign_key, except the null value is also allowed.
3123 sub ut_foreign_keyn {
3124 my( $self, $field, $table, $foreign ) = @_;
3125 $self->getfield($field)
3126 ? $self->ut_foreign_key($field, $table, $foreign)
3130 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
3132 Checks this column as an agentnum, taking into account the current users's
3133 ACLs. NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
3134 right or rights allowing no agentnum.
3138 sub ut_agentnum_acl {
3139 my( $self, $field ) = (shift, shift);
3140 my $null_acl = scalar(@_) ? shift : [];
3141 $null_acl = [ $null_acl ] unless ref($null_acl);
3143 my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
3144 return "Illegal agentnum: $error" if $error;
3146 my $curuser = $FS::CurrentUser::CurrentUser;
3148 if ( $self->$field() ) {
3150 return 'Access denied to agent '. $self->$field()
3151 unless $curuser->agentnum($self->$field());
3155 return 'Access denied to global'
3156 unless grep $curuser->access_right($_), @$null_acl;
3164 =item fields [ TABLE ]
3166 This is a wrapper for real_fields. Code that called
3167 fields before should probably continue to call fields.
3172 my $something = shift;
3174 if($something->isa('FS::Record')) {
3175 $table = $something->table;
3177 $table = $something;
3178 #$something = "FS::$table";
3180 return (real_fields($table));
3184 =item encrypt($value)
3186 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
3188 Returns the encrypted string.
3190 You should generally not have to worry about calling this, as the system handles this for you.
3195 my ($self, $value) = @_;
3196 my $encrypted = $value;
3198 if ($conf->exists('encryption')) {
3199 if ($self->is_encrypted($value)) {
3200 # Return the original value if it isn't plaintext.
3201 $encrypted = $value;
3204 if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
3205 # RSA doesn't like the empty string so let's pack it up
3206 # The database doesn't like the RSA data so uuencode it
3207 my $length = length($value)+1;
3208 $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
3210 die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
3217 =item is_encrypted($value)
3219 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
3225 my ($self, $value) = @_;
3226 # could be more precise about it, but this will do for now
3227 $value =~ /^M/ && length($value) > 80;
3230 =item decrypt($value)
3232 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
3234 You should generally not have to worry about calling this, as the system handles this for you.
3239 my ($self,$value) = @_;
3240 my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
3241 if ($conf->exists('encryption') && $self->is_encrypted($value)) {
3243 if (ref($rsa_decrypt) =~ /::RSA/) {
3244 my $encrypted = unpack ("u*", $value);
3245 $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
3246 if ($@) {warn "Decryption Failed"};
3254 #Initialize the Module
3255 $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
3257 if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
3258 $rsa_module = $conf->config('encryptionmodule');
3262 eval ("require $rsa_module"); # No need to import the namespace
3265 # Initialize Encryption
3266 if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
3267 my $public_key = join("\n",$conf->config('encryptionpublickey'));
3268 $rsa_encrypt = $rsa_module->new_public_key($public_key);
3271 # Intitalize Decryption
3272 if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
3273 my $private_key = join("\n",$conf->config('encryptionprivatekey'));
3274 $rsa_decrypt = $rsa_module->new_private_key($private_key);
3278 =item h_search ACTION
3280 Given an ACTION, either "insert", or "delete", returns the appropriate history
3281 record corresponding to this record, if any.
3286 my( $self, $action ) = @_;
3288 my $table = $self->table;
3291 my $primary_key = dbdef->table($table)->primary_key;
3294 'table' => "h_$table",
3295 'hashref' => { $primary_key => $self->$primary_key(),
3296 'history_action' => $action,
3304 Given an ACTION, either "insert", or "delete", returns the timestamp of the
3305 appropriate history record corresponding to this record, if any.
3310 my($self, $action) = @_;
3311 my $h = $self->h_search($action);
3312 $h ? $h->history_date : '';
3315 =item scalar_sql SQL [ PLACEHOLDER, ... ]
3317 A class or object method. Executes the sql statement represented by SQL and
3318 returns a scalar representing the result: the first column of the first row.
3320 Dies on bogus SQL. Returns an empty string if no row is returned.
3322 Typically used for statments which return a single value such as "SELECT
3323 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
3328 my($self, $sql) = (shift, shift);
3329 my $sth = dbh->prepare($sql) or die dbh->errstr;
3331 or die "Unexpected error executing statement $sql: ". $sth->errstr;
3332 my $row = $sth->fetchrow_arrayref or return '';
3333 my $scalar = $row->[0];
3334 defined($scalar) ? $scalar : '';
3337 =item count [ WHERE [, PLACEHOLDER ...] ]
3339 Convenience method for the common case of "SELECT COUNT(*) FROM table",
3340 with optional WHERE. Must be called as method on a class with an
3346 my($self, $where) = (shift, shift);
3347 my $table = $self->table or die 'count called on object of class '.ref($self);
3348 my $sql = "SELECT COUNT(*) FROM $table";
3349 $sql .= " WHERE $where" if $where;
3350 $self->scalar_sql($sql, @_);
3353 =item row_exists [ WHERE [, PLACEHOLDER ...] ]
3355 Convenience method for the common case of "SELECT 1 FROM table ... LIMIT 1"
3356 with optional (but almost always needed) WHERE.
3361 my($self, $where) = (shift, shift);
3362 my $table = $self->table or die 'row_exists called on object of class '.ref($self);
3363 my $sql = "SELECT 1 FROM $table";
3364 $sql .= " WHERE $where" if $where;
3366 $self->scalar_sql($sql, @_);
3375 =item real_fields [ TABLE ]
3377 Returns a list of the real columns in the specified table. Called only by
3378 fields() and other subroutines elsewhere in FS::Record.
3385 my($table_obj) = dbdef->table($table);
3386 confess "Unknown table $table" unless $table_obj;
3387 $table_obj->columns;
3390 =item pvf FIELD_NAME
3392 Returns the FS::part_virtual_field object corresponding to a field in the
3393 record (specified by FIELD_NAME).
3398 my ($self, $name) = (shift, shift);
3400 if(grep /^$name$/, $self->virtual_fields) {
3402 my $concat = [ "'cf_'", "name" ];
3403 return qsearchs({ table => 'part_virtual_field',
3404 hashref => { dbtable => $self->table,
3407 select => 'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
3413 =item _quote VALUE, TABLE, COLUMN
3415 This is an internal function used to construct SQL statements. It returns
3416 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3417 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3422 my($value, $table, $column) = @_;
3423 my $column_obj = dbdef->table($table)->column($column);
3424 my $column_type = $column_obj->type;
3425 my $nullable = $column_obj->null;
3427 utf8::upgrade($value);
3429 warn " $table.$column: $value ($column_type".
3430 ( $nullable ? ' NULL' : ' NOT NULL' ).
3431 ")\n" if $DEBUG > 2;
3433 if ( $value eq '' && $nullable ) {
3435 } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3436 cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3439 } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3440 ! $column_type =~ /(char|binary|text)$/i ) {
3442 } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3443 && driver_name eq 'Pg'
3447 # dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right
3448 # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\,
3449 # single-quote the whole mess, and put an "E" in front.
3450 return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'");
3458 This is deprecated. Don't use it.
3460 It returns a hash-type list with the fields of this record's table set true.
3465 carp "warning: hfields is deprecated";
3468 foreach (fields($table)) {
3477 "$_: ". $self->getfield($_). "|"
3478 } (fields($self->table)) );
3481 sub DESTROY { return; }
3485 # #use Carp qw(cluck);
3486 # #cluck "DESTROYING $self";
3487 # warn "DESTROYING $self";
3491 # return ! eval { join('',@_), kill 0; 1; };
3494 =item str2time_sql [ DRIVER_NAME ]
3496 Returns a function to convert to unix time based on database type, such as
3497 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql. See
3498 the str2time_sql_closing method to return a closing string rather than just
3499 using a closing parenthesis as previously suggested.
3501 You can pass an optional driver name such as "Pg", "mysql" or
3502 $dbh->{Driver}->{Name} to return a function for that database instead of
3503 the current database.
3508 my $driver = shift || driver_name;
3510 return 'UNIX_TIMESTAMP(' if $driver =~ /^mysql/i;
3511 return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3513 warn "warning: unknown database type $driver; guessing how to convert ".
3514 "dates to UNIX timestamps";
3515 return 'EXTRACT(EPOCH FROM ';
3519 =item str2time_sql_closing [ DRIVER_NAME ]
3521 Returns the closing suffix of a function to convert to unix time based on
3522 database type, such as ")::integer" for Pg or ")" for mysql.
3524 You can pass an optional driver name such as "Pg", "mysql" or
3525 $dbh->{Driver}->{Name} to return a function for that database instead of
3526 the current database.
3530 sub str2time_sql_closing {
3531 my $driver = shift || driver_name;
3533 return ' )::INTEGER ' if $driver =~ /^Pg/i;
3537 =item regexp_sql [ DRIVER_NAME ]
3539 Returns the operator to do a regular expression comparison based on database
3540 type, such as '~' for Pg or 'REGEXP' for mysql.
3542 You can pass an optional driver name such as "Pg", "mysql" or
3543 $dbh->{Driver}->{Name} to return a function for that database instead of
3544 the current database.
3549 my $driver = shift || driver_name;
3551 return '~' if $driver =~ /^Pg/i;
3552 return 'REGEXP' if $driver =~ /^mysql/i;
3554 die "don't know how to use regular expressions in ". driver_name." databases";
3558 =item not_regexp_sql [ DRIVER_NAME ]
3560 Returns the operator to do a regular expression negation based on database
3561 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3563 You can pass an optional driver name such as "Pg", "mysql" or
3564 $dbh->{Driver}->{Name} to return a function for that database instead of
3565 the current database.
3569 sub not_regexp_sql {
3570 my $driver = shift || driver_name;
3572 return '!~' if $driver =~ /^Pg/i;
3573 return 'NOT REGEXP' if $driver =~ /^mysql/i;
3575 die "don't know how to use regular expressions in ". driver_name." databases";
3579 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3581 Returns the items concatenated based on database type, using "CONCAT()" for
3582 mysql and " || " for Pg and other databases.
3584 You can pass an optional driver name such as "Pg", "mysql" or
3585 $dbh->{Driver}->{Name} to return a function for that database instead of
3586 the current database.
3591 my $driver = ref($_[0]) ? driver_name : shift;
3594 if ( $driver =~ /^mysql/i ) {
3595 'CONCAT('. join(',', @$items). ')';
3597 join('||', @$items);
3602 =item group_concat_sql COLUMN, DELIMITER
3604 Returns an SQL expression to concatenate an aggregate column, using
3605 GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg.
3609 sub group_concat_sql {
3610 my ($col, $delim) = @_;
3611 $delim = dbh->quote($delim);
3612 if ( driver_name() =~ /^mysql/i ) {
3613 # DISTINCT(foo) is valid as $col
3614 return "GROUP_CONCAT($col SEPARATOR $delim)";
3616 return "array_to_string(array_agg($col), $delim)";
3620 =item midnight_sql DATE
3622 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3623 on that day in the system timezone, using the default driver name.
3628 my $driver = driver_name;
3630 if ( $driver =~ /^mysql/i ) {
3631 "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3634 "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3642 This module should probably be renamed, since much of the functionality is
3643 of general use. It is not completely unlike Adapter::DBI (see below).
3645 Exported qsearch and qsearchs should be deprecated in favor of method calls
3646 (against an FS::Record object like the old search and searchs that qsearch
3647 and qsearchs were on top of.)
3649 The whole fields / hfields mess should be removed.
3651 The various WHERE clauses should be subroutined.
3653 table string should be deprecated in favor of DBIx::DBSchema::Table.
3655 No doubt we could benefit from a Tied hash. Documenting how exists / defined
3656 true maps to the database (and WHERE clauses) would also help.
3658 The ut_ methods should ask the dbdef for a default length.
3660 ut_sqltype (like ut_varchar) should all be defined
3662 A fallback check method should be provided which uses the dbdef.
3664 The ut_money method assumes money has two decimal digits.
3666 The Pg money kludge in the new method only strips `$'.
3668 The ut_phonen method only checks US-style phone numbers.
3670 The _quote function should probably use ut_float instead of a regex.
3672 All the subroutines probably should be methods, here or elsewhere.
3674 Probably should borrow/use some dbdef methods where appropriate (like sub
3677 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3678 or allow it to be set. Working around it is ugly any way around - DBI should
3679 be fixed. (only affects RDBMS which return uppercase column names)
3681 ut_zip should take an optional country like ut_phone.
3685 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3687 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.