5 use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG
7 $money_char $lat_lower $lon_upper
9 $nowarn_identical $nowarn_classload
10 $no_update_diff $no_history $qsearch_qualify_columns
15 use Carp qw(carp cluck croak confess);
16 use Scalar::Util qw( blessed );
17 use File::CounterFile;
20 use File::Slurp qw( slurp );
21 use DBI qw(:sql_types);
22 use DBIx::DBSchema 0.38;
23 use FS::UID qw(dbh getotaker datasrc driver_name);
25 use FS::Schema qw(dbdef);
27 use FS::Msgcat qw(gettext);
28 use NetAddr::IP; # for validation
30 #use FS::Conf; #dependency loop bs, in install_callback below instead
32 use FS::part_virtual_field;
38 @encrypt_payby = qw( CARD DCRD CHEK DCHK );
40 #export dbdef for now... everything else expects to find it here
42 dbh fields hfields qsearch qsearchs dbdef jsearch
43 str2time_sql str2time_sql_closing regexp_sql not_regexp_sql
44 concat_sql group_concat_sql
51 $nowarn_identical = 0;
52 $nowarn_classload = 0;
56 $qsearch_qualify_columns = 0;
58 $no_check_foreign = 0;
66 our $conf_encryption = '';
67 our $conf_encryptionmodule = '';
68 our $conf_encryptionpublickey = '';
69 our $conf_encryptionprivatekey = '';
70 FS::UID->install_callback( sub {
74 $conf = FS::Conf->new;
75 $conf_encryption = $conf->exists('encryption');
76 $conf_encryptionmodule = $conf->config('encryptionmodule');
77 $conf_encryptionpublickey = join("\n",$conf->config('encryptionpublickey'));
78 $conf_encryptionprivatekey = join("\n",$conf->config('encryptionprivatekey'));
79 $money_char = $conf->config('money_char') || '$';
80 my $nw_coords = $conf->exists('geocode-require_nw_coordinates');
81 $lat_lower = $nw_coords ? 1 : -90;
82 $lon_upper = $nw_coords ? -1 : 180;
84 $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
86 if ( driver_name eq 'Pg' ) {
87 eval "use DBD::Pg ':pg_types'";
90 eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }";
97 FS::Record - Database record objects
102 use FS::Record qw(dbh fields qsearch qsearchs);
104 $record = new FS::Record 'table', \%hash;
105 $record = new FS::Record 'table', { 'column' => 'value', ... };
107 $record = qsearchs FS::Record 'table', \%hash;
108 $record = qsearchs FS::Record 'table', { 'column' => 'value', ... };
109 @records = qsearch FS::Record 'table', \%hash;
110 @records = qsearch FS::Record 'table', { 'column' => 'value', ... };
112 $table = $record->table;
113 $dbdef_table = $record->dbdef_table;
115 $value = $record->get('column');
116 $value = $record->getfield('column');
117 $value = $record->column;
119 $record->set( 'column' => 'value' );
120 $record->setfield( 'column' => 'value' );
121 $record->column('value');
123 %hash = $record->hash;
125 $hashref = $record->hashref;
127 $error = $record->insert;
129 $error = $record->delete;
131 $error = $new_record->replace($old_record);
133 # external use deprecated - handled by the database (at least for Pg, mysql)
134 $value = $record->unique('column');
136 $error = $record->ut_float('column');
137 $error = $record->ut_floatn('column');
138 $error = $record->ut_number('column');
139 $error = $record->ut_numbern('column');
140 $error = $record->ut_decimal('column');
141 $error = $record->ut_decimaln('column');
142 $error = $record->ut_snumber('column');
143 $error = $record->ut_snumbern('column');
144 $error = $record->ut_money('column');
145 $error = $record->ut_text('column');
146 $error = $record->ut_textn('column');
147 $error = $record->ut_alpha('column');
148 $error = $record->ut_alphan('column');
149 $error = $record->ut_phonen('column');
150 $error = $record->ut_anything('column');
151 $error = $record->ut_name('column');
153 $quoted_value = _quote($value,'table','field');
156 $fields = hfields('table');
157 if ( $fields->{Field} ) { # etc.
159 @fields = fields 'table'; #as a subroutine
160 @fields = $record->fields; #as a method call
165 (Mostly) object-oriented interface to database records. Records are currently
166 implemented on top of DBI. FS::Record is intended as a base class for
167 table-specific classes to inherit from, i.e. FS::cust_main.
173 =item new [ TABLE, ] HASHREF
175 Creates a new record. It doesn't store it in the database, though. See
176 L<"insert"> for that.
178 Note that the object stores this hash reference, not a distinct copy of the
179 hash it points to. You can ask the object for a copy with the I<hash>
182 TABLE can only be omitted when a dervived class overrides the table method.
188 my $class = ref($proto) || $proto;
190 bless ($self, $class);
192 unless ( defined ( $self->table ) ) {
193 $self->{'Table'} = shift;
194 carp "warning: FS::Record::new called with table name ". $self->{'Table'}
195 unless $nowarn_classload;
198 $self->{'Hash'} = shift;
200 foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
201 $self->{'Hash'}{$field}='';
204 $self->_rebless if $self->can('_rebless');
206 $self->{'modified'} = 0;
208 $self->_simplecache($self->{'Hash'}) if $self->can('_simplecache');
209 $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
216 my $class = ref($proto) || $proto;
218 bless ($self, $class);
220 $self->{'Table'} = shift unless defined ( $self->table );
222 my $hashref = $self->{'Hash'} = shift;
224 if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
225 my $obj = $cache->cache->{$hashref->{$cache->key}};
226 $obj->_cache($hashref, $cache) if $obj->can('_cache');
229 $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
236 my $class = ref($proto) || $proto;
238 bless ($self, $class);
239 if ( defined $self->table ) {
240 cluck "create constructor is deprecated, use new!";
243 croak "FS::Record::create called (not from a subclass)!";
247 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
249 Searches the database for all records matching (at least) the key/value pairs
250 in HASHREF. Returns all the records found as `FS::TABLE' objects if that
251 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
254 The preferred usage is to pass a hash reference of named parameters:
256 @records = qsearch( {
257 'table' => 'table_name',
258 'hashref' => { 'field' => 'value'
259 'field' => { 'op' => '<',
264 #these are optional...
266 'extra_sql' => 'AND field = ? AND intfield = ?',
267 'extra_param' => [ 'value', [ 5, 'int' ] ],
268 'order_by' => 'ORDER BY something',
269 #'cache_obj' => '', #optional
270 'addl_from' => 'LEFT JOIN othtable USING ( field )',
275 Much code still uses old-style positional parameters, this is also probably
276 fine in the common case where there are only two parameters:
278 my @records = qsearch( 'table', { 'field' => 'value' } );
280 Also possible is an experimental LISTREF of PARAMS_HASHREFs for a UNION of
281 the individual PARAMS_HASHREF queries
283 ###oops, argh, FS::Record::new only lets us create database fields.
284 #Normal behaviour if SELECT is not specified is `*', as in
285 #C<SELECT * FROM table WHERE ...>. However, there is an experimental new
286 #feature where you can specify SELECT - remember, the objects returned,
287 #although blessed into the appropriate `FS::TABLE' package, will only have the
288 #fields you specify. This might have unwanted results if you then go calling
289 #regular FS::TABLE methods
292 C<$FS::Record::qsearch_qualify_columns> package global is disabled by default.
293 When enabled, the WHERE clause generated from the 'hashref' parameter has
294 the table name prepended to each column name. WHERE column = 'value' becomes
295 WHERE table.coumn = 'value'
299 my %TYPE = (); #for debugging
302 my($type, $value) = @_;
304 my $bind_type = { TYPE => SQL_VARCHAR };
306 if ( $type =~ /(big)?(int|serial)/i && $value =~ /^-?\d+(\.\d+)?$/ ) {
308 $bind_type = { TYPE => SQL_INTEGER };
310 } elsif ( $type =~ /^bytea$/i || $type =~ /(blob|varbinary)/i ) {
312 if ( driver_name eq 'Pg' ) {
314 $bind_type = { pg_type => PG_BYTEA };
316 # $bind_type = ? #SQL_VARCHAR could be fine?
319 #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT
320 #fixed by DBD::Pg 2.11.8
321 #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded
322 #(make a Tron test first)
323 } elsif ( _is_fs_float( $type, $value ) ) {
325 $bind_type = { TYPE => SQL_DECIMAL };
334 my($type, $value) = @_;
335 if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) ||
336 ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/)
344 my( @stable, @record, @cache );
345 my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
347 my %union_options = ();
348 if ( ref($_[0]) eq 'ARRAY' ) {
351 foreach my $href ( @$optlist ) {
352 push @stable, ( $href->{'table'} or die "table name is required" );
353 push @record, ( $href->{'hashref'} || {} );
354 push @select, ( $href->{'select'} || '*' );
355 push @extra_sql, ( $href->{'extra_sql'} || '' );
356 push @extra_param, ( $href->{'extra_param'} || [] );
357 push @order_by, ( $href->{'order_by'} || '' );
358 push @cache, ( $href->{'cache_obj'} || '' );
359 push @addl_from, ( $href->{'addl_from'} || '' );
360 push @debug, ( $href->{'debug'} || '' );
362 die "at least one hashref is required" unless scalar(@stable);
363 } elsif ( ref($_[0]) eq 'HASH' ) {
365 $stable[0] = $opt->{'table'} or die "table name is required";
366 $record[0] = $opt->{'hashref'} || {};
367 $select[0] = $opt->{'select'} || '*';
368 $extra_sql[0] = $opt->{'extra_sql'} || '';
369 $extra_param[0] = $opt->{'extra_param'} || [];
370 $order_by[0] = $opt->{'order_by'} || '';
371 $cache[0] = $opt->{'cache_obj'} || '';
372 $addl_from[0] = $opt->{'addl_from'} || '';
373 $debug[0] = $opt->{'debug'} || '';
384 my $cache = $cache[0];
390 foreach my $stable ( @stable ) {
391 #stop altering the caller's hashref
392 my $record = { %{ shift(@record) || {} } };#and be liberal in receipt
393 my $select = shift @select;
394 my $extra_sql = shift @extra_sql;
395 my $extra_param = shift @extra_param;
396 my $order_by = shift @order_by;
397 my $cache = shift @cache;
398 my $addl_from = shift @addl_from;
399 my $debug = shift @debug;
401 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
403 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
406 my $table = $cache ? $cache->table : $stable;
407 my $dbdef_table = dbdef->table($table)
408 or die "No schema for table $table found - ".
409 "do you need to run freeside-upgrade?";
410 my $pkey = $dbdef_table->primary_key;
412 my @real_fields = grep exists($record->{$_}), real_fields($table);
414 my $statement .= "SELECT $select FROM $stable";
415 $statement .= " $addl_from" if $addl_from;
416 if ( @real_fields ) {
417 $statement .= ' WHERE '. join(' AND ',
418 get_real_fields($table, $record, \@real_fields));
421 $statement .= " $extra_sql" if defined($extra_sql);
422 $statement .= " $order_by" if defined($order_by);
424 push @statement, $statement;
426 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
430 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
433 my $value = $record->{$field};
434 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
435 $value = $value->{'value'} if ref($value);
436 my $type = dbdef->table($table)->column($field)->type;
438 my $bind_type = _bind_type($type, $value);
442 # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
444 # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
448 push @bind_type, $bind_type;
452 foreach my $param ( @$extra_param ) {
453 my $bind_type = { TYPE => SQL_VARCHAR };
456 $value = $param->[0];
457 my $type = $param->[1];
458 $bind_type = _bind_type($type, $value);
461 push @bind_type, $bind_type;
465 my $statement = join( ' ) UNION ( ', @statement );
466 $statement = "( $statement )" if scalar(@statement) > 1;
467 $statement .= " $union_options{order_by}" if $union_options{order_by};
469 my $sth = $dbh->prepare($statement)
470 or croak "$dbh->errstr doing $statement";
473 foreach my $value ( @value ) {
474 my $bind_type = shift @bind_type;
475 $sth->bind_param($bind++, $value, $bind_type );
478 # $sth->execute( map $record->{$_},
479 # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
480 # ) or croak "Error executing \"$statement\": ". $sth->errstr;
482 my $ok = $sth->execute;
484 my $error = "Error executing \"$statement\"";
485 $error .= ' (' . join(', ', map {"'$_'"} @value) . ')' if @value;
486 $error .= ': '. $sth->errstr;
491 # Determine how to format rows returned form a union query:
493 # * When all queries involved in the union are from the same table:
494 # Return an array of FS::$table_name objects
496 # * When union query is performed on multiple tables,
497 # Return an array of FS::Record objects
498 # ! Note: As far as I can tell, this functionality was broken, and
499 # ! actually results in a crash. Behavior is left intact
500 # ! as-is, in case the results are in use somewhere
502 # * Union query is performed on multiple table,
503 # and $union_options{classname_from_column} = 1
504 # Return an array of FS::$classname objects, where $classname is
505 # derived for each row from a static field inserted each returned
507 # e.g.: SELECT custnum,first,last,'cust_main' AS `__classname`'.
510 my $table = $stable[0];
512 $table = '' if grep { $_ ne $table } @stable;
513 $pkey = dbdef->table($table)->primary_key if $table;
516 tie %result, "Tie::IxHash";
517 my @stuff = @{ $sth->fetchall_arrayref( {} ) };
518 if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
519 %result = map { $_->{$pkey}, $_ } @stuff;
521 @result{@stuff} = @stuff;
527 if ($union_options{classname_from_column}) {
530 # I'm not implementing the cache for this use case, at least not yet
533 for my $row (@stuff) {
534 my $table_class = $row->{__classname}
535 or die "`__classname` column must be set when ".
536 "using \$union_options{classname_from_column}";
537 push @return, new("FS::$table_class",$row);
541 elsif ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
542 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
543 #derivied class didn't override new method, so this optimization is safe
546 new_or_cached( "FS::$table", { %{$_} }, $cache )
550 new( "FS::$table", { %{$_} } )
554 #okay, its been tested
555 # warn "untested code (class FS::$table uses custom new method)";
557 eval 'FS::'. $table. '->new( { %{$_} } )';
561 # Check for encrypted fields and decrypt them.
562 ## only in the local copy, not the cached object
563 no warnings 'deprecated'; # XXX silence the warning for now
564 if ( $conf_encryption
565 && eval '@FS::'. $table . '::encrypted_fields' ) {
566 foreach my $record (@return) {
567 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
568 next if $field eq 'payinfo'
569 && ($record->isa('FS::payinfo_transaction_Mixin')
570 || $record->isa('FS::payinfo_Mixin') )
572 && !grep { $record->payby eq $_ } @encrypt_payby;
573 # Set it directly... This may cause a problem in the future...
574 $record->setfield($field, $record->decrypt($record->getfield($field)));
579 cluck "warning: FS::$table not loaded; returning FS::Record objects"
580 unless $nowarn_classload;
582 FS::Record->new( $table, { %{$_} } );
590 Construct the SQL statement and parameter-binding list for qsearch. Takes
591 the qsearch parameters.
593 Returns a hash containing:
594 'table': The primary table name (if there is one).
595 'statement': The SQL statement itself.
596 'bind_type': An arrayref of bind types.
597 'value': An arrayref of parameter values.
598 'cache': The cache object, if one was passed.
603 my( @stable, @record, @cache );
604 my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
607 my %union_options = ();
608 if ( ref($_[0]) eq 'ARRAY' ) {
611 foreach my $href ( @$optlist ) {
612 push @stable, ( $href->{'table'} or die "table name is required" );
613 push @record, ( $href->{'hashref'} || {} );
614 push @select, ( $href->{'select'} || '*' );
615 push @extra_sql, ( $href->{'extra_sql'} || '' );
616 push @extra_param, ( $href->{'extra_param'} || [] );
617 push @order_by, ( $href->{'order_by'} || '' );
618 push @cache, ( $href->{'cache_obj'} || '' );
619 push @addl_from, ( $href->{'addl_from'} || '' );
620 push @debug, ( $href->{'debug'} || '' );
622 die "at least one hashref is required" unless scalar(@stable);
623 } elsif ( ref($_[0]) eq 'HASH' ) {
625 $stable[0] = $opt->{'table'} or die "table name is required";
626 $record[0] = $opt->{'hashref'} || {};
627 $select[0] = $opt->{'select'} || '*';
628 $extra_sql[0] = $opt->{'extra_sql'} || '';
629 $extra_param[0] = $opt->{'extra_param'} || [];
630 $order_by[0] = $opt->{'order_by'} || '';
631 $cache[0] = $opt->{'cache_obj'} || '';
632 $addl_from[0] = $opt->{'addl_from'} || '';
633 $debug[0] = $opt->{'debug'} || '';
644 my $cache = $cache[0];
650 my $result_table = $stable[0];
651 foreach my $stable ( @stable ) {
652 #stop altering the caller's hashref
653 my $record = { %{ shift(@record) || {} } };#and be liberal in receipt
654 my $select = shift @select;
655 my $extra_sql = shift @extra_sql;
656 my $extra_param = shift @extra_param;
657 my $order_by = shift @order_by;
658 my $cache = shift @cache;
659 my $addl_from = shift @addl_from;
660 my $debug = shift @debug;
662 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
664 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
667 $result_table = '' if $result_table ne $stable;
669 my $table = $cache ? $cache->table : $stable;
670 my $dbdef_table = dbdef->table($table)
671 or die "No schema for table $table found - ".
672 "do you need to run freeside-upgrade?";
673 my $pkey = $dbdef_table->primary_key;
675 my @real_fields = grep exists($record->{$_}), real_fields($table);
677 my $statement .= "SELECT $select FROM $stable";
678 $statement .= " $addl_from" if $addl_from;
679 if ( @real_fields ) {
680 $statement .= ' WHERE '. join(' AND ',
681 get_real_fields($table, $record, \@real_fields));
684 $statement .= " $extra_sql" if defined($extra_sql);
685 $statement .= " $order_by" if defined($order_by);
687 push @statement, $statement;
689 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
693 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
696 my $value = $record->{$field};
697 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
698 $value = $value->{'value'} if ref($value);
699 my $type = dbdef->table($table)->column($field)->type;
701 my $bind_type = _bind_type($type, $value);
705 # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
707 # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
711 push @bind_type, $bind_type;
715 foreach my $param ( @$extra_param ) {
716 my $bind_type = { TYPE => SQL_VARCHAR };
719 $value = $param->[0];
720 my $type = $param->[1];
721 $bind_type = _bind_type($type, $value);
724 push @bind_type, $bind_type;
728 my $statement = join( ' ) UNION ( ', @statement );
729 $statement = "( $statement )" if scalar(@statement) > 1;
730 $statement .= " $union_options{order_by}" if $union_options{order_by};
733 statement => $statement,
734 bind_type => \@bind_type,
736 table => $result_table,
741 # qsearch should eventually use this
743 my ($table, $cache, @hashrefs) = @_;
745 # XXX get rid of these string evals at some point
746 # (when we have time to test it)
747 # my $class = "FS::$table" if $table;
748 # if ( $class and $class->isa('FS::Record') )
749 # if ( $class->can('new') eq \&new )
751 if ( $table && eval 'scalar(@FS::'. $table. '::ISA);' ) {
752 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
753 #derivied class didn't override new method, so this optimization is safe
756 new_or_cached( "FS::$table", { %{$_} }, $cache )
760 new( "FS::$table", { %{$_} } )
764 #okay, its been tested
765 # warn "untested code (class FS::$table uses custom new method)";
767 eval 'FS::'. $table. '->new( { %{$_} } )';
771 # Check for encrypted fields and decrypt them.
772 ## only in the local copy, not the cached object
773 if ( $conf_encryption
774 && eval '@FS::'. $table . '::encrypted_fields' ) {
775 foreach my $record (@return) {
776 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
777 next if $field eq 'payinfo'
778 && ($record->isa('FS::payinfo_transaction_Mixin')
779 || $record->isa('FS::payinfo_Mixin') )
781 && !grep { $record->payby eq $_ } @encrypt_payby;
782 # Set it directly... This may cause a problem in the future...
783 $record->setfield($field, $record->decrypt($record->getfield($field)));
788 cluck "warning: FS::$table not loaded; returning FS::Record objects"
789 unless $nowarn_classload;
791 FS::Record->new( $table, { %{$_} } );
797 sub get_real_fields {
800 my $real_fields = shift;
802 ## could be optimized more for readability
808 my $table_column = $qsearch_qualify_columns ? "$table.$column" : $column;
809 my $type = dbdef->table($table)->column($column)->type;
810 my $value = $record->{$column};
811 $value = $value->{'value'} if ref($value);
813 if ( ref($record->{$column}) ) {
814 $op = $record->{$column}{'op'} if $record->{$column}{'op'};
815 #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
816 if ( uc($op) eq 'ILIKE' ) {
818 $record->{$column}{'value'} = lc($record->{$column}{'value'});
819 $table_column = "LOWER($table_column)";
821 $record->{$column} = $record->{$column}{'value'}
824 if ( ! defined( $record->{$column} ) || $record->{$column} eq '' ) {
826 if ( driver_name eq 'Pg' ) {
827 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
828 qq-( $table_column IS NULL )-;
830 qq-( $table_column IS NULL OR $table_column = '' )-;
833 qq-( $table_column IS NULL OR $table_column = "" )-;
835 } elsif ( $op eq '!=' ) {
836 if ( driver_name eq 'Pg' ) {
837 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
838 qq-( $table_column IS NOT NULL )-;
840 qq-( $table_column IS NOT NULL AND $table_column != '' )-;
843 qq-( $table_column IS NOT NULL AND $table_column != "" )-;
846 if ( driver_name eq 'Pg' ) {
847 qq-( $table_column $op '' )-;
849 qq-( $table_column $op "" )-;
852 } elsif ( $op eq '!=' ) {
853 qq-( $table_column IS NULL OR $table_column != ? )-;
854 #if this needs to be re-enabled, it needs to use a custom op like
855 #"APPROX=" or something (better name?, not '=', to avoid affecting other
857 #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
858 # ( "$table_column <= ?", "$table_column >= ?" );
860 "$table_column $op ?";
867 =item by_key PRIMARY_KEY_VALUE
869 This is a class method that returns the record with the given primary key
870 value. This method is only useful in FS::Record subclasses. For example:
872 my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
876 my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
881 my ($class, $pkey_value) = @_;
883 my $table = $class->table
884 or croak "No table for $class found";
886 my $dbdef_table = dbdef->table($table)
887 or die "No schema for table $table found - ".
888 "do you need to create it or run dbdef-create?";
889 my $pkey = $dbdef_table->primary_key
890 or die "No primary key for table $table";
892 return qsearchs($table, { $pkey => $pkey_value });
895 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
897 Experimental JOINed search method. Using this method, you can execute a
898 single SELECT spanning multiple tables, and cache the results for subsequent
899 method calls. Interface will almost definately change in an incompatible
907 my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
908 my $cache = FS::SearchCache->new( $ptable, $pkey );
911 grep { !$saw{$_->getfield($pkey)}++ }
912 qsearch($table, $record, $select, $extra_sql, $cache )
916 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
918 Same as qsearch, except that if more than one record matches, it B<carp>s but
919 returns the first. If this happens, you either made a logic error in asking
920 for a single item, or your data is corrupted.
924 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
926 my(@result) = qsearch(@_);
927 cluck "warning: Multiple records in scalar search ($table)"
928 if scalar(@result) > 1;
929 #should warn more vehemently if the search was on a primary key?
930 scalar(@result) ? ($result[0]) : ();
941 Returns the table name.
946 # cluck "warning: FS::Record::table deprecated; supply one in subclass!";
953 Returns the DBIx::DBSchema::Table object for the table.
959 my($table)=$self->table;
960 dbdef->table($table);
965 Returns the primary key for the table.
971 my $pkey = $self->dbdef_table->primary_key;
974 =item get, getfield COLUMN
976 Returns the value of the column/field/key COLUMN.
981 my($self,$field) = @_;
982 # to avoid "Use of unitialized value" errors
983 if ( defined ( $self->{Hash}->{$field} ) ) {
984 $self->{Hash}->{$field};
994 =item set, setfield COLUMN, VALUE
996 Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE.
1001 my($self,$field,$value) = @_;
1002 $self->{'modified'} = 1;
1003 $self->{'Hash'}->{$field} = $value;
1012 Returns true if the column/field/key COLUMN exists.
1017 my($self,$field) = @_;
1018 exists($self->{Hash}->{$field});
1021 =item AUTLOADED METHODS
1023 $record->column is a synonym for $record->get('column');
1025 $record->column('value') is a synonym for $record->set('column','value');
1031 my($self,$value)=@_;
1032 my($field)=$AUTOLOAD;
1034 if ( defined($value) ) {
1035 confess "errant AUTOLOAD $field for $self (arg $value)"
1036 unless blessed($self) && $self->can('setfield');
1037 $self->setfield($field,$value);
1039 confess "errant AUTOLOAD $field for $self (no args)"
1040 unless blessed($self) && $self->can('getfield');
1041 $self->getfield($field);
1047 # my $field = $AUTOLOAD;
1048 # $field =~ s/.*://;
1049 # if ( defined($_[1]) ) {
1050 # $_[0]->setfield($field, $_[1]);
1052 # $_[0]->getfield($field);
1058 Returns a list of the column/value pairs, usually for assigning to a new hash.
1060 To make a distinct duplicate of an FS::Record object, you can do:
1062 $new = new FS::Record ( $old->table, { $old->hash } );
1068 confess $self. ' -> hash: Hash attribute is undefined'
1069 unless defined($self->{'Hash'});
1070 %{ $self->{'Hash'} };
1075 Returns a reference to the column/value hash. This may be deprecated in the
1076 future; if there's a reason you can't just use the autoloaded or get/set
1088 Returns true if any of this object's values have been modified with set (or via
1089 an autoloaded method). Doesn't yet recognize when you retreive a hashref and
1096 $self->{'modified'};
1099 =item select_for_update
1101 Selects this record with the SQL "FOR UPDATE" command. This can be useful as
1106 sub select_for_update {
1108 my $primary_key = $self->primary_key;
1111 'table' => $self->table,
1112 'hashref' => { $primary_key => $self->$primary_key() },
1113 'extra_sql' => 'FOR UPDATE',
1119 Locks this table with a database-driver specific lock method. This is used
1120 as a mutex in order to do a duplicate search.
1122 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
1124 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
1126 Errors are fatal; no useful return value.
1128 Note: To use this method for new tables other than svc_acct and svc_phone,
1129 edit freeside-upgrade and add those tables to the duplicate_lock list.
1135 my $table = $self->table;
1137 warn "$me locking $table table\n" if $DEBUG;
1139 if ( driver_name =~ /^Pg/i ) {
1141 dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
1144 } elsif ( driver_name =~ /^mysql/i ) {
1146 dbh->do("SELECT * FROM duplicate_lock
1147 WHERE lockname = '$table'
1149 ) or die dbh->errstr;
1153 die "unknown database ". driver_name. "; don't know how to lock table";
1157 warn "$me acquired $table table lock\n" if $DEBUG;
1163 Inserts this record to the database. If there is an error, returns the error,
1164 otherwise returns false.
1172 warn "$self -> insert" if $DEBUG;
1174 my $error = $self->check;
1175 return $error if $error;
1177 #single-field non-null unique keys are given a value if empty
1178 #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
1179 foreach ( $self->dbdef_table->unique_singles) {
1180 next if $self->getfield($_);
1181 next if $self->dbdef_table->column($_)->null eq 'NULL';
1185 #and also the primary key, if the database isn't going to
1186 my $primary_key = $self->dbdef_table->primary_key;
1188 if ( $primary_key ) {
1189 my $col = $self->dbdef_table->column($primary_key);
1192 uc($col->type) =~ /^(BIG)?SERIAL\d?/
1193 || ( driver_name eq 'Pg'
1194 && defined($col->default)
1195 && $col->quoted_default =~ /^nextval\(/i
1197 || ( driver_name eq 'mysql'
1198 && defined($col->local)
1199 && $col->local =~ /AUTO_INCREMENT/i
1201 $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
1204 my $table = $self->table;
1206 # Encrypt before the database
1207 if ( scalar( eval '@FS::'. $table . '::encrypted_fields')
1210 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
1211 next if $field eq 'payinfo'
1212 && ($self->isa('FS::payinfo_transaction_Mixin')
1213 || $self->isa('FS::payinfo_Mixin') )
1215 && !grep { $self->payby eq $_ } @encrypt_payby;
1216 $saved->{$field} = $self->getfield($field);
1217 $self->setfield($field, $self->encrypt($self->getfield($field)));
1221 #false laziness w/delete
1223 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1226 my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
1229 my $statement = "INSERT INTO $table ";
1230 if ( @real_fields ) {
1233 join( ', ', @real_fields ).
1235 join( ', ', @values ).
1239 $statement .= 'DEFAULT VALUES';
1241 warn "[debug]$me $statement\n" if $DEBUG > 1;
1242 my $sth = dbh->prepare($statement) or return dbh->errstr;
1244 local $SIG{HUP} = 'IGNORE';
1245 local $SIG{INT} = 'IGNORE';
1246 local $SIG{QUIT} = 'IGNORE';
1247 local $SIG{TERM} = 'IGNORE';
1248 local $SIG{TSTP} = 'IGNORE';
1249 local $SIG{PIPE} = 'IGNORE';
1251 $sth->execute or return $sth->errstr;
1253 # get inserted id from the database, if applicable & needed
1254 if ( $db_seq && ! $self->getfield($primary_key) ) {
1255 warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
1259 if ( driver_name eq 'Pg' ) {
1261 #my $oid = $sth->{'pg_oid_status'};
1262 #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
1264 my $default = $self->dbdef_table->column($primary_key)->quoted_default;
1265 unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
1266 dbh->rollback if $FS::UID::AutoCommit;
1267 return "can't parse $table.$primary_key default value".
1268 " for sequence name: $default";
1272 my $i_sql = "SELECT currval('$sequence')";
1273 my $i_sth = dbh->prepare($i_sql) or do {
1274 dbh->rollback if $FS::UID::AutoCommit;
1277 $i_sth->execute() or do { #$i_sth->execute($oid)
1278 dbh->rollback if $FS::UID::AutoCommit;
1279 return $i_sth->errstr;
1281 $insertid = $i_sth->fetchrow_arrayref->[0];
1283 } elsif ( driver_name eq 'mysql' ) {
1285 $insertid = dbh->{'mysql_insertid'};
1286 # work around mysql_insertid being null some of the time, ala RT :/
1287 unless ( $insertid ) {
1288 warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
1289 "using SELECT LAST_INSERT_ID();";
1290 my $i_sql = "SELECT LAST_INSERT_ID()";
1291 my $i_sth = dbh->prepare($i_sql) or do {
1292 dbh->rollback if $FS::UID::AutoCommit;
1295 $i_sth->execute or do {
1296 dbh->rollback if $FS::UID::AutoCommit;
1297 return $i_sth->errstr;
1299 $insertid = $i_sth->fetchrow_arrayref->[0];
1304 dbh->rollback if $FS::UID::AutoCommit;
1305 return "don't know how to retreive inserted ids from ". driver_name.
1306 ", try using counterfiles (maybe run dbdef-create?)";
1310 $self->setfield($primary_key, $insertid);
1315 if ( defined( dbdef->table('h_'. $table) ) && ! $no_history ) {
1316 my $h_statement = $self->_h_statement('insert');
1317 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1318 $h_sth = dbh->prepare($h_statement) or do {
1319 dbh->rollback if $FS::UID::AutoCommit;
1325 $h_sth->execute or return $h_sth->errstr if $h_sth;
1327 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1329 # Now that it has been saved, reset the encrypted fields so that $new
1330 # can still be used.
1331 foreach my $field (keys %{$saved}) {
1332 $self->setfield($field, $saved->{$field});
1340 Depriciated (use insert instead).
1345 cluck "warning: FS::Record::add deprecated!";
1346 insert @_; #call method in this scope
1351 Delete this record from the database. If there is an error, returns the error,
1352 otherwise returns false.
1359 my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1361 $self->getfield($_) eq ''
1362 #? "( $_ IS NULL OR $_ = \"\" )"
1363 ? ( driver_name eq 'Pg'
1365 : "( $_ IS NULL OR $_ = \"\" )"
1367 : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1368 } ( $self->dbdef_table->primary_key )
1369 ? ( $self->dbdef_table->primary_key)
1370 : real_fields($self->table)
1372 warn "[debug]$me $statement\n" if $DEBUG > 1;
1373 my $sth = dbh->prepare($statement) or return dbh->errstr;
1376 if ( defined dbdef->table('h_'. $self->table) ) {
1377 my $h_statement = $self->_h_statement('delete');
1378 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1379 $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1384 my $primary_key = $self->dbdef_table->primary_key;
1386 local $SIG{HUP} = 'IGNORE';
1387 local $SIG{INT} = 'IGNORE';
1388 local $SIG{QUIT} = 'IGNORE';
1389 local $SIG{TERM} = 'IGNORE';
1390 local $SIG{TSTP} = 'IGNORE';
1391 local $SIG{PIPE} = 'IGNORE';
1393 my $rc = $sth->execute or return $sth->errstr;
1394 #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1395 $h_sth->execute or return $h_sth->errstr if $h_sth;
1397 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1399 #no need to needlessly destoy the data either (causes problems actually)
1400 #undef $self; #no need to keep object!
1407 Depriciated (use delete instead).
1412 cluck "warning: FS::Record::del deprecated!";
1413 &delete(@_); #call method in this scope
1416 =item replace OLD_RECORD
1418 Replace the OLD_RECORD with this one in the database. If there is an error,
1419 returns the error, otherwise returns false.
1424 my ($new, $old) = (shift, shift);
1426 $old = $new->replace_old unless defined($old);
1428 warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1430 if ( $new->can('replace_check') ) {
1431 my $error = $new->replace_check($old);
1432 return $error if $error;
1435 return "Records not in same table!" unless $new->table eq $old->table;
1437 my $primary_key = $old->dbdef_table->primary_key;
1438 return "Can't change primary key $primary_key ".
1439 'from '. $old->getfield($primary_key).
1440 ' to ' . $new->getfield($primary_key)
1442 && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1444 my $error = $new->check;
1445 return $error if $error;
1447 # Encrypt for replace
1449 if ( scalar( eval '@FS::'. $new->table . '::encrypted_fields')
1452 foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1453 next if $field eq 'payinfo'
1454 && ($new->isa('FS::payinfo_transaction_Mixin')
1455 || $new->isa('FS::payinfo_Mixin') )
1457 && !grep { $new->payby eq $_ } @encrypt_payby;
1458 $saved->{$field} = $new->getfield($field);
1459 $new->setfield($field, $new->encrypt($new->getfield($field)));
1463 #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1464 my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1465 ? ($_, $new->getfield($_)) : () } $old->fields;
1467 unless (keys(%diff) || $no_update_diff ) {
1468 carp "[warning]$me ". ref($new)."->replace ".
1469 ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
1470 ": records identical"
1471 unless $nowarn_identical;
1475 my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1477 "$_ = ". _quote($new->getfield($_),$old->table,$_)
1478 } real_fields($old->table)
1483 if ( $old->getfield($_) eq '' ) {
1485 #false laziness w/qsearch
1486 if ( driver_name eq 'Pg' ) {
1487 my $type = $old->dbdef_table->column($_)->type;
1488 if ( $type =~ /(int|(big)?serial)/i ) {
1491 qq-( $_ IS NULL OR $_ = '' )-;
1494 qq-( $_ IS NULL OR $_ = "" )-;
1498 "$_ = ". _quote($old->getfield($_),$old->table,$_);
1501 } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1504 warn "[debug]$me $statement\n" if $DEBUG > 1;
1505 my $sth = dbh->prepare($statement) or return dbh->errstr;
1508 if ( defined dbdef->table('h_'. $old->table) ) {
1509 my $h_old_statement = $old->_h_statement('replace_old');
1510 warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1511 $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1517 if ( defined dbdef->table('h_'. $new->table) ) {
1518 my $h_new_statement = $new->_h_statement('replace_new');
1519 warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1520 $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1525 local $SIG{HUP} = 'IGNORE';
1526 local $SIG{INT} = 'IGNORE';
1527 local $SIG{QUIT} = 'IGNORE';
1528 local $SIG{TERM} = 'IGNORE';
1529 local $SIG{TSTP} = 'IGNORE';
1530 local $SIG{PIPE} = 'IGNORE';
1532 my $rc = $sth->execute or return $sth->errstr;
1533 #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1534 $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1535 $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1537 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1539 # Now that it has been saved, reset the encrypted fields so that $new
1540 # can still be used.
1541 foreach my $field (keys %{$saved}) {
1542 $new->setfield($field, $saved->{$field});
1550 my( $self ) = shift;
1551 warn "[$me] replace called with no arguments; autoloading old record\n"
1554 my $primary_key = $self->dbdef_table->primary_key;
1555 if ( $primary_key ) {
1556 $self->by_key( $self->$primary_key() ) #this is what's returned
1557 or croak "can't find ". $self->table. ".$primary_key ".
1558 $self->$primary_key();
1560 croak $self->table. " has no primary key; pass old record as argument";
1567 Depriciated (use replace instead).
1572 cluck "warning: FS::Record::rep deprecated!";
1573 replace @_; #call method in this scope
1578 Checks custom fields. Subclasses should still provide a check method to validate
1579 non-custom fields, foreign keys, etc., and call this method via $self->SUPER::check.
1585 foreach my $field ($self->virtual_fields) {
1586 my $error = $self->ut_textn($field);
1587 return $error if $error;
1592 =item virtual_fields [ TABLE ]
1594 Returns a list of virtual fields defined for the table. This should not
1595 be exported, and should only be called as an instance or class method.
1599 sub virtual_fields {
1602 $table = $self->table or confess "virtual_fields called on non-table";
1604 confess "Unknown table $table" unless dbdef->table($table);
1606 return () unless dbdef->table('part_virtual_field');
1608 unless ( $virtual_fields_cache{$table} ) {
1609 my $concat = [ "'cf_'", "name" ];
1610 my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' .
1611 "WHERE dbtable = '$table'";
1613 my $result = $dbh->selectcol_arrayref($query);
1614 confess "Error executing virtual fields query: $query: ". $dbh->errstr
1616 $virtual_fields_cache{$table} = $result;
1619 @{$virtual_fields_cache{$table}};
1623 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1625 Processes a batch import as a queued JSRPC job
1627 JOB is an FS::queue entry.
1629 OPTIONS_HASHREF can have the following keys:
1635 Table name (required).
1639 Arrayref of field names for static fields. They will be given values from the
1640 PARAMS hashref and passed as a "params" hashref to batch_import.
1644 Formats hashref. Keys are field names, values are listrefs that define the
1647 Each listref value can be a column name or a code reference. Coderefs are run
1648 with the row object, data and a FS::Conf object as the three parameters.
1649 For example, this coderef does the same thing as using the "columnname" string:
1652 my( $record, $data, $conf ) = @_;
1653 $record->columnname( $data );
1656 Coderefs are run after all "column name" fields are assigned.
1660 Optional format hashref of types. Keys are field names, values are "csv",
1661 "xls" or "fixedlength". Overrides automatic determination of file type
1664 =item format_headers
1666 Optional format hashref of header lines. Keys are field names, values are 0
1667 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1670 =item format_sep_chars
1672 Optional format hashref of CSV sep_chars. Keys are field names, values are the
1673 CSV separation character.
1675 =item format_fixedlenth_formats
1677 Optional format hashref of fixed length format defintiions. Keys are field
1678 names, values Parse::FixedLength listrefs of field definitions.
1682 Set true to default to CSV file type if the filename does not contain a
1683 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1688 PARAMS is a hashref (or base64-encoded Storable hashref) containing the
1689 POSTed data. It must contain the field "uploaded files", generated by
1690 /elements/file-upload.html and containing the list of uploaded files.
1691 Currently only supports a single file named "file".
1695 # uploaded_files is kind of bizarre; fix that some time
1697 use Storable qw(thaw);
1700 sub process_batch_import {
1701 my($job, $opt) = ( shift, shift );
1703 my $table = $opt->{table};
1704 my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1705 my %formats = %{ $opt->{formats} };
1708 # because some job-spawning code (JSRPC) pre-freezes the arguments,
1709 # and then the 'frozen' attribute doesn't get set, and thus $job->args
1710 # doesn't know to thaw them, we have to do this everywhere.
1712 $param = thaw(decode_base64($param));
1714 warn Dumper($param) if $DEBUG;
1716 my $files = $param->{'uploaded_files'}
1717 or die "No files provided.\n";
1719 my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1721 my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1722 my $file = $dir. $files{'file'};
1727 formats => \%formats,
1728 format_types => $opt->{format_types},
1729 format_headers => $opt->{format_headers},
1730 format_sep_chars => $opt->{format_sep_chars},
1731 format_fixedlength_formats => $opt->{format_fixedlength_formats},
1732 format_xml_formats => $opt->{format_xml_formats},
1733 format_asn_formats => $opt->{format_asn_formats},
1734 format_row_callbacks => $opt->{format_row_callbacks},
1735 format_hash_callbacks => $opt->{format_hash_callbacks},
1740 format => $param->{format},
1741 params => { map { $_ => $param->{$_} } @pass_params },
1743 default_csv => $opt->{default_csv},
1744 preinsert_callback => $opt->{preinsert_callback},
1745 postinsert_callback => $opt->{postinsert_callback},
1746 insert_args_callback => $opt->{insert_args_callback},
1749 if ( $opt->{'batch_namecol'} ) {
1750 $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1751 $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1754 my $error = FS::Record::batch_import( \%iopt );
1758 die "$error\n" if $error;
1761 =item batch_import PARAM_HASHREF
1763 Class method for batch imports. Available params:
1769 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1775 =item format_headers
1777 =item format_sep_chars
1779 =item format_fixedlength_formats
1781 =item format_row_callbacks
1783 =item format_hash_callbacks - After parsing, before object creation
1785 =item fields - Alternate way to specify import, specifying import fields directly as a listref
1787 =item preinsert_callback
1789 =item postinsert_callback
1795 FS::queue object, will be updated with progress
1801 csv, xls, fixedlength, xml
1812 warn "$me batch_import call with params: \n". Dumper($param)
1815 my $table = $param->{table};
1817 my $job = $param->{job};
1818 my $file = $param->{file};
1819 my $params = $param->{params} || {};
1821 my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
1822 my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
1824 my( $type, $header, $sep_char,
1825 $fixedlength_format, $xml_format, $asn_format,
1826 $parser_opt, $row_callback, $hash_callback, @fields );
1828 my $postinsert_callback = '';
1829 $postinsert_callback = $param->{'postinsert_callback'}
1830 if $param->{'postinsert_callback'};
1831 my $preinsert_callback = '';
1832 $preinsert_callback = $param->{'preinsert_callback'}
1833 if $param->{'preinsert_callback'};
1834 my $insert_args_callback = '';
1835 $insert_args_callback = $param->{'insert_args_callback'}
1836 if $param->{'insert_args_callback'};
1838 if ( $param->{'format'} ) {
1840 my $format = $param->{'format'};
1841 my $formats = $param->{formats};
1842 die "unknown format $format" unless exists $formats->{ $format };
1844 $type = $param->{'format_types'}
1845 ? $param->{'format_types'}{ $format }
1846 : $param->{type} || 'csv';
1849 $header = $param->{'format_headers'}
1850 ? $param->{'format_headers'}{ $param->{'format'} }
1853 $sep_char = $param->{'format_sep_chars'}
1854 ? $param->{'format_sep_chars'}{ $param->{'format'} }
1857 $fixedlength_format =
1858 $param->{'format_fixedlength_formats'}
1859 ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1863 $param->{'format_parser_opts'}
1864 ? $param->{'format_parser_opts'}{ $param->{'format'} }
1868 $param->{'format_xml_formats'}
1869 ? $param->{'format_xml_formats'}{ $param->{'format'} }
1873 $param->{'format_asn_formats'}
1874 ? $param->{'format_asn_formats'}{ $param->{'format'} }
1878 $param->{'format_row_callbacks'}
1879 ? $param->{'format_row_callbacks'}{ $param->{'format'} }
1883 $param->{'format_hash_callbacks'}
1884 ? $param->{'format_hash_callbacks'}{ $param->{'format'} }
1887 @fields = @{ $formats->{ $format } };
1889 } elsif ( $param->{'fields'} ) {
1891 $type = ''; #infer from filename
1894 $fixedlength_format = '';
1896 $hash_callback = '';
1897 @fields = @{ $param->{'fields'} };
1900 die "neither format nor fields specified";
1903 #my $file = $param->{file};
1906 if ( $file =~ /\.(\w+)$/i ) {
1910 warn "can't parse file type from filename $file; defaulting to CSV";
1914 if $param->{'default_csv'} && $type ne 'xls';
1922 my $asn_header_buffer;
1923 if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1925 if ( $type eq 'csv' ) {
1927 $parser_opt->{'binary'} = 1;
1928 $parser_opt->{'sep_char'} = $sep_char if $sep_char;
1929 $parser = Text::CSV_XS->new($parser_opt);
1931 } elsif ( $type eq 'fixedlength' ) {
1933 eval "use Parse::FixedLength;";
1935 $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
1938 die "Unknown file type $type\n";
1941 @buffer = split(/\r?\n/, slurp($file) );
1942 splice(@buffer, 0, ($header || 0) );
1943 $count = scalar(@buffer);
1945 } elsif ( $type eq 'xls' ) {
1947 eval "use Spreadsheet::ParseExcel;";
1950 eval "use DateTime::Format::Excel;";
1951 #for now, just let the error be thrown if it is used, since only CDR
1952 # formats bill_west and troop use it, not other excel-parsing things
1955 my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
1957 $parser = $excel->{Worksheet}[0]; #first sheet
1959 $count = $parser->{MaxRow} || $parser->{MinRow};
1962 $row = $header || 0;
1964 } elsif ( $type eq 'xml' ) {
1967 eval "use XML::Simple;";
1969 my $xmlrow = $xml_format->{'xmlrow'};
1970 $parser = $xml_format->{'xmlkeys'};
1971 die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
1972 my $data = XML::Simple::XMLin(
1974 'SuppressEmpty' => '', #sets empty values to ''
1978 $rows = $rows->{$_} foreach @$xmlrow;
1979 $rows = [ $rows ] if ref($rows) ne 'ARRAY';
1980 $count = @buffer = @$rows;
1982 } elsif ( $type eq 'asn.1' ) {
1984 eval "use Convert::ASN1";
1987 my $asn = Convert::ASN1->new;
1988 $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
1990 $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
1992 my $data = slurp($file);
1993 my $asn_output = $parser->decode( $data )
1994 or return "No ". $asn_format->{'macro'}. " found\n";
1996 $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
1998 my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
1999 $count = @buffer = @$rows;
2002 die "Unknown file type $type\n";
2007 local $SIG{HUP} = 'IGNORE';
2008 local $SIG{INT} = 'IGNORE';
2009 local $SIG{QUIT} = 'IGNORE';
2010 local $SIG{TERM} = 'IGNORE';
2011 local $SIG{TSTP} = 'IGNORE';
2012 local $SIG{PIPE} = 'IGNORE';
2014 my $oldAutoCommit = $FS::UID::AutoCommit;
2015 local $FS::UID::AutoCommit = 0;
2018 #my $params = $param->{params} || {};
2019 if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
2020 my $batch_col = $param->{'batch_keycol'};
2022 my $batch_class = 'FS::'. $param->{'batch_table'};
2023 my $batch = $batch_class->new({
2024 $param->{'batch_namecol'} => $param->{'batch_namevalue'}
2026 my $error = $batch->insert;
2028 $dbh->rollback if $oldAutoCommit;
2029 return "can't insert batch record: $error";
2031 #primary key via dbdef? (so the column names don't have to match)
2032 my $batch_value = $batch->get( $param->{'batch_keycol'} );
2034 $params->{ $batch_col } = $batch_value;
2037 #my $job = $param->{job};
2040 my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
2044 my %hash = %$params;
2045 if ( $type eq 'csv' ) {
2047 last unless scalar(@buffer);
2048 $line = shift(@buffer);
2050 next if $line =~ /^\s*$/; #skip empty lines
2052 $line = &{$row_callback}($line) if $row_callback;
2054 next if $line =~ /^\s*$/; #skip empty lines
2056 $parser->parse($line) or do {
2057 $dbh->rollback if $oldAutoCommit;
2058 return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
2060 @columns = $parser->fields();
2062 } elsif ( $type eq 'fixedlength' ) {
2064 last unless scalar(@buffer);
2065 $line = shift(@buffer);
2067 @columns = $parser->parse($line);
2069 } elsif ( $type eq 'xls' ) {
2071 last if $row > ($parser->{MaxRow} || $parser->{MinRow})
2072 || ! $parser->{Cells}[$row];
2074 my @row = @{ $parser->{Cells}[$row] };
2075 @columns = map $_->{Val}, @row;
2078 #warn $z++. ": $_\n" for @columns;
2080 } elsif ( $type eq 'xml' ) {
2082 # $parser = [ 'Column0Key', 'Column1Key' ... ]
2083 last unless scalar(@buffer);
2084 my $row = shift @buffer;
2085 @columns = @{ $row }{ @$parser };
2087 } elsif ( $type eq 'asn.1' ) {
2089 last unless scalar(@buffer);
2090 my $row = shift @buffer;
2091 &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2092 if $asn_format->{row_callback};
2093 foreach my $key ( keys %{ $asn_format->{map} } ) {
2094 $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2098 die "Unknown file type $type\n";
2103 foreach my $field ( @fields ) {
2105 my $value = shift @columns;
2107 if ( ref($field) eq 'CODE' ) {
2108 #&{$field}(\%hash, $value);
2109 push @later, $field, $value;
2111 #??? $hash{$field} = $value if length($value);
2112 $hash{$field} = $value if defined($value) && length($value);
2117 if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
2118 && length($1) == $custnum_length ) {
2119 $hash{custnum} = $2;
2122 %hash = &{$hash_callback}(%hash) if $hash_callback;
2124 #my $table = $param->{table};
2125 my $class = "FS::$table";
2127 my $record = $class->new( \%hash );
2130 while ( scalar(@later) ) {
2131 my $sub = shift @later;
2132 my $data = shift @later;
2134 &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2137 $dbh->rollback if $oldAutoCommit;
2138 return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2140 last if exists( $param->{skiprow} );
2142 next if exists( $param->{skiprow} );
2144 if ( $preinsert_callback ) {
2145 my $error = &{$preinsert_callback}($record, $param);
2147 $dbh->rollback if $oldAutoCommit;
2148 return "preinsert_callback error". ( $line ? " for $line" : '' ).
2151 next if exists $param->{skiprow} && $param->{skiprow};
2154 my @insert_args = ();
2155 if ( $insert_args_callback ) {
2156 @insert_args = &{$insert_args_callback}($record, $param);
2159 my $error = $record->insert(@insert_args);
2162 $dbh->rollback if $oldAutoCommit;
2163 return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2169 if ( $postinsert_callback ) {
2170 my $error = &{$postinsert_callback}($record, $param);
2172 $dbh->rollback if $oldAutoCommit;
2173 return "postinsert_callback error". ( $line ? " for $line" : '' ).
2178 if ( $job && time - $min_sec > $last ) { #progress bar
2179 $job->update_statustext( int(100 * $imported / $count) );
2185 unless ( $imported || $param->{empty_ok} ) {
2186 $dbh->rollback if $oldAutoCommit;
2187 return "Empty file!";
2190 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2197 my( $self, $action, $time ) = @_;
2201 my %nohistory = map { $_=>1 } $self->nohistory_fields;
2204 grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2205 real_fields($self->table);
2208 # If we're encrypting then don't store the payinfo in the history
2209 if ( $conf_encryption && $self->table ne 'banned_pay' ) {
2210 @fields = grep { $_ ne 'payinfo' } @fields;
2213 my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2215 "INSERT INTO h_". $self->table. " ( ".
2216 join(', ', qw(history_date history_user history_action), @fields ).
2219 dbh->quote($FS::CurrentUser::CurrentUser->username),
2220 dbh->quote($action),
2229 B<Warning>: External use is B<deprecated>.
2231 Replaces COLUMN in record with a unique number, using counters in the
2232 filesystem. Used by the B<insert> method on single-field unique columns
2233 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2234 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2236 Returns the new value.
2241 my($self,$field) = @_;
2242 my($table)=$self->table;
2244 croak "Unique called on field $field, but it is ",
2245 $self->getfield($field),
2247 if $self->getfield($field);
2249 #warn "table $table is tainted" if is_tainted($table);
2250 #warn "field $field is tainted" if is_tainted($field);
2252 my($counter) = new File::CounterFile "$table.$field",0;
2254 # getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
2256 # my($counter) = new File::CounterFile "$user/$table.$field",0;
2259 my $index = $counter->inc;
2260 $index = $counter->inc while qsearchs($table, { $field=>$index } );
2262 $index =~ /^(\d*)$/;
2265 $self->setfield($field,$index);
2269 =item ut_float COLUMN
2271 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be
2272 null. If there is an error, returns the error, otherwise returns false.
2277 my($self,$field)=@_ ;
2278 ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2279 $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2280 $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2281 $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2282 or return "Illegal or empty (float) $field: ". $self->getfield($field);
2283 $self->setfield($field,$1);
2286 =item ut_floatn COLUMN
2288 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
2289 null. If there is an error, returns the error, otherwise returns false.
2293 #false laziness w/ut_ipn
2295 my( $self, $field ) = @_;
2296 if ( $self->getfield($field) =~ /^()$/ ) {
2297 $self->setfield($field,'');
2300 $self->ut_float($field);
2304 =item ut_sfloat COLUMN
2306 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2307 May not be null. If there is an error, returns the error, otherwise returns
2313 my($self,$field)=@_ ;
2314 ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2315 $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2316 $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2317 $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2318 or return "Illegal or empty (float) $field: ". $self->getfield($field);
2319 $self->setfield($field,$1);
2322 =item ut_sfloatn COLUMN
2324 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
2325 null. If there is an error, returns the error, otherwise returns false.
2330 my( $self, $field ) = @_;
2331 if ( $self->getfield($field) =~ /^()$/ ) {
2332 $self->setfield($field,'');
2335 $self->ut_sfloat($field);
2339 =item ut_snumber COLUMN
2341 Check/untaint signed numeric data (whole numbers). If there is an error,
2342 returns the error, otherwise returns false.
2347 my($self, $field) = @_;
2348 $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2349 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2350 $self->setfield($field, "$1$2");
2354 =item ut_snumbern COLUMN
2356 Check/untaint signed numeric data (whole numbers). If there is an error,
2357 returns the error, otherwise returns false.
2362 my($self, $field) = @_;
2363 $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2364 or return "Illegal (numeric) $field: ". $self->getfield($field);
2366 return "Illegal (numeric) $field: ". $self->getfield($field)
2369 $self->setfield($field, "$1$2");
2373 =item ut_number COLUMN
2375 Check/untaint simple numeric data (whole numbers). May not be null. If there
2376 is an error, returns the error, otherwise returns false.
2381 my($self,$field)=@_;
2382 $self->getfield($field) =~ /^\s*(\d+)\s*$/
2383 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2384 $self->setfield($field,$1);
2388 =item ut_numbern COLUMN
2390 Check/untaint simple numeric data (whole numbers). May be null. If there is
2391 an error, returns the error, otherwise returns false.
2396 my($self,$field)=@_;
2397 $self->getfield($field) =~ /^\s*(\d*)\s*$/
2398 or return "Illegal (numeric) $field: ". $self->getfield($field);
2399 $self->setfield($field,$1);
2403 =item ut_decimal COLUMN[, DIGITS]
2405 Check/untaint decimal numbers (up to DIGITS decimal places. If there is an
2406 error, returns the error, otherwise returns false.
2408 =item ut_decimaln COLUMN[, DIGITS]
2410 Check/untaint decimal numbers. May be null. If there is an error, returns
2411 the error, otherwise returns false.
2416 my($self, $field, $digits) = @_;
2418 $self->getfield($field) =~ /^\s*(\d+(\.\d{0,$digits})?)\s*$/
2419 or return "Illegal or empty (decimal) $field: ".$self->getfield($field);
2420 $self->setfield($field, $1);
2425 my($self, $field, $digits) = @_;
2426 $self->getfield($field) =~ /^\s*(\d*(\.\d{0,$digits})?)\s*$/
2427 or return "Illegal (decimal) $field: ".$self->getfield($field);
2428 $self->setfield($field, $1);
2432 =item ut_money COLUMN
2434 Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
2435 is an error, returns the error, otherwise returns false.
2440 my($self,$field)=@_;
2442 if ( $self->getfield($field) eq '' ) {
2443 $self->setfield($field, 0);
2444 } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2445 #handle one decimal place without barfing out
2446 $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2447 } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2448 $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2450 return "Illegal (money) $field: ". $self->getfield($field);
2456 =item ut_moneyn COLUMN
2458 Check/untaint monetary numbers. May be negative. If there
2459 is an error, returns the error, otherwise returns false.
2464 my($self,$field)=@_;
2465 if ($self->getfield($field) eq '') {
2466 $self->setfield($field, '');
2469 $self->ut_money($field);
2472 =item ut_text COLUMN
2474 Check/untaint text. Alphanumerics, spaces, and the following punctuation
2475 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < > ~
2476 May not be null. If there is an error, returns the error, otherwise returns
2482 my($self,$field)=@_;
2483 #warn "msgcat ". \&msgcat. "\n";
2484 #warn "notexist ". \¬exist. "\n";
2485 #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2486 # \p{Word} = alphanumerics, marks (diacritics), and connectors
2487 # see perldoc perluniprops
2488 $self->getfield($field)
2489 =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>\~$money_char]+)$/
2490 or return gettext('illegal_or_empty_text'). " $field: ".
2491 $self->getfield($field);
2492 $self->setfield($field,$1);
2496 =item ut_textn COLUMN
2498 Check/untaint text. Alphanumerics, spaces, and the following punctuation
2499 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2500 May be null. If there is an error, returns the error, otherwise returns false.
2505 my($self,$field)=@_;
2506 return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2507 $self->ut_text($field);
2510 =item ut_alpha COLUMN
2512 Check/untaint alphanumeric strings (no spaces). May not be null. If there is
2513 an error, returns the error, otherwise returns false.
2518 my($self,$field)=@_;
2519 $self->getfield($field) =~ /^(\w+)$/
2520 or return "Illegal or empty (alphanumeric) $field: ".
2521 $self->getfield($field);
2522 $self->setfield($field,$1);
2526 =item ut_alphan COLUMN
2528 Check/untaint alphanumeric strings (no spaces). May be null. If there is an
2529 error, returns the error, otherwise returns false.
2534 my($self,$field)=@_;
2535 $self->getfield($field) =~ /^(\w*)$/
2536 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2537 $self->setfield($field,$1);
2541 =item ut_alphasn COLUMN
2543 Check/untaint alphanumeric strings, spaces allowed. May be null. If there is
2544 an error, returns the error, otherwise returns false.
2549 my($self,$field)=@_;
2550 $self->getfield($field) =~ /^([\w ]*)$/
2551 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2552 $self->setfield($field,$1);
2557 =item ut_alpha_lower COLUMN
2559 Check/untaint lowercase alphanumeric strings (no spaces). May not be null. If
2560 there is an error, returns the error, otherwise returns false.
2564 sub ut_alpha_lower {
2565 my($self,$field)=@_;
2566 $self->getfield($field) =~ /[[:upper:]]/
2567 and return "Uppercase characters are not permitted in $field";
2568 $self->ut_alpha($field);
2571 =item ut_phonen COLUMN [ COUNTRY ]
2573 Check/untaint phone numbers. May be null. If there is an error, returns
2574 the error, otherwise returns false.
2576 Takes an optional two-letter ISO 3166-1 alpha-2 country code; without
2577 it or with unsupported countries, ut_phonen simply calls ut_alphan.
2582 my( $self, $field, $country ) = @_;
2583 return $self->ut_alphan($field) unless defined $country;
2584 my $phonen = $self->getfield($field);
2585 if ( $phonen eq '' ) {
2586 $self->setfield($field,'');
2587 } elsif ( $country eq 'US' || $country eq 'CA' ) {
2589 $phonen = $conf->config('cust_main-default_areacode').$phonen
2590 if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2591 $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2592 or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2593 $phonen = "$1-$2-$3";
2594 $phonen .= " x$4" if $4;
2595 $self->setfield($field,$phonen);
2597 warn "warning: don't know how to check phone numbers for country $country";
2598 return $self->ut_textn($field);
2605 Check/untaint hexadecimal values.
2610 my($self, $field) = @_;
2611 $self->getfield($field) =~ /^([\da-fA-F]+)$/
2612 or return "Illegal (hex) $field: ". $self->getfield($field);
2613 $self->setfield($field, uc($1));
2617 =item ut_hexn COLUMN
2619 Check/untaint hexadecimal values. May be null.
2624 my($self, $field) = @_;
2625 $self->getfield($field) =~ /^([\da-fA-F]*)$/
2626 or return "Illegal (hex) $field: ". $self->getfield($field);
2627 $self->setfield($field, uc($1));
2631 =item ut_mac_addr COLUMN
2633 Check/untaint mac addresses. May be null.
2638 my($self, $field) = @_;
2640 my $mac = $self->get($field);
2643 $self->set($field, $mac);
2645 my $e = $self->ut_hex($field);
2648 return "Illegal (mac address) $field: ". $self->getfield($field)
2649 unless length($self->getfield($field)) == 12;
2655 =item ut_mac_addrn COLUMN
2657 Check/untaint mac addresses. May be null.
2662 my($self, $field) = @_;
2663 ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2668 Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
2674 my( $self, $field ) = @_;
2675 $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2676 $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2677 or return "Illegal (IP address) $field: ". $self->getfield($field);
2678 for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2679 $self->setfield( $field, $self->_ut_ip_strip_leading_zeros( "$1.$2.$3.$4" ));
2685 Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
2686 to 127.0.0.1. May be null.
2691 my( $self, $field ) = @_;
2692 if ( $self->getfield($field) =~ /^()$/ ) {
2693 $self->setfield($field,'');
2696 $self->ut_ip($field);
2700 =item ut_ip46 COLUMN
2702 Check/untaint IPv4 or IPv6 address.
2707 my( $self, $field ) = @_;
2708 my $ip = NetAddr::IP->new(
2709 $self->_ut_ip_strip_leading_zeros( $self->getfield($field) )
2710 ) or return "Illegal (IP address) $field: ".$self->getfield($field);
2711 $self->setfield($field, lc($ip->addr));
2717 Check/untaint IPv6 or IPv6 address. May be null.
2722 my( $self, $field ) = @_;
2723 if ( $self->getfield($field) =~ /^$/ ) {
2724 $self->setfield($field, '');
2727 $self->ut_ip46($field);
2730 sub _ut_ip_strip_leading_zeros {
2731 # strip user-entered leading 0's from IP addresses
2732 # so parsers like NetAddr::IP don't mangle the address
2733 # e.g. NetAddr::IP converts 10.0.022.220 into 10.0.18.220
2735 my ( $self, $ip ) = @_;
2737 return join '.', map int, split /\./, $ip
2744 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2746 Check/untaint coordinates.
2747 Accepts the following forms:
2757 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2758 The latter form (that is, the MMM are thousands of minutes) is
2759 assumed if the "MMM" is exactly three digits or two digits > 59.
2761 To be safe, just use the DDD.DDDDD form.
2763 If LOWER or UPPER are specified, then the coordinate is checked
2764 for lower and upper bounds, respectively.
2769 my ($self, $field) = (shift, shift);
2772 if ( $field =~ /latitude/ ) {
2773 $lower = $lat_lower;
2775 } elsif ( $field =~ /longitude/ ) {
2777 $upper = $lon_upper;
2780 my $coord = $self->getfield($field);
2781 my $neg = $coord =~ s/^(-)//;
2783 # ignore degree symbol at the end,
2784 # but not otherwise supporting degree/minutes/seconds symbols
2785 $coord =~ s/\N{DEGREE SIGN}\s*$//;
2787 my ($d, $m, $s) = (0, 0, 0);
2790 (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2791 (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2792 (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2794 $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2797 return "Invalid (coordinate with minutes > 59) $field: "
2798 . $self->getfield($field);
2801 $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2803 if (defined($lower) and ($coord < $lower)) {
2804 return "Invalid (coordinate < $lower) $field: "
2805 . $self->getfield($field);;
2808 if (defined($upper) and ($coord > $upper)) {
2809 return "Invalid (coordinate > $upper) $field: "
2810 . $self->getfield($field);;
2813 $self->setfield($field, $coord);
2817 return "Invalid (coordinate) $field: " . $self->getfield($field);
2821 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2823 Same as ut_coord, except optionally null.
2829 my ($self, $field) = (shift, shift);
2831 if ($self->getfield($field) =~ /^\s*$/) {
2834 return $self->ut_coord($field, @_);
2839 =item ut_domain COLUMN
2841 Check/untaint host and domain names. May not be null.
2846 my( $self, $field ) = @_;
2847 #$self->getfield($field) =~/^(\w+\.)*\w+$/
2848 $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2849 or return "Illegal (hostname) $field: ". $self->getfield($field);
2850 $self->setfield($field,$1);
2854 =item ut_domainn COLUMN
2856 Check/untaint host and domain names. May be null.
2861 my( $self, $field ) = @_;
2862 if ( $self->getfield($field) =~ /^()$/ ) {
2863 $self->setfield($field,'');
2866 $self->ut_domain($field);
2870 =item ut_name COLUMN
2872 Check/untaint proper names; allows alphanumerics, spaces and the following
2873 punctuation: , . - '
2880 my( $self, $field ) = @_;
2881 # warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
2882 $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
2883 or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2888 $self->setfield($field, $name);
2892 =item ut_namen COLUMN
2894 Check/untaint proper names; allows alphanumerics, spaces and the following
2895 punctuation: , . - '
2902 my( $self, $field ) = @_;
2903 return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2904 $self->ut_name($field);
2909 Check/untaint zip codes.
2913 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2916 my( $self, $field, $country ) = @_;
2918 if ( $country eq 'US' ) {
2920 $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2921 or return gettext('illegal_zip'). " $field for country $country: ".
2922 $self->getfield($field);
2923 $self->setfield($field, $1);
2925 } elsif ( $country eq 'CA' ) {
2927 $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2928 or return gettext('illegal_zip'). " $field for country $country: ".
2929 $self->getfield($field);
2930 $self->setfield($field, "$1 $2");
2932 } elsif ( $country eq 'AU' ) {
2934 $self->getfield($field) =~ /^\s*(\d{4})\s*$/
2935 or return gettext('illegal_zip'). " $field for country $country: ".
2936 $self->getfield($field);
2937 $self->setfield($field, $1);
2941 if ( $self->getfield($field) =~ /^\s*$/
2942 && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2945 $self->setfield($field,'');
2947 $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
2948 or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2949 $self->setfield($field,$1);
2957 =item ut_country COLUMN
2959 Check/untaint country codes. Country names are changed to codes, if possible -
2960 see L<Locale::Country>.
2965 my( $self, $field ) = @_;
2966 unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2967 if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2968 && country2code($1) ) {
2969 $self->setfield($field,uc(country2code($1)));
2972 $self->getfield($field) =~ /^(\w\w)$/
2973 or return "Illegal (country) $field: ". $self->getfield($field);
2974 $self->setfield($field,uc($1));
2978 =item ut_anything COLUMN
2980 Untaints arbitrary data. Be careful.
2985 my( $self, $field ) = @_;
2986 $self->getfield($field) =~ /^(.*)$/s
2987 or return "Illegal $field: ". $self->getfield($field);
2988 $self->setfield($field,$1);
2992 =item ut_enum COLUMN CHOICES_ARRAYREF
2994 Check/untaint a column, supplying all possible choices, like the "enum" type.
2999 my( $self, $field, $choices ) = @_;
3000 foreach my $choice ( @$choices ) {
3001 if ( $self->getfield($field) eq $choice ) {
3002 $self->setfield($field, $choice);
3006 return "Illegal (enum) field $field: ". $self->getfield($field);
3009 =item ut_enumn COLUMN CHOICES_ARRAYREF
3011 Like ut_enum, except the null value is also allowed.
3016 my( $self, $field, $choices ) = @_;
3017 $self->getfield($field)
3018 ? $self->ut_enum($field, $choices)
3022 =item ut_date COLUMN
3024 Check/untaint a column containing a date string.
3026 Date will be normalized to YYYY-MM-DD format
3031 my ( $self, $field ) = @_;
3032 my $value = $self->getfield( $field );
3034 my @date = split /[\-\/]/, $value;
3035 if ( scalar(@date) == 3 ) {
3036 @date = @date[2,0,1] if $date[2] >= 1900;
3041 # DateTime will die given invalid date
3042 $ymd = DateTime->new(
3050 $self->setfield( $field, $ymd ) unless $value eq $ymd;
3055 return "Illegal (date) field $field: $value";
3058 =item ut_daten COLUMN
3060 Check/untaint a column containing a date string.
3064 Date will be normalized to YYYY-MM-DD format
3069 my ( $self, $field ) = @_;
3071 $self->getfield( $field ) =~ /^()$/
3072 ? $self->setfield( $field, '' )
3073 : $self->ut_date( $field );
3076 =item ut_flag COLUMN
3078 Check/untaint a column if it contains either an empty string or 'Y'. This
3079 is the standard form for boolean flags in Freeside.
3084 my( $self, $field ) = @_;
3085 my $value = uc($self->getfield($field));
3086 if ( $value eq '' or $value eq 'Y' ) {
3087 $self->setfield($field, $value);
3090 return "Illegal (flag) field $field: $value";
3093 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3095 Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
3096 on the column first.
3100 sub ut_foreign_key {
3101 my( $self, $field, $table, $foreign ) = @_;
3102 return '' if $no_check_foreign;
3103 qsearchs($table, { $foreign => $self->getfield($field) })
3104 or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
3105 " in $table.$foreign";
3109 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3111 Like ut_foreign_key, except the null value is also allowed.
3115 sub ut_foreign_keyn {
3116 my( $self, $field, $table, $foreign ) = @_;
3117 $self->getfield($field)
3118 ? $self->ut_foreign_key($field, $table, $foreign)
3122 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
3124 Checks this column as an agentnum, taking into account the current users's
3125 ACLs. NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
3126 right or rights allowing no agentnum.
3130 sub ut_agentnum_acl {
3131 my( $self, $field ) = (shift, shift);
3132 my $null_acl = scalar(@_) ? shift : [];
3133 $null_acl = [ $null_acl ] unless ref($null_acl);
3135 my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
3136 return "Illegal agentnum: $error" if $error;
3138 my $curuser = $FS::CurrentUser::CurrentUser;
3140 if ( $self->$field() ) {
3142 return "Access denied"
3143 unless $curuser->agentnum($self->$field());
3147 return "Access denied"
3148 unless grep $curuser->access_right($_), @$null_acl;
3156 =item trim_whitespace FIELD[, FIELD ... ]
3158 Strip leading and trailing spaces from the value in the named FIELD(s).
3162 sub trim_whitespace {
3164 foreach my $field (@_) {
3165 my $value = $self->get($field);
3168 $self->set($field, $value);
3172 =item fields [ TABLE ]
3174 This is a wrapper for real_fields. Code that called
3175 fields before should probably continue to call fields.
3180 my $something = shift;
3182 if($something->isa('FS::Record')) {
3183 $table = $something->table;
3185 $table = $something;
3186 $something = "FS::$table";
3188 return (real_fields($table));
3192 =item encrypt($value)
3194 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
3196 Returns the encrypted string.
3198 You should generally not have to worry about calling this, as the system handles this for you.
3203 my ($self, $value) = @_;
3204 my $encrypted = $value;
3206 if ($conf_encryption) {
3207 if ($self->is_encrypted($value)) {
3208 # Return the original value if it isn't plaintext.
3209 $encrypted = $value;
3212 if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
3213 # RSA doesn't like the empty string so let's pack it up
3214 # The database doesn't like the RSA data so uuencode it
3215 my $length = length($value)+1;
3216 $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
3218 die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
3225 =item is_encrypted($value)
3227 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
3233 my ($self, $value) = @_;
3234 # Possible Bug - Some work may be required here....
3236 if ($value =~ /^M/ && length($value) > 80) {
3243 =item decrypt($value)
3245 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
3247 You should generally not have to worry about calling this, as the system handles this for you.
3252 my ($self,$value) = @_;
3253 my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
3254 if ($conf_encryption && $self->is_encrypted($value)) {
3256 if (ref($rsa_decrypt) =~ /::RSA/) {
3257 my $encrypted = unpack ("u*", $value);
3258 $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
3259 if ($@) {warn "Decryption Failed"};
3267 #Initialize the Module
3268 $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
3270 if ($conf_encryptionmodule && $conf_encryptionmodule ne '') {
3271 $rsa_module = $conf_encryptionmodule;
3275 eval ("require $rsa_module"); # No need to import the namespace
3278 # Initialize Encryption
3279 if ($conf_encryptionpublickey && $conf_encryptionpublickey ne '') {
3280 $rsa_encrypt = $rsa_module->new_public_key($conf_encryptionpublickey);
3283 # Intitalize Decryption
3284 if ($conf_encryptionprivatekey && $conf_encryptionprivatekey ne '') {
3285 $rsa_decrypt = $rsa_module->new_private_key($conf_encryptionprivatekey);
3289 =item h_search ACTION
3291 Given an ACTION, either "insert", or "delete", returns the appropriate history
3292 record corresponding to this record, if any.
3297 my( $self, $action ) = @_;
3299 my $table = $self->table;
3302 my $primary_key = dbdef->table($table)->primary_key;
3305 'table' => "h_$table",
3306 'hashref' => { $primary_key => $self->$primary_key(),
3307 'history_action' => $action,
3315 Given an ACTION, either "insert", or "delete", returns the timestamp of the
3316 appropriate history record corresponding to this record, if any.
3321 my($self, $action) = @_;
3322 my $h = $self->h_search($action);
3323 $h ? $h->history_date : '';
3326 =item scalar_sql SQL [ PLACEHOLDER, ... ]
3328 A class or object method. Executes the sql statement represented by SQL and
3329 returns a scalar representing the result: the first column of the first row.
3331 Dies on bogus SQL. Returns an empty string if no row is returned.
3333 Typically used for statments which return a single value such as "SELECT
3334 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
3339 my($self, $sql) = (shift, shift);
3340 my $sth = dbh->prepare($sql) or die dbh->errstr;
3342 or die "Unexpected error executing statement $sql: ". $sth->errstr;
3343 my $row = $sth->fetchrow_arrayref or return '';
3344 my $scalar = $row->[0];
3345 defined($scalar) ? $scalar : '';
3348 =item count [ WHERE [, PLACEHOLDER ...] ]
3350 Convenience method for the common case of "SELECT COUNT(*) FROM table",
3351 with optional WHERE. Must be called as method on a class with an
3357 my($self, $where) = (shift, shift);
3358 my $table = $self->table or die 'count called on object of class '.ref($self);
3359 my $sql = "SELECT COUNT(*) FROM $table";
3360 $sql .= " WHERE $where" if $where;
3361 $self->scalar_sql($sql, @_);
3364 =item row_exists [ WHERE [, PLACEHOLDER ...] ]
3366 Convenience method for the common case of "SELECT 1 FROM table ... LIMIT 1"
3367 with optional (but almost always needed) WHERE.
3372 my($self, $where) = (shift, shift);
3373 my $table = $self->table or die 'row_exists called on object of class '.ref($self);
3374 my $sql = "SELECT 1 FROM $table";
3375 $sql .= " WHERE $where" if $where;
3377 $self->scalar_sql($sql, @_);
3386 =item real_fields [ TABLE ]
3388 Returns a list of the real columns in the specified table. Called only by
3389 fields() and other subroutines elsewhere in FS::Record.
3396 my($table_obj) = dbdef->table($table);
3397 confess "Unknown table $table" unless $table_obj;
3398 $table_obj->columns;
3401 =item pvf FIELD_NAME
3403 Returns the FS::part_virtual_field object corresponding to a field in the
3404 record (specified by FIELD_NAME).
3409 my ($self, $name) = (shift, shift);
3411 if(grep /^$name$/, $self->virtual_fields) {
3413 my $concat = [ "'cf_'", "name" ];
3414 return qsearchs({ table => 'part_virtual_field',
3415 hashref => { dbtable => $self->table,
3418 select => 'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
3424 =item _quote VALUE, TABLE, COLUMN
3426 This is an internal function used to construct SQL statements. It returns
3427 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3428 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3433 my($value, $table, $column) = @_;
3434 my $column_obj = dbdef->table($table)->column($column);
3435 my $column_type = $column_obj->type;
3436 my $nullable = $column_obj->null;
3438 utf8::upgrade($value);
3440 warn " $table.$column: $value ($column_type".
3441 ( $nullable ? ' NULL' : ' NOT NULL' ).
3442 ")\n" if $DEBUG > 2;
3444 if ( $value eq '' && $nullable ) {
3446 } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3447 cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3450 } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3451 ! $column_type =~ /(char|binary|text)$/i ) {
3453 } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3454 && driver_name eq 'Pg'
3459 eval { $value = dbh->quote($value, { pg_type => PG_BYTEA() }); };
3461 if ( $@ && $@ =~ /Wide character/i ) {
3462 warn 'Correcting malformed UTF-8 string for binary quote()'
3464 utf8::decode($value);
3465 utf8::encode($value);
3466 $value = dbh->quote($value, { pg_type => PG_BYTEA() });
3477 This is deprecated. Don't use it.
3479 It returns a hash-type list with the fields of this record's table set true.
3484 carp "warning: hfields is deprecated";
3487 foreach (fields($table)) {
3496 "$_: ". $self->getfield($_). "|"
3497 } (fields($self->table)) );
3500 sub DESTROY { return; }
3504 # #use Carp qw(cluck);
3505 # #cluck "DESTROYING $self";
3506 # warn "DESTROYING $self";
3510 # return ! eval { join('',@_), kill 0; 1; };
3513 =item str2time_sql [ DRIVER_NAME ]
3515 Returns a function to convert to unix time based on database type, such as
3516 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql. See
3517 the str2time_sql_closing method to return a closing string rather than just
3518 using a closing parenthesis as previously suggested.
3520 You can pass an optional driver name such as "Pg", "mysql" or
3521 $dbh->{Driver}->{Name} to return a function for that database instead of
3522 the current database.
3527 my $driver = shift || driver_name;
3529 return 'UNIX_TIMESTAMP(' if $driver =~ /^mysql/i;
3530 return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3532 warn "warning: unknown database type $driver; guessing how to convert ".
3533 "dates to UNIX timestamps";
3534 return 'EXTRACT(EPOCH FROM ';
3538 =item str2time_sql_closing [ DRIVER_NAME ]
3540 Returns the closing suffix of a function to convert to unix time based on
3541 database type, such as ")::integer" for Pg or ")" for mysql.
3543 You can pass an optional driver name such as "Pg", "mysql" or
3544 $dbh->{Driver}->{Name} to return a function for that database instead of
3545 the current database.
3549 sub str2time_sql_closing {
3550 my $driver = shift || driver_name;
3552 return ' )::INTEGER ' if $driver =~ /^Pg/i;
3556 =item regexp_sql [ DRIVER_NAME ]
3558 Returns the operator to do a regular expression comparison based on database
3559 type, such as '~' for Pg or 'REGEXP' for mysql.
3561 You can pass an optional driver name such as "Pg", "mysql" or
3562 $dbh->{Driver}->{Name} to return a function for that database instead of
3563 the current database.
3568 my $driver = shift || driver_name;
3570 return '~' if $driver =~ /^Pg/i;
3571 return 'REGEXP' if $driver =~ /^mysql/i;
3573 die "don't know how to use regular expressions in ". driver_name." databases";
3577 =item not_regexp_sql [ DRIVER_NAME ]
3579 Returns the operator to do a regular expression negation based on database
3580 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3582 You can pass an optional driver name such as "Pg", "mysql" or
3583 $dbh->{Driver}->{Name} to return a function for that database instead of
3584 the current database.
3588 sub not_regexp_sql {
3589 my $driver = shift || driver_name;
3591 return '!~' if $driver =~ /^Pg/i;
3592 return 'NOT REGEXP' if $driver =~ /^mysql/i;
3594 die "don't know how to use regular expressions in ". driver_name." databases";
3598 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3600 Returns the items concatenated based on database type, using "CONCAT()" for
3601 mysql and " || " for Pg and other databases.
3603 You can pass an optional driver name such as "Pg", "mysql" or
3604 $dbh->{Driver}->{Name} to return a function for that database instead of
3605 the current database.
3610 my $driver = ref($_[0]) ? driver_name : shift;
3613 if ( $driver =~ /^mysql/i ) {
3614 'CONCAT('. join(',', @$items). ')';
3616 join('||', @$items);
3621 =item group_concat_sql COLUMN, DELIMITER
3623 Returns an SQL expression to concatenate an aggregate column, using
3624 GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg.
3628 sub group_concat_sql {
3629 my ($col, $delim) = @_;
3630 $delim = dbh->quote($delim);
3631 if ( driver_name() =~ /^mysql/i ) {
3632 # DISTINCT(foo) is valid as $col
3633 return "GROUP_CONCAT($col SEPARATOR $delim)";
3635 return "array_to_string(array_agg($col), $delim)";
3639 =item midnight_sql DATE
3641 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3642 on that day in the system timezone, using the default driver name.
3647 my $driver = driver_name;
3649 if ( $driver =~ /^mysql/i ) {
3650 "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3653 "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3661 This module should probably be renamed, since much of the functionality is
3662 of general use. It is not completely unlike Adapter::DBI (see below).
3664 Exported qsearch and qsearchs should be deprecated in favor of method calls
3665 (against an FS::Record object like the old search and searchs that qsearch
3666 and qsearchs were on top of.)
3668 The whole fields / hfields mess should be removed.
3670 The various WHERE clauses should be subroutined.
3672 table string should be deprecated in favor of DBIx::DBSchema::Table.
3674 No doubt we could benefit from a Tied hash. Documenting how exists / defined
3675 true maps to the database (and WHERE clauses) would also help.
3677 The ut_ methods should ask the dbdef for a default length.
3679 ut_sqltype (like ut_varchar) should all be defined
3681 A fallback check method should be provided which uses the dbdef.
3683 The ut_money method assumes money has two decimal digits.
3685 The Pg money kludge in the new method only strips `$'.
3687 The ut_phonen method only checks US-style phone numbers.
3689 The _quote function should probably use ut_float instead of a regex.
3691 All the subroutines probably should be methods, here or elsewhere.
3693 Probably should borrow/use some dbdef methods where appropriate (like sub
3696 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3697 or allow it to be set. Working around it is ugly any way around - DBI should
3698 be fixed. (only affects RDBMS which return uppercase column names)
3700 ut_zip should take an optional country like ut_phone.
3704 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3706 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.