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
33 use FS::part_virtual_field;
39 @encrypt_payby = qw( CARD DCRD CHEK DCHK );
41 #export dbdef for now... everything else expects to find it here
43 dbh fields hfields qsearch qsearchs dbdef jsearch
44 str2time_sql str2time_sql_closing regexp_sql not_regexp_sql
45 concat_sql group_concat_sql
52 $nowarn_identical = 0;
53 $nowarn_classload = 0;
57 $qsearch_qualify_columns = 0;
59 $no_check_foreign = 0;
67 our $conf_encryption = '';
68 our $conf_encryptionmodule = '';
69 our $conf_encryptionpublickey = '';
70 our $conf_encryptionprivatekey = '';
71 FS::UID->install_callback( sub {
75 $conf = FS::Conf->new;
76 $conf_encryption = $conf->exists('encryption');
77 $conf_encryptionmodule = $conf->config('encryptionmodule');
78 $conf_encryptionpublickey = join("\n",$conf->config('encryptionpublickey'));
79 $conf_encryptionprivatekey = join("\n",$conf->config('encryptionprivatekey'));
80 $money_char = $conf->config('money_char') || '$';
81 my $nw_coords = $conf->exists('geocode-require_nw_coordinates');
82 $lat_lower = $nw_coords ? 1 : -90;
83 $lon_upper = $nw_coords ? -1 : 180;
85 $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
87 if ( driver_name eq 'Pg' ) {
88 eval "use DBD::Pg ':pg_types'";
91 eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }";
98 FS::Record - Database record objects
103 use FS::Record qw(dbh fields qsearch qsearchs);
105 $record = new FS::Record 'table', \%hash;
106 $record = new FS::Record 'table', { 'column' => 'value', ... };
108 $record = qsearchs FS::Record 'table', \%hash;
109 $record = qsearchs FS::Record 'table', { 'column' => 'value', ... };
110 @records = qsearch FS::Record 'table', \%hash;
111 @records = qsearch FS::Record 'table', { 'column' => 'value', ... };
113 $table = $record->table;
114 $dbdef_table = $record->dbdef_table;
116 $value = $record->get('column');
117 $value = $record->getfield('column');
118 $value = $record->column;
120 $record->set( 'column' => 'value' );
121 $record->setfield( 'column' => 'value' );
122 $record->column('value');
124 %hash = $record->hash;
126 $hashref = $record->hashref;
128 $error = $record->insert;
130 $error = $record->delete;
132 $error = $new_record->replace($old_record);
134 # external use deprecated - handled by the database (at least for Pg, mysql)
135 $value = $record->unique('column');
137 $error = $record->ut_float('column');
138 $error = $record->ut_floatn('column');
139 $error = $record->ut_number('column');
140 $error = $record->ut_numbern('column');
141 $error = $record->ut_decimal('column');
142 $error = $record->ut_decimaln('column');
143 $error = $record->ut_snumber('column');
144 $error = $record->ut_snumbern('column');
145 $error = $record->ut_money('column');
146 $error = $record->ut_text('column');
147 $error = $record->ut_textn('column');
148 $error = $record->ut_alpha('column');
149 $error = $record->ut_alphan('column');
150 $error = $record->ut_phonen('column');
151 $error = $record->ut_anything('column');
152 $error = $record->ut_name('column');
154 $quoted_value = _quote($value,'table','field');
157 $fields = hfields('table');
158 if ( $fields->{Field} ) { # etc.
160 @fields = fields 'table'; #as a subroutine
161 @fields = $record->fields; #as a method call
166 (Mostly) object-oriented interface to database records. Records are currently
167 implemented on top of DBI. FS::Record is intended as a base class for
168 table-specific classes to inherit from, i.e. FS::cust_main.
174 =item new [ TABLE, ] HASHREF
176 Creates a new record. It doesn't store it in the database, though. See
177 L<"insert"> for that.
179 Note that the object stores this hash reference, not a distinct copy of the
180 hash it points to. You can ask the object for a copy with the I<hash>
183 TABLE can only be omitted when a dervived class overrides the table method.
189 my $class = ref($proto) || $proto;
191 bless ($self, $class);
193 unless ( defined ( $self->table ) ) {
194 $self->{'Table'} = shift;
195 carp "warning: FS::Record::new called with table name ". $self->{'Table'}
196 unless $nowarn_classload;
199 $self->{'Hash'} = shift;
201 foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
202 $self->{'Hash'}{$field}='';
205 $self->_rebless if $self->can('_rebless');
207 $self->{'modified'} = 0;
209 $self->_simplecache($self->{'Hash'}) if $self->can('_simplecache');
210 $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
217 my $class = ref($proto) || $proto;
219 bless ($self, $class);
221 $self->{'Table'} = shift unless defined ( $self->table );
223 my $hashref = $self->{'Hash'} = shift;
225 if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
226 my $obj = $cache->cache->{$hashref->{$cache->key}};
227 $obj->_cache($hashref, $cache) if $obj->can('_cache');
230 $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
237 my $class = ref($proto) || $proto;
239 bless ($self, $class);
240 if ( defined $self->table ) {
241 cluck "create constructor is deprecated, use new!";
244 croak "FS::Record::create called (not from a subclass)!";
248 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
250 Searches the database for all records matching (at least) the key/value pairs
251 in HASHREF. Returns all the records found as `FS::TABLE' objects if that
252 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
255 The preferred usage is to pass a hash reference of named parameters:
257 @records = qsearch( {
258 'table' => 'table_name',
259 'hashref' => { 'field' => 'value'
260 'field' => { 'op' => '<',
265 #these are optional...
267 'extra_sql' => 'AND field = ? AND intfield = ?',
268 'extra_param' => [ 'value', [ 5, 'int' ] ],
269 'order_by' => 'ORDER BY something',
270 #'cache_obj' => '', #optional
271 'addl_from' => 'LEFT JOIN othtable USING ( field )',
276 Much code still uses old-style positional parameters, this is also probably
277 fine in the common case where there are only two parameters:
279 my @records = qsearch( 'table', { 'field' => 'value' } );
281 Also possible is an experimental LISTREF of PARAMS_HASHREFs for a UNION of
282 the individual PARAMS_HASHREF queries
284 ###oops, argh, FS::Record::new only lets us create database fields.
285 #Normal behaviour if SELECT is not specified is `*', as in
286 #C<SELECT * FROM table WHERE ...>. However, there is an experimental new
287 #feature where you can specify SELECT - remember, the objects returned,
288 #although blessed into the appropriate `FS::TABLE' package, will only have the
289 #fields you specify. This might have unwanted results if you then go calling
290 #regular FS::TABLE methods
293 C<$FS::Record::qsearch_qualify_columns> package global is disabled by default.
294 When enabled, the WHERE clause generated from the 'hashref' parameter has
295 the table name prepended to each column name. WHERE column = 'value' becomes
296 WHERE table.coumn = 'value'
300 my %TYPE = (); #for debugging
303 my($type, $value) = @_;
305 my $bind_type = { TYPE => SQL_VARCHAR };
307 if ( $type =~ /(big)?(int|serial)/i && $value =~ /^-?\d+(\.\d+)?$/ ) {
309 $bind_type = { TYPE => SQL_INTEGER };
311 } elsif ( $type =~ /^bytea$/i || $type =~ /(blob|varbinary)/i ) {
313 if ( driver_name eq 'Pg' ) {
315 $bind_type = { pg_type => PG_BYTEA };
317 # $bind_type = ? #SQL_VARCHAR could be fine?
320 #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT
321 #fixed by DBD::Pg 2.11.8
322 #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded
323 #(make a Tron test first)
324 } elsif ( _is_fs_float( $type, $value ) ) {
326 $bind_type = { TYPE => SQL_DECIMAL };
335 my($type, $value) = @_;
336 if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) ||
337 ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/)
345 my( @stable, @record, @cache );
346 my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
348 my %union_options = ();
349 if ( ref($_[0]) eq 'ARRAY' ) {
352 foreach my $href ( @$optlist ) {
353 push @stable, ( $href->{'table'} or die "table name is required" );
354 push @record, ( $href->{'hashref'} || {} );
355 push @select, ( $href->{'select'} || '*' );
356 push @extra_sql, ( $href->{'extra_sql'} || '' );
357 push @extra_param, ( $href->{'extra_param'} || [] );
358 push @order_by, ( $href->{'order_by'} || '' );
359 push @cache, ( $href->{'cache_obj'} || '' );
360 push @addl_from, ( $href->{'addl_from'} || '' );
361 push @debug, ( $href->{'debug'} || '' );
363 die "at least one hashref is required" unless scalar(@stable);
364 } elsif ( ref($_[0]) eq 'HASH' ) {
366 $stable[0] = $opt->{'table'} or die "table name is required";
367 $record[0] = $opt->{'hashref'} || {};
368 $select[0] = $opt->{'select'} || '*';
369 $extra_sql[0] = $opt->{'extra_sql'} || '';
370 $extra_param[0] = $opt->{'extra_param'} || [];
371 $order_by[0] = $opt->{'order_by'} || '';
372 $cache[0] = $opt->{'cache_obj'} || '';
373 $addl_from[0] = $opt->{'addl_from'} || '';
374 $debug[0] = $opt->{'debug'} || '';
385 my $cache = $cache[0];
391 foreach my $stable ( @stable ) {
392 #stop altering the caller's hashref
393 my $record = { %{ shift(@record) || {} } };#and be liberal in receipt
394 my $select = shift @select;
395 my $extra_sql = shift @extra_sql;
396 my $extra_param = shift @extra_param;
397 my $order_by = shift @order_by;
398 my $cache = shift @cache;
399 my $addl_from = shift @addl_from;
400 my $debug = shift @debug;
402 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
404 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
407 my $table = $cache ? $cache->table : $stable;
408 my $dbdef_table = dbdef->table($table)
409 or die "No schema for table $table found - ".
410 "do you need to run freeside-upgrade?";
411 my $pkey = $dbdef_table->primary_key;
413 my @real_fields = grep exists($record->{$_}), real_fields($table);
415 my $statement .= "SELECT $select FROM $stable";
416 $statement .= " $addl_from" if $addl_from;
417 if ( @real_fields ) {
418 $statement .= ' WHERE '. join(' AND ',
419 get_real_fields($table, $record, \@real_fields));
422 $statement .= " $extra_sql" if defined($extra_sql);
423 $statement .= " $order_by" if defined($order_by);
425 push @statement, $statement;
427 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
431 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
434 my $value = $record->{$field};
435 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
436 $value = $value->{'value'} if ref($value);
437 my $type = dbdef->table($table)->column($field)->type;
439 my $bind_type = _bind_type($type, $value);
443 # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
445 # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
449 push @bind_type, $bind_type;
453 foreach my $param ( @$extra_param ) {
454 my $bind_type = { TYPE => SQL_VARCHAR };
457 $value = $param->[0];
458 my $type = $param->[1];
459 $bind_type = _bind_type($type, $value);
462 push @bind_type, $bind_type;
466 my $statement = join( ' ) UNION ( ', @statement );
467 $statement = "( $statement )" if scalar(@statement) > 1;
468 $statement .= " $union_options{order_by}" if $union_options{order_by};
470 my $sth = $dbh->prepare($statement)
471 or croak "$dbh->errstr doing $statement";
474 foreach my $value ( @value ) {
475 my $bind_type = shift @bind_type;
476 $sth->bind_param($bind++, $value, $bind_type );
479 # $sth->execute( map $record->{$_},
480 # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
481 # ) or croak "Error executing \"$statement\": ". $sth->errstr;
483 my $ok = $sth->execute;
485 my $error = "Error executing \"$statement\"";
486 $error .= ' (' . join(', ', map {"'$_'"} @value) . ')' if @value;
487 $error .= ': '. $sth->errstr;
492 # Determine how to format rows returned form a union query:
494 # * When all queries involved in the union are from the same table:
495 # Return an array of FS::$table_name objects
497 # * When union query is performed on multiple tables,
498 # Return an array of FS::Record objects
499 # ! Note: As far as I can tell, this functionality was broken, and
500 # ! actually results in a crash. Behavior is left intact
501 # ! as-is, in case the results are in use somewhere
503 # * Union query is performed on multiple table,
504 # and $union_options{classname_from_column} = 1
505 # Return an array of FS::$classname objects, where $classname is
506 # derived for each row from a static field inserted each returned
508 # e.g.: SELECT custnum,first,last,'cust_main' AS `__classname`'.
511 my $table = $stable[0];
513 $table = '' if grep { $_ ne $table } @stable;
514 $pkey = dbdef->table($table)->primary_key if $table;
517 tie %result, "Tie::IxHash";
518 my @stuff = @{ $sth->fetchall_arrayref( {} ) };
519 if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
520 %result = map { $_->{$pkey}, $_ } @stuff;
522 @result{@stuff} = @stuff;
528 if ($union_options{classname_from_column}) {
531 # I'm not implementing the cache for this use case, at least not yet
534 for my $row (@stuff) {
535 my $table_class = $row->{__classname}
536 or die "`__classname` column must be set when ".
537 "using \$union_options{classname_from_column}";
538 push @return, new("FS::$table_class",$row);
542 elsif ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
543 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
544 #derivied class didn't override new method, so this optimization is safe
547 new_or_cached( "FS::$table", { %{$_} }, $cache )
551 new( "FS::$table", { %{$_} } )
555 #okay, its been tested
556 # warn "untested code (class FS::$table uses custom new method)";
558 eval 'FS::'. $table. '->new( { %{$_} } )';
562 # Check for encrypted fields and decrypt them.
563 ## only in the local copy, not the cached object
564 no warnings 'deprecated'; # XXX silence the warning for now
565 if ( $conf_encryption
566 && eval '@FS::'. $table . '::encrypted_fields' ) {
567 foreach my $record (@return) {
568 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
569 next if $field eq 'payinfo'
570 && ($record->isa('FS::payinfo_transaction_Mixin')
571 || $record->isa('FS::payinfo_Mixin') )
573 && !grep { $record->payby eq $_ } @encrypt_payby;
574 # Set it directly... This may cause a problem in the future...
575 $record->setfield($field, $record->decrypt($record->getfield($field)));
580 cluck "warning: FS::$table not loaded; returning FS::Record objects"
581 unless $nowarn_classload;
583 FS::Record->new( $table, { %{$_} } );
591 Construct the SQL statement and parameter-binding list for qsearch. Takes
592 the qsearch parameters.
594 Returns a hash containing:
595 'table': The primary table name (if there is one).
596 'statement': The SQL statement itself.
597 'bind_type': An arrayref of bind types.
598 'value': An arrayref of parameter values.
599 'cache': The cache object, if one was passed.
604 my( @stable, @record, @cache );
605 my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
608 my %union_options = ();
609 if ( ref($_[0]) eq 'ARRAY' ) {
612 foreach my $href ( @$optlist ) {
613 push @stable, ( $href->{'table'} or die "table name is required" );
614 push @record, ( $href->{'hashref'} || {} );
615 push @select, ( $href->{'select'} || '*' );
616 push @extra_sql, ( $href->{'extra_sql'} || '' );
617 push @extra_param, ( $href->{'extra_param'} || [] );
618 push @order_by, ( $href->{'order_by'} || '' );
619 push @cache, ( $href->{'cache_obj'} || '' );
620 push @addl_from, ( $href->{'addl_from'} || '' );
621 push @debug, ( $href->{'debug'} || '' );
623 die "at least one hashref is required" unless scalar(@stable);
624 } elsif ( ref($_[0]) eq 'HASH' ) {
626 $stable[0] = $opt->{'table'} or die "table name is required";
627 $record[0] = $opt->{'hashref'} || {};
628 $select[0] = $opt->{'select'} || '*';
629 $extra_sql[0] = $opt->{'extra_sql'} || '';
630 $extra_param[0] = $opt->{'extra_param'} || [];
631 $order_by[0] = $opt->{'order_by'} || '';
632 $cache[0] = $opt->{'cache_obj'} || '';
633 $addl_from[0] = $opt->{'addl_from'} || '';
634 $debug[0] = $opt->{'debug'} || '';
645 my $cache = $cache[0];
651 my $result_table = $stable[0];
652 foreach my $stable ( @stable ) {
653 #stop altering the caller's hashref
654 my $record = { %{ shift(@record) || {} } };#and be liberal in receipt
655 my $select = shift @select;
656 my $extra_sql = shift @extra_sql;
657 my $extra_param = shift @extra_param;
658 my $order_by = shift @order_by;
659 my $cache = shift @cache;
660 my $addl_from = shift @addl_from;
661 my $debug = shift @debug;
663 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
665 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
668 $result_table = '' if $result_table ne $stable;
670 my $table = $cache ? $cache->table : $stable;
671 my $dbdef_table = dbdef->table($table)
672 or die "No schema for table $table found - ".
673 "do you need to run freeside-upgrade?";
674 my $pkey = $dbdef_table->primary_key;
676 my @real_fields = grep exists($record->{$_}), real_fields($table);
678 my $statement .= "SELECT $select FROM $stable";
679 $statement .= " $addl_from" if $addl_from;
680 if ( @real_fields ) {
681 $statement .= ' WHERE '. join(' AND ',
682 get_real_fields($table, $record, \@real_fields));
685 $statement .= " $extra_sql" if defined($extra_sql);
686 $statement .= " $order_by" if defined($order_by);
688 push @statement, $statement;
690 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
694 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
697 my $value = $record->{$field};
698 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
699 $value = $value->{'value'} if ref($value);
700 my $type = dbdef->table($table)->column($field)->type;
702 my $bind_type = _bind_type($type, $value);
706 # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
708 # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
712 push @bind_type, $bind_type;
716 foreach my $param ( @$extra_param ) {
717 my $bind_type = { TYPE => SQL_VARCHAR };
720 $value = $param->[0];
721 my $type = $param->[1];
722 $bind_type = _bind_type($type, $value);
725 push @bind_type, $bind_type;
729 my $statement = join( ' ) UNION ( ', @statement );
730 $statement = "( $statement )" if scalar(@statement) > 1;
731 $statement .= " $union_options{order_by}" if $union_options{order_by};
734 statement => $statement,
735 bind_type => \@bind_type,
737 table => $result_table,
742 # qsearch should eventually use this
744 my ($table, $cache, @hashrefs) = @_;
746 # XXX get rid of these string evals at some point
747 # (when we have time to test it)
748 # my $class = "FS::$table" if $table;
749 # if ( $class and $class->isa('FS::Record') )
750 # if ( $class->can('new') eq \&new )
752 if ( $table && eval 'scalar(@FS::'. $table. '::ISA);' ) {
753 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
754 #derivied class didn't override new method, so this optimization is safe
757 new_or_cached( "FS::$table", { %{$_} }, $cache )
761 new( "FS::$table", { %{$_} } )
765 #okay, its been tested
766 # warn "untested code (class FS::$table uses custom new method)";
768 eval 'FS::'. $table. '->new( { %{$_} } )';
772 # Check for encrypted fields and decrypt them.
773 ## only in the local copy, not the cached object
774 if ( $conf_encryption
775 && eval '@FS::'. $table . '::encrypted_fields' ) {
776 foreach my $record (@return) {
777 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
778 next if $field eq 'payinfo'
779 && ($record->isa('FS::payinfo_transaction_Mixin')
780 || $record->isa('FS::payinfo_Mixin') )
782 && !grep { $record->payby eq $_ } @encrypt_payby;
783 # Set it directly... This may cause a problem in the future...
784 $record->setfield($field, $record->decrypt($record->getfield($field)));
789 cluck "warning: FS::$table not loaded; returning FS::Record objects"
790 unless $nowarn_classload;
792 FS::Record->new( $table, { %{$_} } );
798 sub get_real_fields {
801 my $real_fields = shift;
803 ## could be optimized more for readability
809 my $table_column = $qsearch_qualify_columns ? "$table.$column" : $column;
810 my $type = dbdef->table($table)->column($column)->type;
811 my $value = $record->{$column};
812 $value = $value->{'value'} if ref($value);
814 if ( ref($record->{$column}) ) {
815 $op = $record->{$column}{'op'} if $record->{$column}{'op'};
816 #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
817 if ( uc($op) eq 'ILIKE' ) {
819 $record->{$column}{'value'} = lc($record->{$column}{'value'});
820 $table_column = "LOWER($table_column)";
822 $record->{$column} = $record->{$column}{'value'}
825 if ( ! defined( $record->{$column} ) || $record->{$column} eq '' ) {
827 if ( driver_name eq 'Pg' ) {
828 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
829 qq-( $table_column IS NULL )-;
831 qq-( $table_column IS NULL OR $table_column = '' )-;
834 qq-( $table_column IS NULL OR $table_column = "" )-;
836 } elsif ( $op eq '!=' ) {
837 if ( driver_name eq 'Pg' ) {
838 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
839 qq-( $table_column IS NOT NULL )-;
841 qq-( $table_column IS NOT NULL AND $table_column != '' )-;
844 qq-( $table_column IS NOT NULL AND $table_column != "" )-;
847 if ( driver_name eq 'Pg' ) {
848 qq-( $table_column $op '' )-;
850 qq-( $table_column $op "" )-;
853 } elsif ( $op eq '!=' ) {
854 qq-( $table_column IS NULL OR $table_column != ? )-;
855 #if this needs to be re-enabled, it needs to use a custom op like
856 #"APPROX=" or something (better name?, not '=', to avoid affecting other
858 #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
859 # ( "$table_column <= ?", "$table_column >= ?" );
861 "$table_column $op ?";
868 =item by_key PRIMARY_KEY_VALUE
870 This is a class method that returns the record with the given primary key
871 value. This method is only useful in FS::Record subclasses. For example:
873 my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
877 my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
882 my ($class, $pkey_value) = @_;
884 my $table = $class->table
885 or croak "No table for $class found";
887 my $dbdef_table = dbdef->table($table)
888 or die "No schema for table $table found - ".
889 "do you need to create it or run dbdef-create?";
890 my $pkey = $dbdef_table->primary_key
891 or die "No primary key for table $table";
893 return qsearchs($table, { $pkey => $pkey_value });
896 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
898 Experimental JOINed search method. Using this method, you can execute a
899 single SELECT spanning multiple tables, and cache the results for subsequent
900 method calls. Interface will almost definately change in an incompatible
908 my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
909 my $cache = FS::SearchCache->new( $ptable, $pkey );
912 grep { !$saw{$_->getfield($pkey)}++ }
913 qsearch($table, $record, $select, $extra_sql, $cache )
917 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
919 Same as qsearch, except that if more than one record matches, it B<carp>s but
920 returns the first. If this happens, you either made a logic error in asking
921 for a single item, or your data is corrupted.
925 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
927 my(@result) = qsearch(@_);
928 cluck "warning: Multiple records in scalar search ($table)"
929 if scalar(@result) > 1;
930 #should warn more vehemently if the search was on a primary key?
931 scalar(@result) ? ($result[0]) : ();
942 Returns the table name.
947 # cluck "warning: FS::Record::table deprecated; supply one in subclass!";
954 Returns the DBIx::DBSchema::Table object for the table.
960 my($table)=$self->table;
961 dbdef->table($table);
966 Returns the primary key for the table.
972 my $pkey = $self->dbdef_table->primary_key;
975 =item get, getfield COLUMN
977 Returns the value of the column/field/key COLUMN.
982 my($self,$field) = @_;
983 # to avoid "Use of unitialized value" errors
984 if ( defined ( $self->{Hash}->{$field} ) ) {
985 $self->{Hash}->{$field};
995 =item set, setfield COLUMN, VALUE
997 Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE.
1002 my($self,$field,$value) = @_;
1003 $self->{'modified'} = 1;
1004 $self->{'Hash'}->{$field} = $value;
1013 Returns true if the column/field/key COLUMN exists.
1018 my($self,$field) = @_;
1019 exists($self->{Hash}->{$field});
1022 =item AUTLOADED METHODS
1024 $record->column is a synonym for $record->get('column');
1026 $record->column('value') is a synonym for $record->set('column','value');
1032 my($self,$value)=@_;
1033 my($field)=$AUTOLOAD;
1035 if ( defined($value) ) {
1036 confess "errant AUTOLOAD $field for $self (arg $value)"
1037 unless blessed($self) && $self->can('setfield');
1038 $self->setfield($field,$value);
1040 confess "errant AUTOLOAD $field for $self (no args)"
1041 unless blessed($self) && $self->can('getfield');
1042 $self->getfield($field);
1048 # my $field = $AUTOLOAD;
1049 # $field =~ s/.*://;
1050 # if ( defined($_[1]) ) {
1051 # $_[0]->setfield($field, $_[1]);
1053 # $_[0]->getfield($field);
1059 Returns a list of the column/value pairs, usually for assigning to a new hash.
1061 To make a distinct duplicate of an FS::Record object, you can do:
1063 $new = new FS::Record ( $old->table, { $old->hash } );
1069 confess $self. ' -> hash: Hash attribute is undefined'
1070 unless defined($self->{'Hash'});
1071 %{ $self->{'Hash'} };
1076 Returns a reference to the column/value hash. This may be deprecated in the
1077 future; if there's a reason you can't just use the autoloaded or get/set
1089 Returns true if any of this object's values have been modified with set (or via
1090 an autoloaded method). Doesn't yet recognize when you retreive a hashref and
1097 $self->{'modified'};
1100 =item select_for_update
1102 Selects this record with the SQL "FOR UPDATE" command. This can be useful as
1107 sub select_for_update {
1109 my $primary_key = $self->primary_key;
1112 'table' => $self->table,
1113 'hashref' => { $primary_key => $self->$primary_key() },
1114 'extra_sql' => 'FOR UPDATE',
1120 Locks this table with a database-driver specific lock method. This is used
1121 as a mutex in order to do a duplicate search.
1123 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
1125 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
1127 Errors are fatal; no useful return value.
1129 Note: To use this method for new tables other than svc_acct and svc_phone,
1130 edit freeside-upgrade and add those tables to the duplicate_lock list.
1136 my $table = $self->table;
1138 warn "$me locking $table table\n" if $DEBUG;
1140 if ( driver_name =~ /^Pg/i ) {
1142 dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
1145 } elsif ( driver_name =~ /^mysql/i ) {
1147 dbh->do("SELECT * FROM duplicate_lock
1148 WHERE lockname = '$table'
1150 ) or die dbh->errstr;
1154 die "unknown database ". driver_name. "; don't know how to lock table";
1158 warn "$me acquired $table table lock\n" if $DEBUG;
1164 Inserts this record to the database. If there is an error, returns the error,
1165 otherwise returns false.
1173 warn "$self -> insert" if $DEBUG;
1175 my $error = $self->check;
1176 return $error if $error;
1178 #single-field non-null unique keys are given a value if empty
1179 #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
1180 foreach ( $self->dbdef_table->unique_singles) {
1181 next if $self->getfield($_);
1182 next if $self->dbdef_table->column($_)->null eq 'NULL';
1186 #and also the primary key, if the database isn't going to
1187 my $primary_key = $self->dbdef_table->primary_key;
1189 if ( $primary_key ) {
1190 my $col = $self->dbdef_table->column($primary_key);
1193 uc($col->type) =~ /^(BIG)?SERIAL\d?/
1194 || ( driver_name eq 'Pg'
1195 && defined($col->default)
1196 && $col->quoted_default =~ /^nextval\(/i
1198 || ( driver_name eq 'mysql'
1199 && defined($col->local)
1200 && $col->local =~ /AUTO_INCREMENT/i
1202 $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
1205 my $table = $self->table;
1207 # Encrypt before the database
1208 if ( scalar( eval '@FS::'. $table . '::encrypted_fields')
1211 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
1212 next if $field eq 'payinfo'
1213 && ($self->isa('FS::payinfo_transaction_Mixin')
1214 || $self->isa('FS::payinfo_Mixin') )
1216 && !grep { $self->payby eq $_ } @encrypt_payby;
1217 $saved->{$field} = $self->getfield($field);
1218 $self->setfield($field, $self->encrypt($self->getfield($field)));
1222 #false laziness w/delete
1224 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1227 my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
1230 my $statement = "INSERT INTO $table ";
1231 if ( @real_fields ) {
1234 join( ', ', @real_fields ).
1236 join( ', ', @values ).
1240 $statement .= 'DEFAULT VALUES';
1242 warn "[debug]$me $statement\n" if $DEBUG > 1;
1243 my $sth = dbh->prepare($statement) or return dbh->errstr;
1245 local $SIG{HUP} = 'IGNORE';
1246 local $SIG{INT} = 'IGNORE';
1247 local $SIG{QUIT} = 'IGNORE';
1248 local $SIG{TERM} = 'IGNORE';
1249 local $SIG{TSTP} = 'IGNORE';
1250 local $SIG{PIPE} = 'IGNORE';
1252 $sth->execute or return $sth->errstr;
1254 # get inserted id from the database, if applicable & needed
1255 if ( $db_seq && ! $self->getfield($primary_key) ) {
1256 warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
1260 if ( driver_name eq 'Pg' ) {
1262 #my $oid = $sth->{'pg_oid_status'};
1263 #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
1265 my $default = $self->dbdef_table->column($primary_key)->quoted_default;
1266 unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
1267 dbh->rollback if $FS::UID::AutoCommit;
1268 return "can't parse $table.$primary_key default value".
1269 " for sequence name: $default";
1273 my $i_sql = "SELECT currval('$sequence')";
1274 my $i_sth = dbh->prepare($i_sql) or do {
1275 dbh->rollback if $FS::UID::AutoCommit;
1278 $i_sth->execute() or do { #$i_sth->execute($oid)
1279 dbh->rollback if $FS::UID::AutoCommit;
1280 return $i_sth->errstr;
1282 $insertid = $i_sth->fetchrow_arrayref->[0];
1284 } elsif ( driver_name eq 'mysql' ) {
1286 $insertid = dbh->{'mysql_insertid'};
1287 # work around mysql_insertid being null some of the time, ala RT :/
1288 unless ( $insertid ) {
1289 warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
1290 "using SELECT LAST_INSERT_ID();";
1291 my $i_sql = "SELECT LAST_INSERT_ID()";
1292 my $i_sth = dbh->prepare($i_sql) or do {
1293 dbh->rollback if $FS::UID::AutoCommit;
1296 $i_sth->execute or do {
1297 dbh->rollback if $FS::UID::AutoCommit;
1298 return $i_sth->errstr;
1300 $insertid = $i_sth->fetchrow_arrayref->[0];
1305 dbh->rollback if $FS::UID::AutoCommit;
1306 return "don't know how to retreive inserted ids from ". driver_name.
1307 ", try using counterfiles (maybe run dbdef-create?)";
1311 $self->setfield($primary_key, $insertid);
1316 if ( defined( dbdef->table('h_'. $table) ) && ! $no_history ) {
1317 my $h_statement = $self->_h_statement('insert');
1318 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1319 $h_sth = dbh->prepare($h_statement) or do {
1320 dbh->rollback if $FS::UID::AutoCommit;
1326 $h_sth->execute or return $h_sth->errstr if $h_sth;
1328 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1330 # Now that it has been saved, reset the encrypted fields so that $new
1331 # can still be used.
1332 foreach my $field (keys %{$saved}) {
1333 $self->setfield($field, $saved->{$field});
1341 Depriciated (use insert instead).
1346 cluck "warning: FS::Record::add deprecated!";
1347 insert @_; #call method in this scope
1352 Delete this record from the database. If there is an error, returns the error,
1353 otherwise returns false.
1360 my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1362 $self->getfield($_) eq ''
1363 #? "( $_ IS NULL OR $_ = \"\" )"
1364 ? ( driver_name eq 'Pg'
1366 : "( $_ IS NULL OR $_ = \"\" )"
1368 : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1369 } ( $self->dbdef_table->primary_key )
1370 ? ( $self->dbdef_table->primary_key)
1371 : real_fields($self->table)
1373 warn "[debug]$me $statement\n" if $DEBUG > 1;
1374 my $sth = dbh->prepare($statement) or return dbh->errstr;
1377 if ( defined dbdef->table('h_'. $self->table) ) {
1378 my $h_statement = $self->_h_statement('delete');
1379 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1380 $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1385 my $primary_key = $self->dbdef_table->primary_key;
1387 local $SIG{HUP} = 'IGNORE';
1388 local $SIG{INT} = 'IGNORE';
1389 local $SIG{QUIT} = 'IGNORE';
1390 local $SIG{TERM} = 'IGNORE';
1391 local $SIG{TSTP} = 'IGNORE';
1392 local $SIG{PIPE} = 'IGNORE';
1394 my $rc = $sth->execute or return $sth->errstr;
1395 #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1396 $h_sth->execute or return $h_sth->errstr if $h_sth;
1398 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1400 #no need to needlessly destoy the data either (causes problems actually)
1401 #undef $self; #no need to keep object!
1408 Depriciated (use delete instead).
1413 cluck "warning: FS::Record::del deprecated!";
1414 &delete(@_); #call method in this scope
1417 =item replace OLD_RECORD
1419 Replace the OLD_RECORD with this one in the database. If there is an error,
1420 returns the error, otherwise returns false.
1425 my ($new, $old) = (shift, shift);
1427 $old = $new->replace_old unless defined($old);
1429 warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1431 if ( $new->can('replace_check') ) {
1432 my $error = $new->replace_check($old);
1433 return $error if $error;
1436 return "Records not in same table!" unless $new->table eq $old->table;
1438 my $primary_key = $old->dbdef_table->primary_key;
1439 return "Can't change primary key $primary_key ".
1440 'from '. $old->getfield($primary_key).
1441 ' to ' . $new->getfield($primary_key)
1443 && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1445 my $error = $new->check;
1446 return $error if $error;
1448 # Encrypt for replace
1450 if ( scalar( eval '@FS::'. $new->table . '::encrypted_fields')
1453 foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1454 next if $field eq 'payinfo'
1455 && ($new->isa('FS::payinfo_transaction_Mixin')
1456 || $new->isa('FS::payinfo_Mixin') )
1458 && !grep { $new->payby eq $_ } @encrypt_payby;
1459 $saved->{$field} = $new->getfield($field);
1460 $new->setfield($field, $new->encrypt($new->getfield($field)));
1464 #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1465 my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1466 ? ($_, $new->getfield($_)) : () } $old->fields;
1468 unless (keys(%diff) || $no_update_diff ) {
1469 carp "[warning]$me ". ref($new)."->replace ".
1470 ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
1471 ": records identical"
1472 unless $nowarn_identical;
1476 my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1478 "$_ = ". _quote($new->getfield($_),$old->table,$_)
1479 } real_fields($old->table)
1484 if ( $old->getfield($_) eq '' ) {
1486 #false laziness w/qsearch
1487 if ( driver_name eq 'Pg' ) {
1488 my $type = $old->dbdef_table->column($_)->type;
1489 if ( $type =~ /(int|(big)?serial)/i ) {
1492 qq-( $_ IS NULL OR $_ = '' )-;
1495 qq-( $_ IS NULL OR $_ = "" )-;
1499 "$_ = ". _quote($old->getfield($_),$old->table,$_);
1502 } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1505 warn "[debug]$me $statement\n" if $DEBUG > 1;
1506 my $sth = dbh->prepare($statement) or return dbh->errstr;
1509 if ( defined dbdef->table('h_'. $old->table) ) {
1510 my $h_old_statement = $old->_h_statement('replace_old');
1511 warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1512 $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1518 if ( defined dbdef->table('h_'. $new->table) ) {
1519 my $h_new_statement = $new->_h_statement('replace_new');
1520 warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1521 $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1526 local $SIG{HUP} = 'IGNORE';
1527 local $SIG{INT} = 'IGNORE';
1528 local $SIG{QUIT} = 'IGNORE';
1529 local $SIG{TERM} = 'IGNORE';
1530 local $SIG{TSTP} = 'IGNORE';
1531 local $SIG{PIPE} = 'IGNORE';
1533 my $rc = $sth->execute or return $sth->errstr;
1534 #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1535 $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1536 $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1538 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1540 # Now that it has been saved, reset the encrypted fields so that $new
1541 # can still be used.
1542 foreach my $field (keys %{$saved}) {
1543 $new->setfield($field, $saved->{$field});
1551 my( $self ) = shift;
1552 warn "[$me] replace called with no arguments; autoloading old record\n"
1555 my $primary_key = $self->dbdef_table->primary_key;
1556 if ( $primary_key ) {
1557 $self->by_key( $self->$primary_key() ) #this is what's returned
1558 or croak "can't find ". $self->table. ".$primary_key ".
1559 $self->$primary_key();
1561 croak $self->table. " has no primary key; pass old record as argument";
1568 Depriciated (use replace instead).
1573 cluck "warning: FS::Record::rep deprecated!";
1574 replace @_; #call method in this scope
1579 Checks custom fields. Subclasses should still provide a check method to validate
1580 non-custom fields, foreign keys, etc., and call this method via $self->SUPER::check.
1586 foreach my $field ($self->virtual_fields) {
1587 my $error = $self->ut_textn($field);
1588 return $error if $error;
1593 =item virtual_fields [ TABLE ]
1595 Returns a list of virtual fields defined for the table. This should not
1596 be exported, and should only be called as an instance or class method.
1600 sub virtual_fields {
1603 $table = $self->table or confess "virtual_fields called on non-table";
1605 confess "Unknown table $table" unless dbdef->table($table);
1607 return () unless dbdef->table('part_virtual_field');
1609 unless ( $virtual_fields_cache{$table} ) {
1610 my $concat = [ "'cf_'", "name" ];
1611 my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' .
1612 "WHERE dbtable = '$table'";
1614 my $result = $dbh->selectcol_arrayref($query);
1615 confess "Error executing virtual fields query: $query: ". $dbh->errstr
1617 $virtual_fields_cache{$table} = $result;
1620 @{$virtual_fields_cache{$table}};
1624 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1626 Processes a batch import as a queued JSRPC job
1628 JOB is an FS::queue entry.
1630 OPTIONS_HASHREF can have the following keys:
1636 Table name (required).
1640 Arrayref of field names for static fields. They will be given values from the
1641 PARAMS hashref and passed as a "params" hashref to batch_import.
1645 Formats hashref. Keys are field names, values are listrefs that define the
1648 Each listref value can be a column name or a code reference. Coderefs are run
1649 with the row object, data and a FS::Conf object as the three parameters.
1650 For example, this coderef does the same thing as using the "columnname" string:
1653 my( $record, $data, $conf ) = @_;
1654 $record->columnname( $data );
1657 Coderefs are run after all "column name" fields are assigned.
1661 Optional format hashref of types. Keys are field names, values are "csv",
1662 "xls" or "fixedlength". Overrides automatic determination of file type
1665 =item format_headers
1667 Optional format hashref of header lines. Keys are field names, values are 0
1668 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1671 =item format_sep_chars
1673 Optional format hashref of CSV sep_chars. Keys are field names, values are the
1674 CSV separation character.
1676 =item format_fixedlenth_formats
1678 Optional format hashref of fixed length format defintiions. Keys are field
1679 names, values Parse::FixedLength listrefs of field definitions.
1683 Set true to default to CSV file type if the filename does not contain a
1684 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1689 PARAMS is a hashref (or base64-encoded Storable hashref) containing the
1690 POSTed data. It must contain the field "uploaded files", generated by
1691 /elements/file-upload.html and containing the list of uploaded files.
1692 Currently only supports a single file named "file".
1696 # uploaded_files is kind of bizarre; fix that some time
1698 use Storable qw(thaw);
1701 sub process_batch_import {
1702 my($job, $opt) = ( shift, shift );
1704 my $table = $opt->{table};
1705 my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1706 my %formats = %{ $opt->{formats} };
1709 # because some job-spawning code (JSRPC) pre-freezes the arguments,
1710 # and then the 'frozen' attribute doesn't get set, and thus $job->args
1711 # doesn't know to thaw them, we have to do this everywhere.
1713 $param = thaw(decode_base64($param));
1715 warn Dumper($param) if $DEBUG;
1717 my $files = $param->{'uploaded_files'}
1718 or die "No files provided.\n";
1720 my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1722 my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1723 my $file = $dir. $files{'file'};
1728 formats => \%formats,
1729 format_types => $opt->{format_types},
1730 format_headers => $opt->{format_headers},
1731 format_sep_chars => $opt->{format_sep_chars},
1732 format_fixedlength_formats => $opt->{format_fixedlength_formats},
1733 format_xml_formats => $opt->{format_xml_formats},
1734 format_asn_formats => $opt->{format_asn_formats},
1735 format_row_callbacks => $opt->{format_row_callbacks},
1736 format_hash_callbacks => $opt->{format_hash_callbacks},
1741 format => $param->{format},
1742 params => { map { $_ => $param->{$_} } @pass_params },
1744 default_csv => $opt->{default_csv},
1745 preinsert_callback => $opt->{preinsert_callback},
1746 postinsert_callback => $opt->{postinsert_callback},
1747 insert_args_callback => $opt->{insert_args_callback},
1750 if ( $opt->{'batch_namecol'} ) {
1751 $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1752 $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1755 my $error = FS::Record::batch_import( \%iopt );
1759 die "$error\n" if $error;
1762 =item batch_import PARAM_HASHREF
1764 Class method for batch imports. Available params:
1770 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1776 =item format_headers
1778 =item format_sep_chars
1780 =item format_fixedlength_formats
1782 =item format_row_callbacks
1784 =item format_hash_callbacks - After parsing, before object creation
1786 =item fields - Alternate way to specify import, specifying import fields directly as a listref
1788 =item preinsert_callback
1790 =item postinsert_callback
1796 FS::queue object, will be updated with progress
1802 csv, xls, fixedlength, xml
1813 warn "$me batch_import call with params: \n". Dumper($param)
1816 my $table = $param->{table};
1818 my $job = $param->{job};
1819 my $file = $param->{file};
1820 my $params = $param->{params} || {};
1822 my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
1823 my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
1825 my( $type, $header, $sep_char,
1826 $fixedlength_format, $xml_format, $asn_format,
1827 $parser_opt, $row_callback, $hash_callback, @fields );
1829 my $postinsert_callback = '';
1830 $postinsert_callback = $param->{'postinsert_callback'}
1831 if $param->{'postinsert_callback'};
1832 my $preinsert_callback = '';
1833 $preinsert_callback = $param->{'preinsert_callback'}
1834 if $param->{'preinsert_callback'};
1835 my $insert_args_callback = '';
1836 $insert_args_callback = $param->{'insert_args_callback'}
1837 if $param->{'insert_args_callback'};
1839 if ( $param->{'format'} ) {
1841 my $format = $param->{'format'};
1842 my $formats = $param->{formats};
1843 die "unknown format $format" unless exists $formats->{ $format };
1845 $type = $param->{'format_types'}
1846 ? $param->{'format_types'}{ $format }
1847 : $param->{type} || 'csv';
1850 $header = $param->{'format_headers'}
1851 ? $param->{'format_headers'}{ $param->{'format'} }
1854 $sep_char = $param->{'format_sep_chars'}
1855 ? $param->{'format_sep_chars'}{ $param->{'format'} }
1858 $fixedlength_format =
1859 $param->{'format_fixedlength_formats'}
1860 ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1864 $param->{'format_parser_opts'}
1865 ? $param->{'format_parser_opts'}{ $param->{'format'} }
1869 $param->{'format_xml_formats'}
1870 ? $param->{'format_xml_formats'}{ $param->{'format'} }
1874 $param->{'format_asn_formats'}
1875 ? $param->{'format_asn_formats'}{ $param->{'format'} }
1879 $param->{'format_row_callbacks'}
1880 ? $param->{'format_row_callbacks'}{ $param->{'format'} }
1884 $param->{'format_hash_callbacks'}
1885 ? $param->{'format_hash_callbacks'}{ $param->{'format'} }
1888 @fields = @{ $formats->{ $format } };
1890 } elsif ( $param->{'fields'} ) {
1892 $type = ''; #infer from filename
1895 $fixedlength_format = '';
1897 $hash_callback = '';
1898 @fields = @{ $param->{'fields'} };
1901 die "neither format nor fields specified";
1904 #my $file = $param->{file};
1907 if ( $file =~ /\.(\w+)$/i ) {
1911 warn "can't parse file type from filename $file; defaulting to CSV";
1915 if $param->{'default_csv'} && $type ne 'xls';
1923 my $asn_header_buffer;
1924 if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1926 if ( $type eq 'csv' ) {
1928 $parser_opt->{'binary'} = 1;
1929 $parser_opt->{'sep_char'} = $sep_char if $sep_char;
1930 $parser = Text::CSV_XS->new($parser_opt);
1932 } elsif ( $type eq 'fixedlength' ) {
1934 eval "use Parse::FixedLength;";
1936 $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
1939 die "Unknown file type $type\n";
1942 @buffer = split(/\r?\n/, slurp($file) );
1943 splice(@buffer, 0, ($header || 0) );
1944 $count = scalar(@buffer);
1946 } elsif ( $type eq 'xls' ) {
1948 eval "use Spreadsheet::ParseExcel;";
1951 eval "use DateTime::Format::Excel;";
1952 #for now, just let the error be thrown if it is used, since only CDR
1953 # formats bill_west and troop use it, not other excel-parsing things
1956 my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
1958 $parser = $excel->{Worksheet}[0]; #first sheet
1960 $count = $parser->{MaxRow} || $parser->{MinRow};
1963 $row = $header || 0;
1965 } elsif ( $type eq 'xml' ) {
1968 eval "use XML::Simple;";
1970 my $xmlrow = $xml_format->{'xmlrow'};
1971 $parser = $xml_format->{'xmlkeys'};
1972 die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
1973 my $data = XML::Simple::XMLin(
1975 'SuppressEmpty' => '', #sets empty values to ''
1979 $rows = $rows->{$_} foreach @$xmlrow;
1980 $rows = [ $rows ] if ref($rows) ne 'ARRAY';
1981 $count = @buffer = @$rows;
1983 } elsif ( $type eq 'asn.1' ) {
1985 eval "use Convert::ASN1";
1988 my $asn = Convert::ASN1->new;
1989 $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
1991 $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
1993 my $data = slurp($file);
1994 my $asn_output = $parser->decode( $data )
1995 or return "No ". $asn_format->{'macro'}. " found\n";
1997 $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
1999 my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
2000 $count = @buffer = @$rows;
2003 die "Unknown file type $type\n";
2008 local $SIG{HUP} = 'IGNORE';
2009 local $SIG{INT} = 'IGNORE';
2010 local $SIG{QUIT} = 'IGNORE';
2011 local $SIG{TERM} = 'IGNORE';
2012 local $SIG{TSTP} = 'IGNORE';
2013 local $SIG{PIPE} = 'IGNORE';
2015 my $oldAutoCommit = $FS::UID::AutoCommit;
2016 local $FS::UID::AutoCommit = 0;
2019 #my $params = $param->{params} || {};
2020 if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
2021 my $batch_col = $param->{'batch_keycol'};
2023 my $batch_class = 'FS::'. $param->{'batch_table'};
2024 my $batch = $batch_class->new({
2025 $param->{'batch_namecol'} => $param->{'batch_namevalue'}
2027 my $error = $batch->insert;
2029 $dbh->rollback if $oldAutoCommit;
2030 return "can't insert batch record: $error";
2032 #primary key via dbdef? (so the column names don't have to match)
2033 my $batch_value = $batch->get( $param->{'batch_keycol'} );
2035 $params->{ $batch_col } = $batch_value;
2038 #my $job = $param->{job};
2041 my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
2045 my %hash = %$params;
2046 if ( $type eq 'csv' ) {
2048 last unless scalar(@buffer);
2049 $line = shift(@buffer);
2051 next if $line =~ /^\s*$/; #skip empty lines
2053 $line = &{$row_callback}($line) if $row_callback;
2055 next if $line =~ /^\s*$/; #skip empty lines
2057 $parser->parse($line) or do {
2058 $dbh->rollback if $oldAutoCommit;
2059 return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
2061 @columns = $parser->fields();
2063 } elsif ( $type eq 'fixedlength' ) {
2065 last unless scalar(@buffer);
2066 $line = shift(@buffer);
2068 @columns = $parser->parse($line);
2070 } elsif ( $type eq 'xls' ) {
2072 last if $row > ($parser->{MaxRow} || $parser->{MinRow})
2073 || ! $parser->{Cells}[$row];
2075 my @row = @{ $parser->{Cells}[$row] };
2076 @columns = map $_->{Val}, @row;
2079 #warn $z++. ": $_\n" for @columns;
2081 } elsif ( $type eq 'xml' ) {
2083 # $parser = [ 'Column0Key', 'Column1Key' ... ]
2084 last unless scalar(@buffer);
2085 my $row = shift @buffer;
2086 @columns = @{ $row }{ @$parser };
2088 } elsif ( $type eq 'asn.1' ) {
2090 last unless scalar(@buffer);
2091 my $row = shift @buffer;
2092 &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2093 if $asn_format->{row_callback};
2094 foreach my $key ( keys %{ $asn_format->{map} } ) {
2095 $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2099 die "Unknown file type $type\n";
2104 foreach my $field ( @fields ) {
2106 my $value = shift @columns;
2108 if ( ref($field) eq 'CODE' ) {
2109 #&{$field}(\%hash, $value);
2110 push @later, $field, $value;
2112 #??? $hash{$field} = $value if length($value);
2113 $hash{$field} = $value if defined($value) && length($value);
2118 if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
2119 && length($1) == $custnum_length ) {
2120 $hash{custnum} = $2;
2123 %hash = &{$hash_callback}(%hash) if $hash_callback;
2125 #my $table = $param->{table};
2126 my $class = "FS::$table";
2128 my $record = $class->new( \%hash );
2131 while ( scalar(@later) ) {
2132 my $sub = shift @later;
2133 my $data = shift @later;
2135 &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2138 $dbh->rollback if $oldAutoCommit;
2139 return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2141 last if exists( $param->{skiprow} );
2143 next if exists( $param->{skiprow} );
2145 if ( $preinsert_callback ) {
2146 my $error = &{$preinsert_callback}($record, $param);
2148 $dbh->rollback if $oldAutoCommit;
2149 return "preinsert_callback error". ( $line ? " for $line" : '' ).
2152 next if exists $param->{skiprow} && $param->{skiprow};
2155 my @insert_args = ();
2156 if ( $insert_args_callback ) {
2157 @insert_args = &{$insert_args_callback}($record, $param);
2160 my $error = $record->insert(@insert_args);
2163 $dbh->rollback if $oldAutoCommit;
2164 return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2170 if ( $postinsert_callback ) {
2171 my $error = &{$postinsert_callback}($record, $param);
2173 $dbh->rollback if $oldAutoCommit;
2174 return "postinsert_callback error". ( $line ? " for $line" : '' ).
2179 if ( $job && time - $min_sec > $last ) { #progress bar
2180 $job->update_statustext( int(100 * $imported / $count) );
2186 unless ( $imported || $param->{empty_ok} ) {
2187 $dbh->rollback if $oldAutoCommit;
2188 return "Empty file!";
2191 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2198 my( $self, $action, $time ) = @_;
2202 my %nohistory = map { $_=>1 } $self->nohistory_fields;
2205 grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2206 real_fields($self->table);
2209 # If we're encrypting then don't store the payinfo in the history
2210 if ( $conf_encryption && $self->table ne 'banned_pay' ) {
2211 @fields = grep { $_ ne 'payinfo' } @fields;
2214 my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2216 "INSERT INTO h_". $self->table. " ( ".
2217 join(', ', qw(history_date history_user history_action), @fields ).
2220 dbh->quote($FS::CurrentUser::CurrentUser->username),
2221 dbh->quote($action),
2230 B<Warning>: External use is B<deprecated>.
2232 Replaces COLUMN in record with a unique number, using counters in the
2233 filesystem. Used by the B<insert> method on single-field unique columns
2234 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2235 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2237 Returns the new value.
2242 my($self,$field) = @_;
2243 my($table)=$self->table;
2245 croak "Unique called on field $field, but it is ",
2246 $self->getfield($field),
2248 if $self->getfield($field);
2250 #warn "table $table is tainted" if is_tainted($table);
2251 #warn "field $field is tainted" if is_tainted($field);
2253 my($counter) = new File::CounterFile "$table.$field",0;
2255 # getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
2257 # my($counter) = new File::CounterFile "$user/$table.$field",0;
2260 my $index = $counter->inc;
2261 $index = $counter->inc while qsearchs($table, { $field=>$index } );
2263 $index =~ /^(\d*)$/;
2266 $self->setfield($field,$index);
2270 =item ut_float COLUMN
2272 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be
2273 null. If there is an error, returns the error, otherwise returns false.
2278 my($self,$field)=@_ ;
2279 ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2280 $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2281 $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2282 $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2283 or return "Illegal or empty (float) $field: ". $self->getfield($field);
2284 $self->setfield($field,$1);
2287 =item ut_floatn COLUMN
2289 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
2290 null. If there is an error, returns the error, otherwise returns false.
2294 #false laziness w/ut_ipn
2296 my( $self, $field ) = @_;
2297 if ( $self->getfield($field) =~ /^()$/ ) {
2298 $self->setfield($field,'');
2301 $self->ut_float($field);
2305 =item ut_sfloat COLUMN
2307 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2308 May not be null. If there is an error, returns the error, otherwise returns
2314 my($self,$field)=@_ ;
2315 ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2316 $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2317 $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2318 $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2319 or return "Illegal or empty (float) $field: ". $self->getfield($field);
2320 $self->setfield($field,$1);
2323 =item ut_sfloatn COLUMN
2325 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
2326 null. If there is an error, returns the error, otherwise returns false.
2331 my( $self, $field ) = @_;
2332 if ( $self->getfield($field) =~ /^()$/ ) {
2333 $self->setfield($field,'');
2336 $self->ut_sfloat($field);
2340 =item ut_snumber COLUMN
2342 Check/untaint signed numeric data (whole numbers). If there is an error,
2343 returns the error, otherwise returns false.
2348 my($self, $field) = @_;
2349 $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2350 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2351 $self->setfield($field, "$1$2");
2355 =item ut_snumbern COLUMN
2357 Check/untaint signed numeric data (whole numbers). If there is an error,
2358 returns the error, otherwise returns false.
2363 my($self, $field) = @_;
2364 $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2365 or return "Illegal (numeric) $field: ". $self->getfield($field);
2367 return "Illegal (numeric) $field: ". $self->getfield($field)
2370 $self->setfield($field, "$1$2");
2374 =item ut_number COLUMN
2376 Check/untaint simple numeric data (whole numbers). May not be null. If there
2377 is an error, returns the error, otherwise returns false.
2382 my($self,$field)=@_;
2383 $self->getfield($field) =~ /^\s*(\d+)\s*$/
2384 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2385 $self->setfield($field,$1);
2389 =item ut_numbern COLUMN
2391 Check/untaint simple numeric data (whole numbers). May be null. If there is
2392 an error, returns the error, otherwise returns false.
2397 my($self,$field)=@_;
2398 $self->getfield($field) =~ /^\s*(\d*)\s*$/
2399 or return "Illegal (numeric) $field: ". $self->getfield($field);
2400 $self->setfield($field,$1);
2404 =item ut_decimal COLUMN[, DIGITS]
2406 Check/untaint decimal numbers (up to DIGITS decimal places. If there is an
2407 error, returns the error, otherwise returns false.
2409 =item ut_decimaln COLUMN[, DIGITS]
2411 Check/untaint decimal numbers. May be null. If there is an error, returns
2412 the error, otherwise returns false.
2417 my($self, $field, $digits) = @_;
2419 $self->getfield($field) =~ /^\s*(\d+(\.\d{0,$digits})?)\s*$/
2420 or return "Illegal or empty (decimal) $field: ".$self->getfield($field);
2421 $self->setfield($field, $1);
2426 my($self, $field, $digits) = @_;
2427 $self->getfield($field) =~ /^\s*(\d*(\.\d{0,$digits})?)\s*$/
2428 or return "Illegal (decimal) $field: ".$self->getfield($field);
2429 $self->setfield($field, $1);
2433 =item ut_money COLUMN
2435 Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
2436 is an error, returns the error, otherwise returns false.
2441 my($self,$field)=@_;
2443 if ( $self->getfield($field) eq '' ) {
2444 $self->setfield($field, 0);
2445 } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2446 #handle one decimal place without barfing out
2447 $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2448 } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2449 $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2451 return "Illegal (money) $field: ". $self->getfield($field);
2457 =item ut_moneyn COLUMN
2459 Check/untaint monetary numbers. May be negative. If there
2460 is an error, returns the error, otherwise returns false.
2465 my($self,$field)=@_;
2466 if ($self->getfield($field) eq '') {
2467 $self->setfield($field, '');
2470 $self->ut_money($field);
2473 =item ut_text COLUMN
2475 Check/untaint text. Alphanumerics, spaces, and the following punctuation
2476 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < > ~
2477 May not be null. If there is an error, returns the error, otherwise returns
2483 my($self,$field)=@_;
2484 #warn "msgcat ". \&msgcat. "\n";
2485 #warn "notexist ". \¬exist. "\n";
2486 #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2487 # \p{Word} = alphanumerics, marks (diacritics), and connectors
2488 # see perldoc perluniprops
2489 $self->getfield($field)
2490 =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>\~$money_char]+)$/
2491 or return gettext('illegal_or_empty_text'). " $field: ".
2492 $self->getfield($field);
2493 $self->setfield($field,$1);
2497 =item ut_textn COLUMN
2499 Check/untaint text. Alphanumerics, spaces, and the following punctuation
2500 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2501 May be null. If there is an error, returns the error, otherwise returns false.
2506 my($self,$field)=@_;
2507 return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2508 $self->ut_text($field);
2511 =item ut_alpha COLUMN
2513 Check/untaint alphanumeric strings (no spaces). May not be null. If there is
2514 an error, returns the error, otherwise returns false.
2519 my($self,$field)=@_;
2520 $self->getfield($field) =~ /^(\w+)$/
2521 or return "Illegal or empty (alphanumeric) $field: ".
2522 $self->getfield($field);
2523 $self->setfield($field,$1);
2527 =item ut_alphan COLUMN
2529 Check/untaint alphanumeric strings (no spaces). May be null. If there is an
2530 error, returns the error, otherwise returns false.
2535 my($self,$field)=@_;
2536 $self->getfield($field) =~ /^(\w*)$/
2537 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2538 $self->setfield($field,$1);
2542 =item ut_alphasn COLUMN
2544 Check/untaint alphanumeric strings, spaces allowed. May be null. If there is
2545 an error, returns the error, otherwise returns false.
2550 my($self,$field)=@_;
2551 $self->getfield($field) =~ /^([\w ]*)$/
2552 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2553 $self->setfield($field,$1);
2558 =item ut_alpha_lower COLUMN
2560 Check/untaint lowercase alphanumeric strings (no spaces). May not be null. If
2561 there is an error, returns the error, otherwise returns false.
2565 sub ut_alpha_lower {
2566 my($self,$field)=@_;
2567 $self->getfield($field) =~ /[[:upper:]]/
2568 and return "Uppercase characters are not permitted in $field";
2569 $self->ut_alpha($field);
2572 =item ut_phonen COLUMN [ COUNTRY ]
2574 Check/untaint phone numbers. May be null. If there is an error, returns
2575 the error, otherwise returns false.
2577 Takes an optional two-letter ISO 3166-1 alpha-2 country code; without
2578 it or with unsupported countries, ut_phonen simply calls ut_alphan.
2583 my( $self, $field, $country ) = @_;
2584 return $self->ut_alphan($field) unless defined $country;
2585 my $phonen = $self->getfield($field);
2586 if ( $phonen eq '' ) {
2587 $self->setfield($field,'');
2588 } elsif ( $country eq 'US' || $country eq 'CA' ) {
2590 $phonen = $conf->config('cust_main-default_areacode').$phonen
2591 if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2592 $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2593 or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2594 $phonen = "$1-$2-$3";
2595 $phonen .= " x$4" if $4;
2596 $self->setfield($field,$phonen);
2598 warn "warning: don't know how to check phone numbers for country $country";
2599 return $self->ut_textn($field);
2606 Check/untaint hexadecimal values.
2611 my($self, $field) = @_;
2612 $self->getfield($field) =~ /^([\da-fA-F]+)$/
2613 or return "Illegal (hex) $field: ". $self->getfield($field);
2614 $self->setfield($field, uc($1));
2618 =item ut_hexn COLUMN
2620 Check/untaint hexadecimal values. May be null.
2625 my($self, $field) = @_;
2626 $self->getfield($field) =~ /^([\da-fA-F]*)$/
2627 or return "Illegal (hex) $field: ". $self->getfield($field);
2628 $self->setfield($field, uc($1));
2632 =item ut_mac_addr COLUMN
2634 Check/untaint mac addresses. May be null.
2639 my($self, $field) = @_;
2641 my $mac = $self->get($field);
2644 $self->set($field, $mac);
2646 my $e = $self->ut_hex($field);
2649 return "Illegal (mac address) $field: ". $self->getfield($field)
2650 unless length($self->getfield($field)) == 12;
2656 =item ut_mac_addrn COLUMN
2658 Check/untaint mac addresses. May be null.
2663 my($self, $field) = @_;
2664 ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2669 Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
2675 my( $self, $field ) = @_;
2676 $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2677 $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2678 or return "Illegal (IP address) $field: ". $self->getfield($field);
2679 for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2680 $self->setfield( $field, $self->_ut_ip_strip_leading_zeros( "$1.$2.$3.$4" ));
2686 Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
2687 to 127.0.0.1. May be null.
2692 my( $self, $field ) = @_;
2693 if ( $self->getfield($field) =~ /^()$/ ) {
2694 $self->setfield($field,'');
2697 $self->ut_ip($field);
2701 =item ut_ip46 COLUMN
2703 Check/untaint IPv4 or IPv6 address.
2708 my( $self, $field ) = @_;
2709 my $ip = NetAddr::IP->new(
2710 $self->_ut_ip_strip_leading_zeros( $self->getfield($field) )
2711 ) or return "Illegal (IP address) $field: ".$self->getfield($field);
2712 $self->setfield($field, lc($ip->addr));
2718 Check/untaint IPv6 or IPv6 address. May be null.
2723 my( $self, $field ) = @_;
2724 if ( $self->getfield($field) =~ /^$/ ) {
2725 $self->setfield($field, '');
2728 $self->ut_ip46($field);
2731 sub _ut_ip_strip_leading_zeros {
2732 # strip user-entered leading 0's from IP addresses
2733 # so parsers like NetAddr::IP don't mangle the address
2734 # e.g. NetAddr::IP converts 10.0.022.220 into 10.0.18.220
2736 my ( $self, $ip ) = @_;
2738 return join '.', map int, split /\./, $ip
2745 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2747 Check/untaint coordinates.
2748 Accepts the following forms:
2758 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2759 The latter form (that is, the MMM are thousands of minutes) is
2760 assumed if the "MMM" is exactly three digits or two digits > 59.
2762 To be safe, just use the DDD.DDDDD form.
2764 If LOWER or UPPER are specified, then the coordinate is checked
2765 for lower and upper bounds, respectively.
2770 my ($self, $field) = (shift, shift);
2773 if ( $field =~ /latitude/ ) {
2774 $lower = $lat_lower;
2776 } elsif ( $field =~ /longitude/ ) {
2778 $upper = $lon_upper;
2781 my $coord = $self->getfield($field);
2782 my $neg = $coord =~ s/^(-)//;
2784 # ignore degree symbol at the end,
2785 # but not otherwise supporting degree/minutes/seconds symbols
2786 $coord =~ s/\N{DEGREE SIGN}\s*$//;
2788 my ($d, $m, $s) = (0, 0, 0);
2791 (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2792 (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2793 (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2795 $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2798 return "Invalid (coordinate with minutes > 59) $field: "
2799 . $self->getfield($field);
2802 $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2804 if (defined($lower) and ($coord < $lower)) {
2805 return "Invalid (coordinate < $lower) $field: "
2806 . $self->getfield($field);;
2809 if (defined($upper) and ($coord > $upper)) {
2810 return "Invalid (coordinate > $upper) $field: "
2811 . $self->getfield($field);;
2814 $self->setfield($field, $coord);
2818 return "Invalid (coordinate) $field: " . $self->getfield($field);
2822 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2824 Same as ut_coord, except optionally null.
2830 my ($self, $field) = (shift, shift);
2832 if ($self->getfield($field) =~ /^\s*$/) {
2835 return $self->ut_coord($field, @_);
2840 =item ut_domain COLUMN
2842 Check/untaint host and domain names. May not be null.
2847 my( $self, $field ) = @_;
2848 #$self->getfield($field) =~/^(\w+\.)*\w+$/
2849 $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2850 or return "Illegal (hostname) $field: ". $self->getfield($field);
2851 $self->setfield($field,$1);
2855 =item ut_domainn COLUMN
2857 Check/untaint host and domain names. May be null.
2862 my( $self, $field ) = @_;
2863 if ( $self->getfield($field) =~ /^()$/ ) {
2864 $self->setfield($field,'');
2867 $self->ut_domain($field);
2871 =item ut_name COLUMN
2873 Check/untaint proper names; allows alphanumerics, spaces and the following
2874 punctuation: , . - '
2881 my( $self, $field ) = @_;
2882 # warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
2883 $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
2884 or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2889 $self->setfield($field, $name);
2893 =item ut_namen COLUMN
2895 Check/untaint proper names; allows alphanumerics, spaces and the following
2896 punctuation: , . - '
2903 my( $self, $field ) = @_;
2904 return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2905 $self->ut_name($field);
2910 Check/untaint zip codes.
2914 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2917 my( $self, $field, $country ) = @_;
2919 if ( $country eq 'US' ) {
2921 $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2922 or return gettext('illegal_zip'). " $field for country $country: ".
2923 $self->getfield($field);
2924 $self->setfield($field, $1);
2926 } elsif ( $country eq 'CA' ) {
2928 $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2929 or return gettext('illegal_zip'). " $field for country $country: ".
2930 $self->getfield($field);
2931 $self->setfield($field, "$1 $2");
2933 } elsif ( $country eq 'AU' ) {
2935 $self->getfield($field) =~ /^\s*(\d{4})\s*$/
2936 or return gettext('illegal_zip'). " $field for country $country: ".
2937 $self->getfield($field);
2938 $self->setfield($field, $1);
2942 if ( $self->getfield($field) =~ /^\s*$/
2943 && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2946 $self->setfield($field,'');
2948 $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
2949 or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2950 $self->setfield($field,$1);
2958 =item ut_country COLUMN
2960 Check/untaint country codes. Country names are changed to codes, if possible -
2961 see L<Locale::Country>.
2966 my( $self, $field ) = @_;
2967 unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2968 if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2969 && country2code($1) ) {
2970 $self->setfield($field,uc(country2code($1)));
2973 $self->getfield($field) =~ /^(\w\w)$/
2974 or return "Illegal (country) $field: ". $self->getfield($field);
2975 $self->setfield($field,uc($1));
2979 =item ut_anything COLUMN
2981 Untaints arbitrary data. Be careful.
2986 my( $self, $field ) = @_;
2987 $self->getfield($field) =~ /^(.*)$/s
2988 or return "Illegal $field: ". $self->getfield($field);
2989 $self->setfield($field,$1);
2993 =item ut_enum COLUMN CHOICES_ARRAYREF
2995 Check/untaint a column, supplying all possible choices, like the "enum" type.
3000 my( $self, $field, $choices ) = @_;
3001 foreach my $choice ( @$choices ) {
3002 if ( $self->getfield($field) eq $choice ) {
3003 $self->setfield($field, $choice);
3007 return "Illegal (enum) field $field: ". $self->getfield($field);
3010 =item ut_enumn COLUMN CHOICES_ARRAYREF
3012 Like ut_enum, except the null value is also allowed.
3017 my( $self, $field, $choices ) = @_;
3018 $self->getfield($field)
3019 ? $self->ut_enum($field, $choices)
3023 =item ut_date COLUMN
3025 Check/untaint a column containing a date string.
3027 Date will be normalized to YYYY-MM-DD format
3032 my ( $self, $field ) = @_;
3033 my $value = $self->getfield( $field );
3035 my @date = split /[\-\/]/, $value;
3036 if ( scalar(@date) == 3 ) {
3037 @date = @date[2,0,1] if $date[2] >= 1900;
3042 # DateTime will die given invalid date
3043 $ymd = DateTime->new(
3051 $self->setfield( $field, $ymd ) unless $value eq $ymd;
3056 return "Illegal (date) field $field: $value";
3059 =item ut_daten COLUMN
3061 Check/untaint a column containing a date string.
3065 Date will be normalized to YYYY-MM-DD format
3070 my ( $self, $field ) = @_;
3072 $self->getfield( $field ) =~ /^()$/
3073 ? $self->setfield( $field, '' )
3074 : $self->ut_date( $field );
3077 =item ut_flag COLUMN
3079 Check/untaint a column if it contains either an empty string or 'Y'. This
3080 is the standard form for boolean flags in Freeside.
3085 my( $self, $field ) = @_;
3086 my $value = uc($self->getfield($field));
3087 if ( $value eq '' or $value eq 'Y' ) {
3088 $self->setfield($field, $value);
3091 return "Illegal (flag) field $field: $value";
3094 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3096 Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
3097 on the column first.
3101 sub ut_foreign_key {
3102 my( $self, $field, $table, $foreign ) = @_;
3103 return '' if $no_check_foreign;
3104 qsearchs($table, { $foreign => $self->getfield($field) })
3105 or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
3106 " in $table.$foreign";
3110 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3112 Like ut_foreign_key, except the null value is also allowed.
3116 sub ut_foreign_keyn {
3117 my( $self, $field, $table, $foreign ) = @_;
3118 $self->getfield($field)
3119 ? $self->ut_foreign_key($field, $table, $foreign)
3123 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
3125 Checks this column as an agentnum, taking into account the current users's
3126 ACLs. NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
3127 right or rights allowing no agentnum.
3131 sub ut_agentnum_acl {
3132 my( $self, $field ) = (shift, shift);
3133 my $null_acl = scalar(@_) ? shift : [];
3134 $null_acl = [ $null_acl ] unless ref($null_acl);
3136 my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
3137 return "Illegal agentnum: $error" if $error;
3139 my $curuser = $FS::CurrentUser::CurrentUser;
3141 if ( $self->$field() ) {
3143 return "Access denied"
3144 unless $curuser->agentnum($self->$field());
3148 return "Access denied"
3149 unless grep $curuser->access_right($_), @$null_acl;
3158 =item ut_email COLUMN
3160 Check column contains a valid E-Mail address
3165 my ( $self, $field ) = @_;
3166 Email::Valid->address( $self->getfield( $field ) )
3168 : "Illegal (email) field $field: ". $self->getfield( $field );
3171 =item ut_emailn COLUMN
3173 Check column contains a valid E-Mail address
3180 my ( $self, $field ) = @_;
3182 $self->getfield( $field ) =~ /^$/
3183 ? $self->getfield( $field, '' )
3184 : $self->ut_email( $field );
3187 =item trim_whitespace FIELD[, FIELD ... ]
3189 Strip leading and trailing spaces from the value in the named FIELD(s).
3193 sub trim_whitespace {
3195 foreach my $field (@_) {
3196 my $value = $self->get($field);
3199 $self->set($field, $value);
3203 =item fields [ TABLE ]
3205 This is a wrapper for real_fields. Code that called
3206 fields before should probably continue to call fields.
3211 my $something = shift;
3213 if($something->isa('FS::Record')) {
3214 $table = $something->table;
3216 $table = $something;
3217 $something = "FS::$table";
3219 return (real_fields($table));
3223 =item encrypt($value)
3225 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
3227 Returns the encrypted string.
3229 You should generally not have to worry about calling this, as the system handles this for you.
3234 my ($self, $value) = @_;
3235 my $encrypted = $value;
3237 if ($conf_encryption) {
3238 if ($self->is_encrypted($value)) {
3239 # Return the original value if it isn't plaintext.
3240 $encrypted = $value;
3243 if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
3244 # RSA doesn't like the empty string so let's pack it up
3245 # The database doesn't like the RSA data so uuencode it
3246 my $length = length($value)+1;
3247 $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
3249 die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
3256 =item is_encrypted($value)
3258 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
3264 my ($self, $value) = @_;
3265 # Possible Bug - Some work may be required here....
3267 if ($value =~ /^M/ && length($value) > 80) {
3274 =item decrypt($value)
3276 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
3278 You should generally not have to worry about calling this, as the system handles this for you.
3283 my ($self,$value) = @_;
3284 my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
3285 if ($conf_encryption && $self->is_encrypted($value)) {
3287 if (ref($rsa_decrypt) =~ /::RSA/) {
3288 my $encrypted = unpack ("u*", $value);
3289 $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
3290 if ($@) {warn "Decryption Failed"};
3298 #Initialize the Module
3299 $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
3301 if ($conf_encryptionmodule && $conf_encryptionmodule ne '') {
3302 $rsa_module = $conf_encryptionmodule;
3306 eval ("require $rsa_module"); # No need to import the namespace
3309 # Initialize Encryption
3310 if ($conf_encryptionpublickey && $conf_encryptionpublickey ne '') {
3311 $rsa_encrypt = $rsa_module->new_public_key($conf_encryptionpublickey);
3314 # Intitalize Decryption
3315 if ($conf_encryptionprivatekey && $conf_encryptionprivatekey ne '') {
3316 $rsa_decrypt = $rsa_module->new_private_key($conf_encryptionprivatekey);
3320 =item h_search ACTION
3322 Given an ACTION, either "insert", or "delete", returns the appropriate history
3323 record corresponding to this record, if any.
3328 my( $self, $action ) = @_;
3330 my $table = $self->table;
3333 my $primary_key = dbdef->table($table)->primary_key;
3336 'table' => "h_$table",
3337 'hashref' => { $primary_key => $self->$primary_key(),
3338 'history_action' => $action,
3346 Given an ACTION, either "insert", or "delete", returns the timestamp of the
3347 appropriate history record corresponding to this record, if any.
3352 my($self, $action) = @_;
3353 my $h = $self->h_search($action);
3354 $h ? $h->history_date : '';
3357 =item scalar_sql SQL [ PLACEHOLDER, ... ]
3359 A class or object method. Executes the sql statement represented by SQL and
3360 returns a scalar representing the result: the first column of the first row.
3362 Dies on bogus SQL. Returns an empty string if no row is returned.
3364 Typically used for statments which return a single value such as "SELECT
3365 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
3370 my($self, $sql) = (shift, shift);
3371 my $sth = dbh->prepare($sql) or die dbh->errstr;
3373 or die "Unexpected error executing statement $sql: ". $sth->errstr;
3374 my $row = $sth->fetchrow_arrayref or return '';
3375 my $scalar = $row->[0];
3376 defined($scalar) ? $scalar : '';
3379 =item count [ WHERE [, PLACEHOLDER ...] ]
3381 Convenience method for the common case of "SELECT COUNT(*) FROM table",
3382 with optional WHERE. Must be called as method on a class with an
3388 my($self, $where) = (shift, shift);
3389 my $table = $self->table or die 'count called on object of class '.ref($self);
3390 my $sql = "SELECT COUNT(*) FROM $table";
3391 $sql .= " WHERE $where" if $where;
3392 $self->scalar_sql($sql, @_);
3395 =item row_exists [ WHERE [, PLACEHOLDER ...] ]
3397 Convenience method for the common case of "SELECT 1 FROM table ... LIMIT 1"
3398 with optional (but almost always needed) WHERE.
3403 my($self, $where) = (shift, shift);
3404 my $table = $self->table or die 'row_exists called on object of class '.ref($self);
3405 my $sql = "SELECT 1 FROM $table";
3406 $sql .= " WHERE $where" if $where;
3408 $self->scalar_sql($sql, @_);
3417 =item real_fields [ TABLE ]
3419 Returns a list of the real columns in the specified table. Called only by
3420 fields() and other subroutines elsewhere in FS::Record.
3427 my($table_obj) = dbdef->table($table);
3428 confess "Unknown table $table" unless $table_obj;
3429 $table_obj->columns;
3432 =item pvf FIELD_NAME
3434 Returns the FS::part_virtual_field object corresponding to a field in the
3435 record (specified by FIELD_NAME).
3440 my ($self, $name) = (shift, shift);
3442 if(grep /^$name$/, $self->virtual_fields) {
3444 my $concat = [ "'cf_'", "name" ];
3445 return qsearchs({ table => 'part_virtual_field',
3446 hashref => { dbtable => $self->table,
3449 select => 'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
3455 =item _quote VALUE, TABLE, COLUMN
3457 This is an internal function used to construct SQL statements. It returns
3458 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3459 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3464 my($value, $table, $column) = @_;
3465 my $column_obj = dbdef->table($table)->column($column);
3466 my $column_type = $column_obj->type;
3467 my $nullable = $column_obj->null;
3469 utf8::upgrade($value);
3471 warn " $table.$column: $value ($column_type".
3472 ( $nullable ? ' NULL' : ' NOT NULL' ).
3473 ")\n" if $DEBUG > 2;
3475 if ( $value eq '' && $nullable ) {
3477 } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3478 cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3481 } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3482 ! $column_type =~ /(char|binary|text)$/i ) {
3484 } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3485 && driver_name eq 'Pg'
3490 eval { $value = dbh->quote($value, { pg_type => PG_BYTEA() }); };
3492 if ( $@ && $@ =~ /Wide character/i ) {
3493 warn 'Correcting malformed UTF-8 string for binary quote()'
3495 utf8::decode($value);
3496 utf8::encode($value);
3497 $value = dbh->quote($value, { pg_type => PG_BYTEA() });
3508 This is deprecated. Don't use it.
3510 It returns a hash-type list with the fields of this record's table set true.
3515 carp "warning: hfields is deprecated";
3518 foreach (fields($table)) {
3527 "$_: ". $self->getfield($_). "|"
3528 } (fields($self->table)) );
3531 sub DESTROY { return; }
3535 # #use Carp qw(cluck);
3536 # #cluck "DESTROYING $self";
3537 # warn "DESTROYING $self";
3541 # return ! eval { join('',@_), kill 0; 1; };
3544 =item str2time_sql [ DRIVER_NAME ]
3546 Returns a function to convert to unix time based on database type, such as
3547 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql. See
3548 the str2time_sql_closing method to return a closing string rather than just
3549 using a closing parenthesis as previously suggested.
3551 You can pass an optional driver name such as "Pg", "mysql" or
3552 $dbh->{Driver}->{Name} to return a function for that database instead of
3553 the current database.
3558 my $driver = shift || driver_name;
3560 return 'UNIX_TIMESTAMP(' if $driver =~ /^mysql/i;
3561 return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3563 warn "warning: unknown database type $driver; guessing how to convert ".
3564 "dates to UNIX timestamps";
3565 return 'EXTRACT(EPOCH FROM ';
3569 =item str2time_sql_closing [ DRIVER_NAME ]
3571 Returns the closing suffix of a function to convert to unix time based on
3572 database type, such as ")::integer" for Pg or ")" for mysql.
3574 You can pass an optional driver name such as "Pg", "mysql" or
3575 $dbh->{Driver}->{Name} to return a function for that database instead of
3576 the current database.
3580 sub str2time_sql_closing {
3581 my $driver = shift || driver_name;
3583 return ' )::INTEGER ' if $driver =~ /^Pg/i;
3587 =item regexp_sql [ DRIVER_NAME ]
3589 Returns the operator to do a regular expression comparison based on database
3590 type, such as '~' for Pg or 'REGEXP' for mysql.
3592 You can pass an optional driver name such as "Pg", "mysql" or
3593 $dbh->{Driver}->{Name} to return a function for that database instead of
3594 the current database.
3599 my $driver = shift || driver_name;
3601 return '~' if $driver =~ /^Pg/i;
3602 return 'REGEXP' if $driver =~ /^mysql/i;
3604 die "don't know how to use regular expressions in ". driver_name." databases";
3608 =item not_regexp_sql [ DRIVER_NAME ]
3610 Returns the operator to do a regular expression negation based on database
3611 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3613 You can pass an optional driver name such as "Pg", "mysql" or
3614 $dbh->{Driver}->{Name} to return a function for that database instead of
3615 the current database.
3619 sub not_regexp_sql {
3620 my $driver = shift || driver_name;
3622 return '!~' if $driver =~ /^Pg/i;
3623 return 'NOT REGEXP' if $driver =~ /^mysql/i;
3625 die "don't know how to use regular expressions in ". driver_name." databases";
3629 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3631 Returns the items concatenated based on database type, using "CONCAT()" for
3632 mysql and " || " for Pg and other databases.
3634 You can pass an optional driver name such as "Pg", "mysql" or
3635 $dbh->{Driver}->{Name} to return a function for that database instead of
3636 the current database.
3641 my $driver = ref($_[0]) ? driver_name : shift;
3644 if ( $driver =~ /^mysql/i ) {
3645 'CONCAT('. join(',', @$items). ')';
3647 join('||', @$items);
3652 =item group_concat_sql COLUMN, DELIMITER
3654 Returns an SQL expression to concatenate an aggregate column, using
3655 GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg.
3659 sub group_concat_sql {
3660 my ($col, $delim) = @_;
3661 $delim = dbh->quote($delim);
3662 if ( driver_name() =~ /^mysql/i ) {
3663 # DISTINCT(foo) is valid as $col
3664 return "GROUP_CONCAT($col SEPARATOR $delim)";
3666 return "array_to_string(array_agg($col), $delim)";
3670 =item midnight_sql DATE
3672 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3673 on that day in the system timezone, using the default driver name.
3678 my $driver = driver_name;
3680 if ( $driver =~ /^mysql/i ) {
3681 "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3684 "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3692 This module should probably be renamed, since much of the functionality is
3693 of general use. It is not completely unlike Adapter::DBI (see below).
3695 Exported qsearch and qsearchs should be deprecated in favor of method calls
3696 (against an FS::Record object like the old search and searchs that qsearch
3697 and qsearchs were on top of.)
3699 The whole fields / hfields mess should be removed.
3701 The various WHERE clauses should be subroutined.
3703 table string should be deprecated in favor of DBIx::DBSchema::Table.
3705 No doubt we could benefit from a Tied hash. Documenting how exists / defined
3706 true maps to the database (and WHERE clauses) would also help.
3708 The ut_ methods should ask the dbdef for a default length.
3710 ut_sqltype (like ut_varchar) should all be defined
3712 A fallback check method should be provided which uses the dbdef.
3714 The ut_money method assumes money has two decimal digits.
3716 The Pg money kludge in the new method only strips `$'.
3718 The ut_phonen method only checks US-style phone numbers.
3720 The _quote function should probably use ut_float instead of a regex.
3722 All the subroutines probably should be methods, here or elsewhere.
3724 Probably should borrow/use some dbdef methods where appropriate (like sub
3727 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3728 or allow it to be set. Working around it is ugly any way around - DBI should
3729 be fixed. (only affects RDBMS which return uppercase column names)
3731 ut_zip should take an optional country like ut_phone.
3735 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3737 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.