2 use base qw( Exporter );
7 %virtual_fields_cache %fk_method_cache $fk_table_cache
8 %virtual_fields_hash_cache $money_char $lat_lower $lon_upper
11 use Carp qw(carp cluck croak confess);
12 use Scalar::Util qw( blessed );
13 use File::Slurp qw( slurp );
14 use File::CounterFile;
16 use DBI qw(:sql_types);
17 use DBIx::DBSchema 0.43; #0.43 for foreign keys
20 use NetAddr::IP; # for validation
21 use Crypt::OpenSSL::RSA;
22 use FS::UID qw(dbh datasrc driver_name);
24 use FS::Schema qw(dbdef);
26 use FS::Msgcat qw(gettext);
27 #use FS::Conf; #dependency loop bs, in install_callback below instead
30 use FS::part_virtual_field;
34 our @encrypt_payby = qw( CARD DCRD CHEK DCHK );
36 #export dbdef for now... everything else expects to find it here
38 dbh fields hfields qsearch qsearchs dbdef jsearch
39 str2time_sql str2time_sql_closing regexp_sql not_regexp_sql
40 concat_sql group_concat_sql
41 midnight_sql fk_methods_init
45 our $me = '[FS::Record]';
47 $use_placeholders = 0;
49 our $nowarn_identical = 0;
50 our $nowarn_classload = 0;
51 our $no_update_diff = 0;
54 our $qsearch_qualify_columns = 1;
56 our $no_check_foreign = 1; #well, not inefficiently in perl by default anymore
62 our $conf_encryption = '';
63 our $conf_encryptionmodule = '';
64 our $conf_encryptionpublickey = '';
65 our $conf_encryptionprivatekey = '';
66 FS::UID->install_callback( sub {
70 $conf = FS::Conf->new;
71 $conf_encryption = $conf->exists('encryption');
72 $conf_encryptionmodule = $conf->config('encryptionmodule');
73 $conf_encryptionpublickey = join("\n",$conf->config('encryptionpublickey'));
74 $conf_encryptionprivatekey = join("\n",$conf->config('encryptionprivatekey'));
75 $money_char = $conf->config('money_char') || '$';
76 my $nw_coords = $conf->exists('geocode-require_nw_coordinates');
77 $lat_lower = $nw_coords ? 1 : -90;
78 $lon_upper = $nw_coords ? -1 : 180;
80 $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
82 if ( driver_name eq 'Pg' ) {
83 eval "use DBD::Pg ':pg_types'";
86 eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }";
95 FS::Record - Database record objects
100 use FS::Record qw(dbh fields qsearch qsearchs);
102 $record = new FS::Record 'table', \%hash;
103 $record = new FS::Record 'table', { 'column' => 'value', ... };
105 $record = qsearchs FS::Record 'table', \%hash;
106 $record = qsearchs FS::Record 'table', { 'column' => 'value', ... };
107 @records = qsearch FS::Record 'table', \%hash;
108 @records = qsearch FS::Record 'table', { 'column' => 'value', ... };
110 $table = $record->table;
111 $dbdef_table = $record->dbdef_table;
113 $value = $record->get('column');
114 $value = $record->getfield('column');
115 $value = $record->column;
117 $record->set( 'column' => 'value' );
118 $record->setfield( 'column' => 'value' );
119 $record->column('value');
121 %hash = $record->hash;
123 $hashref = $record->hashref;
125 $error = $record->insert;
127 $error = $record->delete;
129 $error = $new_record->replace($old_record);
131 # external use deprecated - handled by the database (at least for Pg, mysql)
132 $value = $record->unique('column');
134 $error = $record->ut_float('column');
135 $error = $record->ut_floatn('column');
136 $error = $record->ut_number('column');
137 $error = $record->ut_numbern('column');
138 $error = $record->ut_decimal('column');
139 $error = $record->ut_decimaln('column');
140 $error = $record->ut_snumber('column');
141 $error = $record->ut_snumbern('column');
142 $error = $record->ut_money('column');
143 $error = $record->ut_text('column');
144 $error = $record->ut_textn('column');
145 $error = $record->ut_alpha('column');
146 $error = $record->ut_alphan('column');
147 $error = $record->ut_phonen('column');
148 $error = $record->ut_anything('column');
149 $error = $record->ut_name('column');
151 $quoted_value = _quote($value,'table','field');
154 $fields = hfields('table');
155 if ( $fields->{Field} ) { # etc.
157 @fields = fields 'table'; #as a subroutine
158 @fields = $record->fields; #as a method call
163 (Mostly) object-oriented interface to database records. Records are currently
164 implemented on top of DBI. FS::Record is intended as a base class for
165 table-specific classes to inherit from, i.e. FS::cust_main.
171 =item new [ TABLE, ] HASHREF
173 Creates a new record. It doesn't store it in the database, though. See
174 L<"insert"> for that.
176 Note that the object stores this hash reference, not a distinct copy of the
177 hash it points to. You can ask the object for a copy with the I<hash>
180 TABLE can only be omitted when a dervived class overrides the table method.
186 my $class = ref($proto) || $proto;
188 bless ($self, $class);
190 unless ( defined ( $self->table ) ) {
191 $self->{'Table'} = shift;
192 carp "warning: FS::Record::new called with table name ". $self->{'Table'}
193 unless $nowarn_classload;
196 $self->{'Hash'} = shift;
198 foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
199 $self->{'Hash'}{$field}='';
202 $self->_rebless if $self->can('_rebless');
204 $self->{'modified'} = 0;
206 $self->_simplecache($self->{'Hash'}) if $self->can('_simplecache');
207 $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
214 my $class = ref($proto) || $proto;
216 bless ($self, $class);
218 $self->{'Table'} = shift unless defined ( $self->table );
220 my $hashref = $self->{'Hash'} = shift;
222 if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
223 my $obj = $cache->cache->{$hashref->{$cache->key}};
224 $obj->_cache($hashref, $cache) if $obj->can('_cache');
227 $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
234 my $class = ref($proto) || $proto;
236 bless ($self, $class);
237 if ( defined $self->table ) {
238 cluck "create constructor is deprecated, use new!";
241 croak "FS::Record::create called (not from a subclass)!";
245 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
247 Searches the database for all records matching (at least) the key/value pairs
248 in HASHREF. Returns all the records found as `FS::TABLE' objects if that
249 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
252 The preferred usage is to pass a hash reference of named parameters:
254 @records = qsearch( {
255 'table' => 'table_name',
256 'hashref' => { 'field' => 'value'
257 'field' => { 'op' => '<',
262 #these are optional...
264 'extra_sql' => 'AND field = ? AND intfield = ?',
265 'extra_param' => [ 'value', [ 5, 'int' ] ],
266 'order_by' => 'ORDER BY something',
267 #'cache_obj' => '', #optional
268 'addl_from' => 'LEFT JOIN othtable USING ( field )',
273 Much code still uses old-style positional parameters, this is also probably
274 fine in the common case where there are only two parameters:
276 my @records = qsearch( 'table', { 'field' => 'value' } );
278 Also possible is an experimental LISTREF of PARAMS_HASHREFs for a UNION of
279 the individual PARAMS_HASHREF queries
281 ###oops, argh, FS::Record::new only lets us create database fields.
282 #Normal behaviour if SELECT is not specified is `*', as in
283 #C<SELECT * FROM table WHERE ...>. However, there is an experimental new
284 #feature where you can specify SELECT - remember, the objects returned,
285 #although blessed into the appropriate `FS::TABLE' package, will only have the
286 #fields you specify. This might have unwanted results if you then go calling
287 #regular FS::TABLE methods
290 C<$FS::Record::qsearch_qualify_columns> package global is enabled by default.
291 When enabled, the WHERE clause generated from the 'hashref' parameter has
292 the table name prepended to each column name. WHERE column = 'value' becomes
293 WHERE table.coumn = 'value'
297 my %TYPE = (); #for debugging
300 my($type, $value) = @_;
302 my $bind_type = { TYPE => SQL_VARCHAR };
304 if ( $type =~ /(big)?(int|serial)/i && $value =~ /^-?\d+(\.\d+)?$/ ) {
306 $bind_type = { TYPE => SQL_INTEGER };
308 } elsif ( $type =~ /^bytea$/i || $type =~ /(blob|varbinary)/i ) {
310 if ( driver_name eq 'Pg' ) {
312 $bind_type = { pg_type => PG_BYTEA };
314 # $bind_type = ? #SQL_VARCHAR could be fine?
317 #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT
318 #fixed by DBD::Pg 2.11.8
319 #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded
320 #(make a Tron test first)
321 } elsif ( _is_fs_float( $type, $value ) ) {
323 $bind_type = { TYPE => SQL_DECIMAL };
332 my($type, $value) = @_;
333 if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) ||
334 ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/)
342 my( @stable, @record, @cache );
343 my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
345 my %union_options = ();
346 if ( ref($_[0]) eq 'ARRAY' ) {
349 foreach my $href ( @$optlist ) {
350 push @stable, ( $href->{'table'} or die "table name is required" );
351 push @record, ( $href->{'hashref'} || {} );
352 push @select, ( $href->{'select'} || '*' );
353 push @extra_sql, ( $href->{'extra_sql'} || '' );
354 push @extra_param, ( $href->{'extra_param'} || [] );
355 push @order_by, ( $href->{'order_by'} || '' );
356 push @cache, ( $href->{'cache_obj'} || '' );
357 push @addl_from, ( $href->{'addl_from'} || '' );
358 push @debug, ( $href->{'debug'} || '' );
360 die "at least one hashref is required" unless scalar(@stable);
361 } elsif ( ref($_[0]) eq 'HASH' ) {
363 $stable[0] = $opt->{'table'} or die "table name is required";
364 $record[0] = $opt->{'hashref'} || {};
365 $select[0] = $opt->{'select'} || '*';
366 $extra_sql[0] = $opt->{'extra_sql'} || '';
367 $extra_param[0] = $opt->{'extra_param'} || [];
368 $order_by[0] = $opt->{'order_by'} || '';
369 $cache[0] = $opt->{'cache_obj'} || '';
370 $addl_from[0] = $opt->{'addl_from'} || '';
371 $debug[0] = $opt->{'debug'} || '';
382 my $cache = $cache[0];
388 foreach my $stable ( @stable ) {
390 carp '->qsearch on cust_main called' if $stable eq 'cust_main' && $DEBUG;
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";
418 $statement .= " $addl_from";
419 # detect aliasing of the main table
420 if ( $addl_from =~ /^\s*AS\s+(\w+)/i ) {
424 if ( @real_fields ) {
425 $statement .= ' WHERE '. join(' AND ',
426 get_real_fields($table, $record, \@real_fields, $alias_main));
429 $statement .= " $extra_sql" if defined($extra_sql);
430 $statement .= " $order_by" if defined($order_by);
432 push @statement, $statement;
434 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
437 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
440 my $value = $record->{$field};
441 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
442 $value = $value->{'value'} if ref($value);
443 my $type = dbdef->table($table)->column($field)->type;
445 my $bind_type = _bind_type($type, $value);
449 # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
451 # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
455 push @bind_type, $bind_type;
459 foreach my $param ( @$extra_param ) {
460 my $bind_type = { TYPE => SQL_VARCHAR };
463 $value = $param->[0];
464 my $type = $param->[1];
465 $bind_type = _bind_type($type, $value);
468 push @bind_type, $bind_type;
472 my $statement = join( ' ) UNION ( ', @statement );
473 $statement = "( $statement )" if scalar(@statement) > 1;
474 $statement .= " $union_options{order_by}" if $union_options{order_by};
476 my $sth = $dbh->prepare($statement)
477 or croak "$dbh->errstr doing $statement";
480 foreach my $value ( @value ) {
481 my $bind_type = shift @bind_type;
482 $sth->bind_param($bind++, $value, $bind_type );
485 # $sth->execute( map $record->{$_},
486 # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
487 # ) or croak "Error executing \"$statement\": ". $sth->errstr;
489 my $ok = $sth->execute;
491 my $error = "Error executing \"$statement\"";
492 $error .= ' (' . join(', ', map {"'$_'"} @value) . ')' if @value;
493 $error .= ': '. $sth->errstr;
498 # Determine how to format rows returned form a union query:
500 # * When all queries involved in the union are from the same table:
501 # Return an array of FS::$table_name objects
503 # * When union query is performed on multiple tables,
504 # Return an array of FS::Record objects
505 # ! Note: As far as I can tell, this functionality was broken, and
506 # ! actually results in a crash. Behavior is left intact
507 # ! as-is, in case the results are in use somewhere
509 # * Union query is performed on multiple table,
510 # and $union_options{classname_from_column} = 1
511 # Return an array of FS::$classname objects, where $classname is
512 # derived for each row from a static field inserted each returned
514 # e.g.: SELECT custnum,first,last,'cust_main' AS `__classname`'.
517 my $table = $stable[0];
519 $table = '' if grep { $_ ne $table } @stable;
520 $pkey = dbdef->table($table)->primary_key if $table;
523 tie %result, "Tie::IxHash";
524 my @stuff = @{ $sth->fetchall_arrayref( {} ) };
525 if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
526 %result = map { $_->{$pkey}, $_ } @stuff;
528 @result{@stuff} = @stuff;
533 #below was refactored out to _from_hashref, this should use it at some point
536 if ($union_options{classname_from_column}) {
539 # I'm not implementing the cache for this use case, at least not yet
542 for my $row (@stuff) {
543 my $table_class = $row->{__classname}
544 or die "`__classname` column must be set when ".
545 "using \$union_options{classname_from_column}";
546 push @return, new("FS::$table_class",$row);
550 elsif ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
551 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
552 #derivied class didn't override new method, so this optimization is safe
555 new_or_cached( "FS::$table", { %{$_} }, $cache )
559 new( "FS::$table", { %{$_} } )
563 #okay, its been tested
564 # warn "untested code (class FS::$table uses custom new method)";
566 eval 'FS::'. $table. '->new( { %{$_} } )';
570 # Check for encrypted fields and decrypt them.
571 ## only in the local copy, not the cached object
572 no warnings 'deprecated'; # XXX silence the warning for now
573 if ( $conf_encryption
574 && eval '@FS::'. $table . '::encrypted_fields' ) {
575 foreach my $record (@return) {
576 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
577 next if $field eq 'payinfo'
578 && ($record->isa('FS::payinfo_transaction_Mixin')
579 || $record->isa('FS::payinfo_Mixin') )
581 && !grep { $record->payby eq $_ } @encrypt_payby;
582 # Set it directly... This may cause a problem in the future...
583 $record->setfield($field, $record->decrypt($record->getfield($field)));
588 cluck "warning: FS::$table not loaded; returning FS::Record objects"
589 unless $nowarn_classload;
591 FS::Record->new( $table, { %{$_} } );
599 Construct the SQL statement and parameter-binding list for qsearch. Takes
600 the qsearch parameters.
602 Returns a hash containing:
603 'table': The primary table name (if there is one).
604 'statement': The SQL statement itself.
605 'bind_type': An arrayref of bind types.
606 'value': An arrayref of parameter values.
607 'cache': The cache object, if one was passed.
612 my( @stable, @record, @cache );
613 my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
616 my %union_options = ();
617 if ( ref($_[0]) eq 'ARRAY' ) {
620 foreach my $href ( @$optlist ) {
621 push @stable, ( $href->{'table'} or die "table name is required" );
622 push @record, ( $href->{'hashref'} || {} );
623 push @select, ( $href->{'select'} || '*' );
624 push @extra_sql, ( $href->{'extra_sql'} || '' );
625 push @extra_param, ( $href->{'extra_param'} || [] );
626 push @order_by, ( $href->{'order_by'} || '' );
627 push @cache, ( $href->{'cache_obj'} || '' );
628 push @addl_from, ( $href->{'addl_from'} || '' );
629 push @debug, ( $href->{'debug'} || '' );
631 die "at least one hashref is required" unless scalar(@stable);
632 } elsif ( ref($_[0]) eq 'HASH' ) {
634 $stable[0] = $opt->{'table'} or die "table name is required";
635 $record[0] = $opt->{'hashref'} || {};
636 $select[0] = $opt->{'select'} || '*';
637 $extra_sql[0] = $opt->{'extra_sql'} || '';
638 $extra_param[0] = $opt->{'extra_param'} || [];
639 $order_by[0] = $opt->{'order_by'} || '';
640 $cache[0] = $opt->{'cache_obj'} || '';
641 $addl_from[0] = $opt->{'addl_from'} || '';
642 $debug[0] = $opt->{'debug'} || '';
653 my $cache = $cache[0];
659 my $result_table = $stable[0];
660 foreach my $stable ( @stable ) {
661 #stop altering the caller's hashref
662 my $record = { %{ shift(@record) || {} } };#and be liberal in receipt
663 my $select = shift @select;
664 my $extra_sql = shift @extra_sql;
665 my $extra_param = shift @extra_param;
666 my $order_by = shift @order_by;
667 my $cache = shift @cache;
668 my $addl_from = shift @addl_from;
669 my $debug = shift @debug;
671 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
673 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
676 $result_table = '' if $result_table ne $stable;
678 my $table = $cache ? $cache->table : $stable;
679 my $dbdef_table = dbdef->table($table)
680 or die "No schema for table $table found - ".
681 "do you need to run freeside-upgrade?";
682 my $pkey = $dbdef_table->primary_key;
684 my @real_fields = grep exists($record->{$_}), real_fields($table);
686 my $statement .= "SELECT $select FROM $stable";
687 $statement .= " $addl_from" if $addl_from;
688 if ( @real_fields ) {
689 $statement .= ' WHERE '. join(' AND ',
690 get_real_fields($table, $record, \@real_fields));
693 $statement .= " $extra_sql" if defined($extra_sql);
694 $statement .= " $order_by" if defined($order_by);
696 push @statement, $statement;
698 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
702 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
705 my $value = $record->{$field};
706 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
707 $value = $value->{'value'} if ref($value);
708 my $type = dbdef->table($table)->column($field)->type;
710 my $bind_type = _bind_type($type, $value);
714 # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
716 # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
720 push @bind_type, $bind_type;
724 foreach my $param ( @$extra_param ) {
725 my $bind_type = { TYPE => SQL_VARCHAR };
728 $value = $param->[0];
729 my $type = $param->[1];
730 $bind_type = _bind_type($type, $value);
733 push @bind_type, $bind_type;
737 my $statement = join( ' ) UNION ( ', @statement );
738 $statement = "( $statement )" if scalar(@statement) > 1;
739 $statement .= " $union_options{order_by}" if $union_options{order_by};
742 statement => $statement,
743 bind_type => \@bind_type,
745 table => $result_table,
750 # qsearch should eventually use this
752 my ($table, $cache, @hashrefs) = @_;
754 # XXX get rid of these string evals at some point
755 # (when we have time to test it)
756 # my $class = "FS::$table" if $table;
757 # if ( $class and $class->isa('FS::Record') )
758 # if ( $class->can('new') eq \&new )
760 if ( $table && eval 'scalar(@FS::'. $table. '::ISA);' ) {
761 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
762 #derivied class didn't override new method, so this optimization is safe
765 new_or_cached( "FS::$table", { %{$_} }, $cache )
769 new( "FS::$table", { %{$_} } )
773 #okay, its been tested
774 # warn "untested code (class FS::$table uses custom new method)";
776 eval 'FS::'. $table. '->new( { %{$_} } )';
780 # Check for encrypted fields and decrypt them.
781 ## only in the local copy, not the cached object
782 if ( $conf_encryption
783 && eval '@FS::'. $table . '::encrypted_fields' ) {
784 foreach my $record (@return) {
785 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
786 next if $field eq 'payinfo'
787 && ($record->isa('FS::payinfo_transaction_Mixin')
788 || $record->isa('FS::payinfo_Mixin') )
790 && !grep { $record->payby eq $_ } @encrypt_payby;
791 # Set it directly... This may cause a problem in the future...
792 $record->setfield($field, $record->decrypt($record->getfield($field)));
797 cluck "warning: FS::$table not loaded; returning FS::Record objects"
798 unless $nowarn_classload;
800 FS::Record->new( $table, { %{$_} } );
806 sub get_real_fields {
809 my $real_fields = shift;
810 my $alias_main = shift; # defaults to undef
811 $alias_main ||= $table;
813 ## could be optimized more for readability
819 my $table_column = $qsearch_qualify_columns ? "$alias_main.$column" : $column;
820 my $type = dbdef->table($table)->column($column)->type;
821 my $value = $record->{$column};
822 $value = $value->{'value'} if ref($value);
824 if ( ref($record->{$column}) ) {
825 $op = $record->{$column}{'op'} if $record->{$column}{'op'};
826 #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
827 if ( uc($op) eq 'ILIKE' ) {
829 $record->{$column}{'value'} = lc($record->{$column}{'value'});
830 $table_column = "LOWER($table_column)";
832 $record->{$column} = $record->{$column}{'value'}
835 if ( ! defined( $record->{$column} ) || $record->{$column} eq '' ) {
837 if ( driver_name eq 'Pg' ) {
838 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
839 qq-( $table_column IS NULL )-;
841 qq-( $table_column IS NULL OR $table_column = '' )-;
844 qq-( $table_column IS NULL OR $table_column = "" )-;
846 } elsif ( $op eq '!=' ) {
847 if ( driver_name eq 'Pg' ) {
848 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
849 qq-( $table_column IS NOT NULL )-;
851 qq-( $table_column IS NOT NULL AND $table_column != '' )-;
854 qq-( $table_column IS NOT NULL AND $table_column != "" )-;
857 if ( driver_name eq 'Pg' ) {
858 qq-( $table_column $op '' )-;
860 qq-( $table_column $op "" )-;
863 } elsif ( $op eq '!=' ) {
864 qq-( $table_column IS NULL OR $table_column != ? )-;
865 #if this needs to be re-enabled, it needs to use a custom op like
866 #"APPROX=" or something (better name?, not '=', to avoid affecting other
868 #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
869 # ( "$table_column <= ?", "$table_column >= ?" );
871 "$table_column $op ?";
878 =item by_key PRIMARY_KEY_VALUE
880 This is a class method that returns the record with the given primary key
881 value. This method is only useful in FS::Record subclasses. For example:
883 my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
887 my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
892 my ($class, $pkey_value) = @_;
894 my $table = $class->table
895 or croak "No table for $class found";
897 my $dbdef_table = dbdef->table($table)
898 or die "No schema for table $table found - ".
899 "do you need to create it or run dbdef-create?";
900 my $pkey = $dbdef_table->primary_key
901 or die "No primary key for table $table";
903 return qsearchs($table, { $pkey => $pkey_value });
906 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
908 Experimental JOINed search method. Using this method, you can execute a
909 single SELECT spanning multiple tables, and cache the results for subsequent
910 method calls. Interface will almost definately change in an incompatible
918 my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
919 my $cache = FS::SearchCache->new( $ptable, $pkey );
922 grep { !$saw{$_->getfield($pkey)}++ }
923 qsearch($table, $record, $select, $extra_sql, $cache )
927 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
929 Same as qsearch, except that if more than one record matches, it B<carp>s but
930 returns the first. If this happens, you either made a logic error in asking
931 for a single item, or your data is corrupted.
935 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
937 my(@result) = qsearch(@_);
938 cluck "warning: Multiple records in scalar search ($table)"
939 #.join(' / ', map "$_=>".$_[1]->{$_}, keys %{ $_[1] } )
940 if scalar(@result) > 1;
941 #should warn more vehemently if the search was on a primary key?
942 scalar(@result) ? ($result[0]) : ();
953 Returns the table name.
958 # cluck "warning: FS::Record::table deprecated; supply one in subclass!";
965 Returns the DBIx::DBSchema::Table object for the table.
971 my($table)=$self->table;
972 dbdef->table($table);
977 Returns the primary key for the table.
983 my $pkey = $self->dbdef_table->primary_key;
986 =item get, getfield COLUMN
988 Returns the value of the column/field/key COLUMN.
993 my($self,$field) = @_;
994 # to avoid "Use of unitialized value" errors
995 if ( defined ( $self->{Hash}->{$field} ) ) {
996 $self->{Hash}->{$field};
1006 =item set, setfield COLUMN, VALUE
1008 Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE.
1013 my($self,$field,$value) = @_;
1014 $self->{'modified'} = 1;
1015 $self->{'Hash'}->{$field} = $value;
1024 Returns true if the column/field/key COLUMN exists.
1029 my($self,$field) = @_;
1030 exists($self->{Hash}->{$field});
1033 =item AUTOLOADED METHODS
1035 $record->column is a synonym for $record->get('column');
1037 $record->column('value') is a synonym for $record->set('column','value');
1039 $record->foreign_table_name calls qsearchs and returns a single
1040 FS::foreign_table record (for tables referenced by a column of this table) or
1041 qsearch and returns an array of FS::foreign_table records (for tables
1042 referenced by a column in the foreign table).
1048 my($self,$value)=@_;
1049 my($field)=$AUTOLOAD;
1052 confess "errant AUTOLOAD $field for $self (arg $value)"
1053 unless blessed($self) && $self->can('setfield');
1055 if ( my $fk_info = get_fk_method($self->table, $field) ) {
1057 my $method = $fk_info->{method} || 'qsearchs';
1058 my $table = $fk_info->{table} || $field;
1059 my $column = $fk_info->{column};
1060 my $foreign_column = $fk_info->{references} || $column;
1062 eval "use FS::$table";
1065 carp '->cust_main called' if $table eq 'cust_main' && $DEBUG;
1067 my $pkey_value = $self->$column();
1068 my %search = ( $foreign_column => $pkey_value );
1070 # FS::Record->$method() ? they're actually just subs :/
1071 if ( $method eq 'qsearchs' ) {
1072 return $pkey_value ? qsearchs( $table, \%search ) : '';
1073 } elsif ( $method eq 'qsearch' ) {
1074 return $pkey_value ? qsearch( $table, \%search ) : ();
1076 die "unknown method $method";
1081 if ( defined($value) ) {
1082 $self->setfield($field,$value);
1084 $self->getfield($field);
1088 # efficient (also, old, doesn't support FK stuff)
1090 # my $field = $AUTOLOAD;
1091 # $field =~ s/.*://;
1092 # if ( defined($_[1]) ) {
1093 # $_[0]->setfield($field, $_[1]);
1095 # $_[0]->getfield($field);
1099 # get_fk_method(TABLE, FIELD)
1100 # Internal subroutine for fetching the foreign key descriptor for TABLE.FIELD
1101 # if there is one. If not, returns undef.
1102 # This will initialize fk_method_cache if it hasn't happened yet. It is the
1103 # _only_ allowed way to access the contents of %fk_method_cache.
1105 # if we wanted to be even more efficient we'd create the fk methods in the
1106 # symbol table instead of relying on AUTOLOAD every time
1109 my ($table, $field) = @_;
1111 fk_methods_init() unless exists($fk_method_cache{$table});
1113 if ( exists($fk_method_cache{$table}) and
1114 exists($fk_method_cache{$table}{$field}) ) {
1115 return $fk_method_cache{$table}{$field};
1122 sub fk_methods_init {
1123 warn "[fk_methods_init]\n" if $DEBUG;
1124 foreach my $table ( dbdef->tables ) {
1125 $fk_method_cache{$table} = fk_methods($table);
1134 # foreign keys we reference in other tables
1135 foreach my $fk (dbdef->table($table)->foreign_keys) {
1138 if ( scalar( @{$fk->columns} ) == 1 ) {
1139 if ( ! defined($fk->references)
1140 || ! @{$fk->references}
1141 || $fk->columns->[0] eq $fk->references->[0]
1143 $method = $fk->table;
1145 #some sort of hint in the table.pm or schema for methods not named
1146 # after their foreign table (well, not a whole lot different than
1147 # just providing a small subroutine...)
1151 $hash{$method} = { #fk_info
1152 'method' => 'qsearchs',
1153 'column' => $fk->columns->[0],
1154 #'references' => $fk->references->[0],
1162 # foreign keys referenced in other tables to us
1163 # (alas. why we're cached. still, might this loop better be done once at
1164 # schema load time insetad of every time we AUTOLOAD a method on a new
1166 if (! defined $fk_table_cache) {
1167 foreach my $f_table ( dbdef->tables ) {
1168 foreach my $fk (dbdef->table($f_table)->foreign_keys) {
1169 push @{$fk_table_cache->{$fk->table}},[$f_table,$fk];
1173 foreach my $fks (@{$fk_table_cache->{$table}}) {
1174 my ($f_table,$fk) = @$fks;
1176 if ( scalar( @{$fk->columns} ) == 1 ) {
1177 if ( ! defined($fk->references)
1178 || ! @{$fk->references}
1179 || $fk->columns->[0] eq $fk->references->[0]
1183 #some sort of hint in the table.pm or schema for methods not named
1184 # after their foreign table (well, not a whole lot different than
1185 # just providing a small subroutine...)
1189 $hash{$method} = { #fk_info
1190 'method' => 'qsearch',
1191 'column' => $fk->columns->[0], #references||column
1192 #'references' => $fk->column->[0],
1204 Returns a list of the column/value pairs, usually for assigning to a new hash.
1206 To make a distinct duplicate of an FS::Record object, you can do:
1208 $new = new FS::Record ( $old->table, { $old->hash } );
1214 confess $self. ' -> hash: Hash attribute is undefined'
1215 unless defined($self->{'Hash'});
1216 %{ $self->{'Hash'} };
1221 Returns a reference to the column/value hash. This may be deprecated in the
1222 future; if there's a reason you can't just use the autoloaded or get/set
1236 +{ ( map { $_=>$self->$_ } $self->fields ),
1241 my( $class, %opt ) = @_;
1242 my $table = $class->table;
1243 my $self = $class->new( { map { $_ => $opt{$_} } fields($table) } );
1244 my $error = $self->insert;
1245 return +{ 'error' => $error } if $error;
1246 my $pkey = $self->pkey;
1247 return +{ 'error' => '',
1248 'primary_key' => $pkey,
1249 $pkey => $self->$pkey,
1255 Returns true if any of this object's values have been modified with set (or via
1256 an autoloaded method). Doesn't yet recognize when you retreive a hashref and
1263 $self->{'modified'};
1266 =item select_for_update
1268 Selects this record with the SQL "FOR UPDATE" command. This can be useful as
1273 sub select_for_update {
1275 my $primary_key = $self->primary_key;
1278 'table' => $self->table,
1279 'hashref' => { $primary_key => $self->$primary_key() },
1280 'extra_sql' => 'FOR UPDATE',
1286 Locks this table with a database-driver specific lock method. This is used
1287 as a mutex in order to do a duplicate search.
1289 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
1291 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
1293 Errors are fatal; no useful return value.
1295 Note: To use this method for new tables other than svc_acct and svc_phone,
1296 edit freeside-upgrade and add those tables to the duplicate_lock list.
1302 my $table = $self->table;
1304 warn "$me locking $table table\n" if $DEBUG;
1306 if ( driver_name =~ /^Pg/i ) {
1308 dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
1311 } elsif ( driver_name =~ /^mysql/i ) {
1313 dbh->do("SELECT * FROM duplicate_lock
1314 WHERE lockname = '$table'
1316 ) or die dbh->errstr;
1320 die "unknown database ". driver_name. "; don't know how to lock table";
1324 warn "$me acquired $table table lock\n" if $DEBUG;
1330 Inserts this record to the database. If there is an error, returns the error,
1331 otherwise returns false.
1339 warn "$self -> insert" if $DEBUG;
1341 my $error = $self->check;
1342 return $error if $error;
1344 #single-field non-null unique keys are given a value if empty
1345 #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
1346 foreach ( $self->dbdef_table->unique_singles) {
1347 next if $self->getfield($_);
1348 next if $self->dbdef_table->column($_)->null eq 'NULL';
1352 #and also the primary key, if the database isn't going to
1353 my $primary_key = $self->dbdef_table->primary_key;
1355 if ( $primary_key ) {
1356 my $col = $self->dbdef_table->column($primary_key);
1359 uc($col->type) =~ /^(BIG)?SERIAL\d?/
1360 || ( driver_name eq 'Pg'
1361 && defined($col->default)
1362 && $col->quoted_default =~ /^nextval\(/i
1364 || ( driver_name eq 'mysql'
1365 && defined($col->local)
1366 && $col->local =~ /AUTO_INCREMENT/i
1368 $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
1371 my $table = $self->table;
1373 # Encrypt before the database
1374 if ( scalar( eval '@FS::'. $table . '::encrypted_fields')
1377 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
1378 next if $field eq 'payinfo'
1379 && ($self->isa('FS::payinfo_transaction_Mixin')
1380 || $self->isa('FS::payinfo_Mixin') )
1382 && !grep { $self->payby eq $_ } @encrypt_payby;
1383 $saved->{$field} = $self->getfield($field);
1384 $self->setfield($field, $self->encrypt($self->getfield($field)));
1388 #false laziness w/delete
1390 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1394 my $statement = "INSERT INTO $table ";
1395 my @bind_values = ();
1397 if ( ! @real_fields ) {
1399 $statement .= 'DEFAULT VALUES';
1403 if ( $use_placeholders ) {
1405 @bind_values = map $self->getfield($_), @real_fields;
1409 join( ', ', @real_fields ).
1411 join( ', ', map '?', @real_fields ). # @bind_values ).
1417 my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
1421 join( ', ', @real_fields ).
1423 join( ', ', @values ).
1431 warn "[debug]$me $statement\n" if $DEBUG > 1;
1432 my $sth = dbh->prepare($statement) or return dbh->errstr;
1434 local $SIG{HUP} = 'IGNORE';
1435 local $SIG{INT} = 'IGNORE';
1436 local $SIG{QUIT} = 'IGNORE';
1437 local $SIG{TERM} = 'IGNORE';
1438 local $SIG{TSTP} = 'IGNORE';
1439 local $SIG{PIPE} = 'IGNORE';
1441 $sth->execute(@bind_values) or return $sth->errstr;
1443 # get inserted id from the database, if applicable & needed
1444 if ( $db_seq && ! $self->getfield($primary_key) ) {
1445 warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
1449 if ( driver_name eq 'Pg' ) {
1451 #my $oid = $sth->{'pg_oid_status'};
1452 #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
1454 my $default = $self->dbdef_table->column($primary_key)->quoted_default;
1455 unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
1456 dbh->rollback if $FS::UID::AutoCommit;
1457 return "can't parse $table.$primary_key default value".
1458 " for sequence name: $default";
1462 my $i_sql = "SELECT currval('$sequence')";
1463 my $i_sth = dbh->prepare($i_sql) or do {
1464 dbh->rollback if $FS::UID::AutoCommit;
1467 $i_sth->execute() or do { #$i_sth->execute($oid)
1468 dbh->rollback if $FS::UID::AutoCommit;
1469 return $i_sth->errstr;
1471 $insertid = $i_sth->fetchrow_arrayref->[0];
1473 } elsif ( driver_name eq 'mysql' ) {
1475 $insertid = dbh->{'mysql_insertid'};
1476 # work around mysql_insertid being null some of the time, ala RT :/
1477 unless ( $insertid ) {
1478 warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
1479 "using SELECT LAST_INSERT_ID();";
1480 my $i_sql = "SELECT LAST_INSERT_ID()";
1481 my $i_sth = dbh->prepare($i_sql) or do {
1482 dbh->rollback if $FS::UID::AutoCommit;
1485 $i_sth->execute or do {
1486 dbh->rollback if $FS::UID::AutoCommit;
1487 return $i_sth->errstr;
1489 $insertid = $i_sth->fetchrow_arrayref->[0];
1494 dbh->rollback if $FS::UID::AutoCommit;
1495 return "don't know how to retreive inserted ids from ". driver_name.
1496 ", try using counterfiles (maybe run dbdef-create?)";
1500 $self->setfield($primary_key, $insertid);
1505 if ( defined( dbdef->table('h_'. $table) ) && ! $no_history ) {
1506 my $h_statement = $self->_h_statement('insert');
1507 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1508 $h_sth = dbh->prepare($h_statement) or do {
1509 dbh->rollback if $FS::UID::AutoCommit;
1515 $h_sth->execute or return $h_sth->errstr if $h_sth;
1517 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1519 # Now that it has been saved, reset the encrypted fields so that $new
1520 # can still be used.
1521 foreach my $field (keys %{$saved}) {
1522 $self->setfield($field, $saved->{$field});
1530 Depriciated (use insert instead).
1535 cluck "warning: FS::Record::add deprecated!";
1536 insert @_; #call method in this scope
1541 Delete this record from the database. If there is an error, returns the error,
1542 otherwise returns false.
1549 my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1551 $self->getfield($_) eq ''
1552 #? "( $_ IS NULL OR $_ = \"\" )"
1553 ? ( driver_name eq 'Pg'
1555 : "( $_ IS NULL OR $_ = \"\" )"
1557 : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1558 } ( $self->dbdef_table->primary_key )
1559 ? ( $self->dbdef_table->primary_key)
1560 : real_fields($self->table)
1562 warn "[debug]$me $statement\n" if $DEBUG > 1;
1563 my $sth = dbh->prepare($statement) or return dbh->errstr;
1566 if ( defined dbdef->table('h_'. $self->table) ) {
1567 my $h_statement = $self->_h_statement('delete');
1568 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1569 $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1574 my $primary_key = $self->dbdef_table->primary_key;
1576 local $SIG{HUP} = 'IGNORE';
1577 local $SIG{INT} = 'IGNORE';
1578 local $SIG{QUIT} = 'IGNORE';
1579 local $SIG{TERM} = 'IGNORE';
1580 local $SIG{TSTP} = 'IGNORE';
1581 local $SIG{PIPE} = 'IGNORE';
1583 my $rc = $sth->execute or return $sth->errstr;
1584 #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1585 $h_sth->execute or return $h_sth->errstr if $h_sth;
1587 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1589 #no need to needlessly destoy the data either (causes problems actually)
1590 #undef $self; #no need to keep object!
1597 Depriciated (use delete instead).
1602 cluck "warning: FS::Record::del deprecated!";
1603 &delete(@_); #call method in this scope
1606 =item replace OLD_RECORD
1608 Replace the OLD_RECORD with this one in the database. If there is an error,
1609 returns the error, otherwise returns false.
1614 my ($new, $old) = (shift, shift);
1616 $old = $new->replace_old unless defined($old);
1618 warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1620 if ( $new->can('replace_check') ) {
1621 my $error = $new->replace_check($old);
1622 return $error if $error;
1625 return "Records not in same table!" unless $new->table eq $old->table;
1627 my $primary_key = $old->dbdef_table->primary_key;
1628 return "Can't change primary key $primary_key ".
1629 'from '. $old->getfield($primary_key).
1630 ' to ' . $new->getfield($primary_key)
1632 && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1634 my $error = $new->check;
1635 return $error if $error;
1637 # Encrypt for replace
1639 if ( scalar( eval '@FS::'. $new->table . '::encrypted_fields')
1642 foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1643 next if $field eq 'payinfo'
1644 && ($new->isa('FS::payinfo_transaction_Mixin')
1645 || $new->isa('FS::payinfo_Mixin') )
1647 && !grep { $new->payby eq $_ } @encrypt_payby;
1648 $saved->{$field} = $new->getfield($field);
1649 $new->setfield($field, $new->encrypt($new->getfield($field)));
1653 #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1654 my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1655 ? ($_, $new->getfield($_)) : () } $old->fields;
1657 unless (keys(%diff) || $no_update_diff ) {
1658 carp "[warning]$me ". ref($new)."->replace ".
1659 ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
1660 ": records identical"
1661 unless $nowarn_identical;
1665 my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1667 "$_ = ". _quote($new->getfield($_),$old->table,$_)
1668 } real_fields($old->table)
1673 if ( $old->getfield($_) eq '' ) {
1675 #false laziness w/qsearch
1676 if ( driver_name eq 'Pg' ) {
1677 my $type = $old->dbdef_table->column($_)->type;
1678 if ( $type =~ /(int|(big)?serial)/i ) {
1681 qq-( $_ IS NULL OR $_ = '' )-;
1684 qq-( $_ IS NULL OR $_ = "" )-;
1688 "$_ = ". _quote($old->getfield($_),$old->table,$_);
1691 } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1694 warn "[debug]$me $statement\n" if $DEBUG > 1;
1695 my $sth = dbh->prepare($statement) or return dbh->errstr;
1698 if ( defined dbdef->table('h_'. $old->table) ) {
1699 my $h_old_statement = $old->_h_statement('replace_old');
1700 warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1701 $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1707 if ( defined dbdef->table('h_'. $new->table) ) {
1708 my $h_new_statement = $new->_h_statement('replace_new');
1709 warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1710 $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1715 local $SIG{HUP} = 'IGNORE';
1716 local $SIG{INT} = 'IGNORE';
1717 local $SIG{QUIT} = 'IGNORE';
1718 local $SIG{TERM} = 'IGNORE';
1719 local $SIG{TSTP} = 'IGNORE';
1720 local $SIG{PIPE} = 'IGNORE';
1722 my $rc = $sth->execute or return $sth->errstr;
1723 #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1724 $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1725 $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1727 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1729 # Now that it has been saved, reset the encrypted fields so that $new
1730 # can still be used.
1731 foreach my $field (keys %{$saved}) {
1732 $new->setfield($field, $saved->{$field});
1740 my( $self ) = shift;
1741 warn "[$me] replace called with no arguments; autoloading old record\n"
1744 my $primary_key = $self->dbdef_table->primary_key;
1745 if ( $primary_key ) {
1746 $self->by_key( $self->$primary_key() ) #this is what's returned
1747 or croak "can't find ". $self->table. ".$primary_key ".
1748 $self->$primary_key();
1750 croak $self->table. " has no primary key; pass old record as argument";
1757 Depriciated (use replace instead).
1762 cluck "warning: FS::Record::rep deprecated!";
1763 replace @_; #call method in this scope
1768 Checks custom fields. Subclasses should still provide a check method to validate
1769 non-custom fields, etc., and call this method via $self->SUPER::check.
1775 foreach my $field ($self->virtual_fields) {
1776 my $error = $self->ut_textn($field);
1777 return $error if $error;
1782 =item virtual_fields [ TABLE ]
1784 Returns a list of virtual fields defined for the table. This should not
1785 be exported, and should only be called as an instance or class method.
1789 sub virtual_fields {
1792 $table = $self->table or confess "virtual_fields called on non-table";
1794 confess "Unknown table $table" unless dbdef->table($table);
1796 return () unless dbdef->table('part_virtual_field');
1798 unless ( $virtual_fields_cache{$table} ) {
1799 my $concat = [ "'cf_'", "name" ];
1800 my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' .
1801 "WHERE dbtable = '$table'";
1803 my $result = $dbh->selectcol_arrayref($query);
1804 confess "Error executing virtual fields query: $query: ". $dbh->errstr
1806 $virtual_fields_cache{$table} = $result;
1809 @{$virtual_fields_cache{$table}};
1813 =item virtual_fields_hash [ TABLE ]
1815 Returns a list of virtual field records as a hash defined for the table. This should not
1816 be exported, and should only be called as an instance or class method.
1820 sub virtual_fields_hash {
1823 $table = $self->table or confess "virtual_fields called on non-table";
1825 confess "Unknown table $table" unless dbdef->table($table);
1827 return () unless dbdef->table('part_virtual_field');
1829 unless ( $virtual_fields_hash_cache{$table} ) {
1830 $virtual_fields_hash_cache{$table} = [];
1831 my $concat = [ "'cf_'", "name" ];
1832 my $select = concat_sql($concat).' as name, label, length';
1833 my @vfields = qsearch({
1835 table => 'part_virtual_field',
1836 hashref => { 'dbtable' => $table, },
1839 foreach (@vfields) {
1840 push @{ $virtual_fields_hash_cache{$table} }, $_->{Hash};
1844 @{$virtual_fields_hash_cache{$table}};
1848 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1850 Processes a batch import as a queued JSRPC job
1852 JOB is an FS::queue entry.
1854 OPTIONS_HASHREF can have the following keys:
1860 Table name (required).
1864 Arrayref of field names for static fields. They will be given values from the
1865 PARAMS hashref and passed as a "params" hashref to batch_import.
1869 Formats hashref. Keys are field names, values are listrefs that define the
1872 Each listref value can be a column name or a code reference. Coderefs are run
1873 with the row object, data and a FS::Conf object as the three parameters.
1874 For example, this coderef does the same thing as using the "columnname" string:
1877 my( $record, $data, $conf ) = @_;
1878 $record->columnname( $data );
1881 Coderefs are run after all "column name" fields are assigned.
1885 Optional format hashref of types. Keys are field names, values are "csv",
1886 "xls" or "fixedlength". Overrides automatic determination of file type
1889 =item format_headers
1891 Optional format hashref of header lines. Keys are field names, values are 0
1892 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1895 =item format_sep_chars
1897 Optional format hashref of CSV sep_chars. Keys are field names, values are the
1898 CSV separation character.
1900 =item format_fixedlenth_formats
1902 Optional format hashref of fixed length format defintiions. Keys are field
1903 names, values Parse::FixedLength listrefs of field definitions.
1907 Set true to default to CSV file type if the filename does not contain a
1908 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1913 PARAMS is a hashref (or base64-encoded Storable hashref) containing the
1914 POSTed data. It must contain the field "uploaded files", generated by
1915 /elements/file-upload.html and containing the list of uploaded files.
1916 Currently only supports a single file named "file".
1921 sub process_batch_import {
1922 my($job, $opt, $param) = @_;
1924 my $table = $opt->{table};
1925 my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1926 my %formats = %{ $opt->{formats} };
1928 warn Dumper($param) if $DEBUG;
1930 my $files = $param->{'uploaded_files'}
1931 or die "No files provided.\n";
1933 my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1935 my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1936 my $file = $dir. $files{'file'};
1941 formats => \%formats,
1942 format_types => $opt->{format_types},
1943 format_headers => $opt->{format_headers},
1944 format_sep_chars => $opt->{format_sep_chars},
1945 format_fixedlength_formats => $opt->{format_fixedlength_formats},
1946 format_xml_formats => $opt->{format_xml_formats},
1947 format_asn_formats => $opt->{format_asn_formats},
1948 format_row_callbacks => $opt->{format_row_callbacks},
1949 format_hash_callbacks => $opt->{format_hash_callbacks},
1954 format => $param->{format},
1955 params => { map { $_ => $param->{$_} } @pass_params },
1957 default_csv => $opt->{default_csv},
1958 preinsert_callback => $opt->{preinsert_callback},
1959 postinsert_callback => $opt->{postinsert_callback},
1960 insert_args_callback => $opt->{insert_args_callback},
1963 if ( $opt->{'batch_namecol'} ) {
1964 $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1965 $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1968 my $error = FS::Record::batch_import( \%iopt );
1972 die "$error\n" if $error;
1975 =item batch_import PARAM_HASHREF
1977 Class method for batch imports. Available params:
1983 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1989 =item format_headers
1991 =item format_sep_chars
1993 =item format_fixedlength_formats
1995 =item format_row_callbacks
1997 =item format_hash_callbacks - After parsing, before object creation
1999 =item fields - Alternate way to specify import, specifying import fields directly as a listref
2001 =item preinsert_callback
2003 =item postinsert_callback
2009 FS::queue object, will be updated with progress
2015 csv, xls, fixedlength, xml
2027 warn "$me batch_import call with params: \n". Dumper($param)
2030 my $table = $param->{table};
2032 my $job = $param->{job};
2033 my $file = $param->{file};
2034 my $params = $param->{params} || {};
2036 my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
2037 my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
2039 my( $type, $header, $sep_char,
2040 $fixedlength_format, $xml_format, $asn_format,
2041 $parser_opt, $row_callback, $hash_callback, @fields );
2043 my $postinsert_callback = '';
2044 $postinsert_callback = $param->{'postinsert_callback'}
2045 if $param->{'postinsert_callback'};
2046 my $preinsert_callback = '';
2047 $preinsert_callback = $param->{'preinsert_callback'}
2048 if $param->{'preinsert_callback'};
2049 my $insert_args_callback = '';
2050 $insert_args_callback = $param->{'insert_args_callback'}
2051 if $param->{'insert_args_callback'};
2053 if ( $param->{'format'} ) {
2055 my $format = $param->{'format'};
2056 my $formats = $param->{formats};
2057 die "unknown format $format" unless exists $formats->{ $format };
2059 $type = $param->{'format_types'}
2060 ? $param->{'format_types'}{ $format }
2061 : $param->{type} || 'csv';
2064 $header = $param->{'format_headers'}
2065 ? $param->{'format_headers'}{ $param->{'format'} }
2068 $sep_char = $param->{'format_sep_chars'}
2069 ? $param->{'format_sep_chars'}{ $param->{'format'} }
2072 $fixedlength_format =
2073 $param->{'format_fixedlength_formats'}
2074 ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
2078 $param->{'format_parser_opts'}
2079 ? $param->{'format_parser_opts'}{ $param->{'format'} }
2083 $param->{'format_xml_formats'}
2084 ? $param->{'format_xml_formats'}{ $param->{'format'} }
2088 $param->{'format_asn_formats'}
2089 ? $param->{'format_asn_formats'}{ $param->{'format'} }
2093 $param->{'format_row_callbacks'}
2094 ? $param->{'format_row_callbacks'}{ $param->{'format'} }
2098 $param->{'format_hash_callbacks'}
2099 ? $param->{'format_hash_callbacks'}{ $param->{'format'} }
2102 @fields = @{ $formats->{ $format } };
2104 } elsif ( $param->{'fields'} ) {
2106 $type = ''; #infer from filename
2109 $fixedlength_format = '';
2111 $hash_callback = '';
2112 @fields = @{ $param->{'fields'} };
2115 die "neither format nor fields specified";
2118 #my $file = $param->{file};
2121 if ( $file =~ /\.(\w+)$/i ) {
2125 warn "can't parse file type from filename $file; defaulting to CSV";
2129 if $param->{'default_csv'} && $type ne 'xls';
2137 my $asn_header_buffer;
2138 if ( $type eq 'csv' || $type eq 'fixedlength' ) {
2140 if ( $type eq 'csv' ) {
2142 $parser_opt->{'binary'} = 1;
2143 $parser_opt->{'sep_char'} = $sep_char if $sep_char;
2144 $parser = Text::CSV_XS->new($parser_opt);
2146 } elsif ( $type eq 'fixedlength' ) {
2148 eval "use Parse::FixedLength;";
2150 $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
2153 die "Unknown file type $type\n";
2156 @buffer = split(/\r?\n/, slurp($file) );
2157 splice(@buffer, 0, ($header || 0) );
2158 $count = scalar(@buffer);
2160 } elsif ( $type eq 'xls' ) {
2162 eval "use Spreadsheet::ParseExcel;";
2165 eval "use DateTime::Format::Excel;";
2166 #for now, just let the error be thrown if it is used, since only CDR
2167 # formats bill_west and troop use it, not other excel-parsing things
2170 my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
2172 $parser = $excel->{Worksheet}[0]; #first sheet
2174 $count = $parser->{MaxRow} || $parser->{MinRow};
2177 $row = $header || 0;
2179 } elsif ( $type eq 'xml' ) {
2182 eval "use XML::Simple;";
2184 my $xmlrow = $xml_format->{'xmlrow'};
2185 $parser = $xml_format->{'xmlkeys'};
2186 die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
2187 my $data = XML::Simple::XMLin(
2189 'SuppressEmpty' => '', #sets empty values to ''
2193 $rows = $rows->{$_} foreach @$xmlrow;
2194 $rows = [ $rows ] if ref($rows) ne 'ARRAY';
2195 $count = @buffer = @$rows;
2197 } elsif ( $type eq 'asn.1' ) {
2199 eval "use Convert::ASN1";
2202 my $asn = Convert::ASN1->new;
2203 $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
2205 $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
2207 my $data = slurp($file);
2208 my $asn_output = $parser->decode( $data )
2209 or return "No ". $asn_format->{'macro'}. " found\n";
2211 $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
2213 my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
2214 $count = @buffer = @$rows;
2217 die "Unknown file type $type\n";
2222 local $SIG{HUP} = 'IGNORE';
2223 local $SIG{INT} = 'IGNORE';
2224 local $SIG{QUIT} = 'IGNORE';
2225 local $SIG{TERM} = 'IGNORE';
2226 local $SIG{TSTP} = 'IGNORE';
2227 local $SIG{PIPE} = 'IGNORE';
2229 my $oldAutoCommit = $FS::UID::AutoCommit;
2230 local $FS::UID::AutoCommit = 0;
2233 #my $params = $param->{params} || {};
2234 if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
2235 my $batch_col = $param->{'batch_keycol'};
2237 my $batch_class = 'FS::'. $param->{'batch_table'};
2238 my $batch = $batch_class->new({
2239 $param->{'batch_namecol'} => $param->{'batch_namevalue'}
2241 my $error = $batch->insert;
2243 $dbh->rollback if $oldAutoCommit;
2244 return "can't insert batch record: $error";
2246 #primary key via dbdef? (so the column names don't have to match)
2247 my $batch_value = $batch->get( $param->{'batch_keycol'} );
2249 $params->{ $batch_col } = $batch_value;
2252 #my $job = $param->{job};
2255 my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
2259 my %hash = %$params;
2260 if ( $type eq 'csv' ) {
2262 last unless scalar(@buffer);
2263 $line = shift(@buffer);
2265 next if $line =~ /^\s*$/; #skip empty lines
2267 $line = &{$row_callback}($line) if $row_callback;
2269 next if $line =~ /^\s*$/; #skip empty lines
2271 $parser->parse($line) or do {
2272 $dbh->rollback if $oldAutoCommit;
2273 return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
2275 @columns = $parser->fields();
2277 } elsif ( $type eq 'fixedlength' ) {
2279 last unless scalar(@buffer);
2280 $line = shift(@buffer);
2282 @columns = $parser->parse($line);
2284 } elsif ( $type eq 'xls' ) {
2286 last if $row > ($parser->{MaxRow} || $parser->{MinRow})
2287 || ! $parser->{Cells}[$row];
2289 my @row = @{ $parser->{Cells}[$row] };
2290 @columns = map $_->{Val}, @row;
2293 #warn $z++. ": $_\n" for @columns;
2295 } elsif ( $type eq 'xml' ) {
2297 # $parser = [ 'Column0Key', 'Column1Key' ... ]
2298 last unless scalar(@buffer);
2299 my $row = shift @buffer;
2300 @columns = @{ $row }{ @$parser };
2302 } elsif ( $type eq 'asn.1' ) {
2304 last unless scalar(@buffer);
2305 my $row = shift @buffer;
2306 &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2307 if $asn_format->{row_callback};
2308 foreach my $key ( keys %{ $asn_format->{map} } ) {
2309 $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2313 die "Unknown file type $type\n";
2318 foreach my $field ( @fields ) {
2320 my $value = shift @columns;
2322 if ( ref($field) eq 'CODE' ) {
2323 #&{$field}(\%hash, $value);
2324 push @later, $field, $value;
2326 #??? $hash{$field} = $value if length($value);
2327 $hash{$field} = $value if defined($value) && length($value);
2332 if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
2333 && length($1) == $custnum_length ) {
2334 $hash{custnum} = $2;
2337 %hash = &{$hash_callback}(%hash) if $hash_callback;
2339 #my $table = $param->{table};
2340 my $class = "FS::$table";
2342 my $record = $class->new( \%hash );
2345 while ( scalar(@later) ) {
2346 my $sub = shift @later;
2347 my $data = shift @later;
2349 &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2352 $dbh->rollback if $oldAutoCommit;
2353 return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2355 last if exists( $param->{skiprow} );
2357 next if exists( $param->{skiprow} );
2359 if ( $preinsert_callback ) {
2360 my $error = &{$preinsert_callback}($record, $param);
2362 $dbh->rollback if $oldAutoCommit;
2363 return "preinsert_callback error". ( $line ? " for $line" : '' ).
2366 next if exists $param->{skiprow} && $param->{skiprow};
2369 my @insert_args = ();
2370 if ( $insert_args_callback ) {
2371 @insert_args = &{$insert_args_callback}($record, $param);
2374 my $error = $record->insert(@insert_args);
2377 $dbh->rollback if $oldAutoCommit;
2378 return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2384 if ( $postinsert_callback ) {
2385 my $error = &{$postinsert_callback}($record, $param);
2387 $dbh->rollback if $oldAutoCommit;
2388 return "postinsert_callback error". ( $line ? " for $line" : '' ).
2393 if ( $job && time - $min_sec > $last ) { #progress bar
2394 $job->update_statustext( int(100 * $imported / $count) );
2400 unless ( $imported || $param->{empty_ok} ) {
2401 $dbh->rollback if $oldAutoCommit;
2402 return "Empty file!";
2405 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2412 my( $self, $action, $time ) = @_;
2416 my %nohistory = map { $_=>1 } $self->nohistory_fields;
2419 grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2420 real_fields($self->table);
2423 # If we're encrypting then don't store the payinfo in the history
2424 if ( $conf_encryption && $self->table ne 'banned_pay' ) {
2425 @fields = grep { $_ ne 'payinfo' } @fields;
2428 my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2430 "INSERT INTO h_". $self->table. " ( ".
2431 join(', ', qw(history_date history_usernum history_action), @fields ).
2434 $FS::CurrentUser::CurrentUser->usernum,
2435 dbh->quote($action),
2444 B<Warning>: External use is B<deprecated>.
2446 Replaces COLUMN in record with a unique number, using counters in the
2447 filesystem. Used by the B<insert> method on single-field unique columns
2448 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2449 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2451 Returns the new value.
2456 my($self,$field) = @_;
2457 my($table)=$self->table;
2459 croak "Unique called on field $field, but it is ",
2460 $self->getfield($field),
2462 if $self->getfield($field);
2464 #warn "table $table is tainted" if is_tainted($table);
2465 #warn "field $field is tainted" if is_tainted($field);
2467 my($counter) = new File::CounterFile "$table.$field",0;
2469 my $index = $counter->inc;
2470 $index = $counter->inc while qsearchs($table, { $field=>$index } );
2472 $index =~ /^(\d*)$/;
2475 $self->setfield($field,$index);
2479 =item ut_float COLUMN
2481 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be
2482 null. If there is an error, returns the error, otherwise returns false.
2487 my($self,$field)=@_ ;
2488 ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2489 $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2490 $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2491 $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2492 or return "Illegal or empty (float) $field: ". $self->getfield($field);
2493 $self->setfield($field,$1);
2496 =item ut_floatn COLUMN
2498 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
2499 null. If there is an error, returns the error, otherwise returns false.
2503 #false laziness w/ut_ipn
2505 my( $self, $field ) = @_;
2506 if ( $self->getfield($field) =~ /^()$/ ) {
2507 $self->setfield($field,'');
2510 $self->ut_float($field);
2514 =item ut_sfloat COLUMN
2516 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2517 May not be null. If there is an error, returns the error, otherwise returns
2523 my($self,$field)=@_ ;
2524 ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2525 $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2526 $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2527 $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2528 or return "Illegal or empty (float) $field: ". $self->getfield($field);
2529 $self->setfield($field,$1);
2532 =item ut_sfloatn COLUMN
2534 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
2535 null. If there is an error, returns the error, otherwise returns false.
2540 my( $self, $field ) = @_;
2541 if ( $self->getfield($field) =~ /^()$/ ) {
2542 $self->setfield($field,'');
2545 $self->ut_sfloat($field);
2549 =item ut_snumber COLUMN
2551 Check/untaint signed numeric data (whole numbers). If there is an error,
2552 returns the error, otherwise returns false.
2557 my($self, $field) = @_;
2558 $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2559 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2560 $self->setfield($field, "$1$2");
2564 =item ut_snumbern COLUMN
2566 Check/untaint signed numeric data (whole numbers). If there is an error,
2567 returns the error, otherwise returns false.
2572 my($self, $field) = @_;
2573 $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2574 or return "Illegal (numeric) $field: ". $self->getfield($field);
2576 return "Illegal (numeric) $field: ". $self->getfield($field)
2579 $self->setfield($field, "$1$2");
2583 =item ut_number COLUMN
2585 Check/untaint simple numeric data (whole numbers). May not be null. If there
2586 is an error, returns the error, otherwise returns false.
2591 my($self,$field)=@_;
2592 $self->getfield($field) =~ /^\s*(\d+)\s*$/
2593 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2594 $self->setfield($field,$1);
2598 =item ut_numbern COLUMN
2600 Check/untaint simple numeric data (whole numbers). May be null. If there is
2601 an error, returns the error, otherwise returns false.
2606 my($self,$field)=@_;
2607 $self->getfield($field) =~ /^\s*(\d*)\s*$/
2608 or return "Illegal (numeric) $field: ". $self->getfield($field);
2609 $self->setfield($field,$1);
2613 =item ut_decimal COLUMN[, DIGITS]
2615 Check/untaint decimal numbers (up to DIGITS decimal places. If there is an
2616 error, returns the error, otherwise returns false.
2618 =item ut_decimaln COLUMN[, DIGITS]
2620 Check/untaint decimal numbers. May be null. If there is an error, returns
2621 the error, otherwise returns false.
2626 my($self, $field, $digits) = @_;
2628 $self->getfield($field) =~ /^\s*(\d+(\.\d{0,$digits})?)\s*$/
2629 or return "Illegal or empty (decimal) $field: ".$self->getfield($field);
2630 $self->setfield($field, $1);
2635 my($self, $field, $digits) = @_;
2636 $self->getfield($field) =~ /^\s*(\d*(\.\d{0,$digits})?)\s*$/
2637 or return "Illegal (decimal) $field: ".$self->getfield($field);
2638 $self->setfield($field, $1);
2642 =item ut_money COLUMN
2644 Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
2645 is an error, returns the error, otherwise returns false.
2650 my($self,$field)=@_;
2652 if ( $self->getfield($field) eq '' ) {
2653 $self->setfield($field, 0);
2654 } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2655 #handle one decimal place without barfing out
2656 $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2657 } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2658 $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2660 return "Illegal (money) $field: ". $self->getfield($field);
2666 =item ut_moneyn COLUMN
2668 Check/untaint monetary numbers. May be negative. If there
2669 is an error, returns the error, otherwise returns false.
2674 my($self,$field)=@_;
2675 if ($self->getfield($field) eq '') {
2676 $self->setfield($field, '');
2679 $self->ut_money($field);
2682 =item ut_currencyn COLUMN
2684 Check/untaint currency indicators, such as USD or EUR. May be null. If there
2685 is an error, returns the error, otherwise returns false.
2690 my($self, $field) = @_;
2691 if ($self->getfield($field) eq '') { #can be null
2692 $self->setfield($field, '');
2695 $self->ut_currency($field);
2698 =item ut_currency COLUMN
2700 Check/untaint currency indicators, such as USD or EUR. May not be null. If
2701 there is an error, returns the error, otherwise returns false.
2706 my($self, $field) = @_;
2707 my $value = uc( $self->getfield($field) );
2708 if ( code2currency($value) ) {
2709 $self->setfield($value);
2711 return "Unknown currency $value";
2717 =item ut_text COLUMN
2719 Check/untaint text. Alphanumerics, spaces, and the following punctuation
2720 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < > ~
2721 May not be null. If there is an error, returns the error, otherwise returns
2727 my($self,$field)=@_;
2728 #warn "msgcat ". \&msgcat. "\n";
2729 #warn "notexist ". \¬exist. "\n";
2730 #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2731 # \p{Word} = alphanumerics, marks (diacritics), and connectors
2732 # see perldoc perluniprops
2733 $self->getfield($field)
2734 =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>\~$money_char]+)$/
2735 or return gettext('illegal_or_empty_text'). " $field: ".
2736 $self->getfield($field);
2737 $self->setfield($field,$1);
2741 =item ut_textn COLUMN
2743 Check/untaint text. Alphanumerics, spaces, and the following punctuation
2744 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2745 May be null. If there is an error, returns the error, otherwise returns false.
2750 my($self,$field)=@_;
2751 return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2752 $self->ut_text($field);
2755 =item ut_alpha COLUMN
2757 Check/untaint alphanumeric strings (no spaces). May not be null. If there is
2758 an error, returns the error, otherwise returns false.
2763 my($self,$field)=@_;
2764 $self->getfield($field) =~ /^(\w+)$/
2765 or return "Illegal or empty (alphanumeric) $field: ".
2766 $self->getfield($field);
2767 $self->setfield($field,$1);
2771 =item ut_alphan COLUMN
2773 Check/untaint alphanumeric strings (no spaces). May be null. If there is an
2774 error, returns the error, otherwise returns false.
2779 my($self,$field)=@_;
2780 $self->getfield($field) =~ /^(\w*)$/
2781 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2782 $self->setfield($field,$1);
2786 =item ut_alphasn COLUMN
2788 Check/untaint alphanumeric strings, spaces allowed. May be null. If there is
2789 an error, returns the error, otherwise returns false.
2794 my($self,$field)=@_;
2795 $self->getfield($field) =~ /^([\w ]*)$/
2796 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2797 $self->setfield($field,$1);
2802 =item ut_alpha_lower COLUMN
2804 Check/untaint lowercase alphanumeric strings (no spaces). May not be null. If
2805 there is an error, returns the error, otherwise returns false.
2809 sub ut_alpha_lower {
2810 my($self,$field)=@_;
2811 $self->getfield($field) =~ /[[:upper:]]/
2812 and return "Uppercase characters are not permitted in $field";
2813 $self->ut_alpha($field);
2816 =item ut_phonen COLUMN [ COUNTRY ]
2818 Check/untaint phone numbers. May be null. If there is an error, returns
2819 the error, otherwise returns false.
2821 Takes an optional two-letter ISO 3166-1 alpha-2 country code; without
2822 it or with unsupported countries, ut_phonen simply calls ut_alphan.
2827 my( $self, $field, $country ) = @_;
2828 return $self->ut_alphan($field) unless defined $country;
2829 my $phonen = $self->getfield($field);
2830 if ( $phonen eq '' ) {
2831 $self->setfield($field,'');
2832 } elsif ( $country eq 'US' || $country eq 'CA' ) {
2834 $phonen = $conf->config('cust_main-default_areacode').$phonen
2835 if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2836 $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2837 or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2838 $phonen = "$1-$2-$3";
2839 $phonen .= " x$4" if $4;
2840 $self->setfield($field,$phonen);
2842 warn "warning: don't know how to check phone numbers for country $country";
2843 return $self->ut_textn($field);
2850 Check/untaint hexadecimal values.
2855 my($self, $field) = @_;
2856 $self->getfield($field) =~ /^([\da-fA-F]+)$/
2857 or return "Illegal (hex) $field: ". $self->getfield($field);
2858 $self->setfield($field, uc($1));
2862 =item ut_hexn COLUMN
2864 Check/untaint hexadecimal values. May be null.
2869 my($self, $field) = @_;
2870 $self->getfield($field) =~ /^([\da-fA-F]*)$/
2871 or return "Illegal (hex) $field: ". $self->getfield($field);
2872 $self->setfield($field, uc($1));
2876 =item ut_mac_addr COLUMN
2878 Check/untaint mac addresses. May be null.
2883 my($self, $field) = @_;
2885 my $mac = $self->get($field);
2888 $self->set($field, $mac);
2890 my $e = $self->ut_hex($field);
2893 return "Illegal (mac address) $field: ". $self->getfield($field)
2894 unless length($self->getfield($field)) == 12;
2900 =item ut_mac_addrn COLUMN
2902 Check/untaint mac addresses. May be null.
2907 my($self, $field) = @_;
2908 ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2913 Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
2919 my( $self, $field ) = @_;
2920 $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2921 return "Illegal (IP address) $field: ".$self->getfield($field)
2922 unless $self->getfield($field) =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/;
2923 $self->ut_ip46($field);
2928 Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
2929 to 127.0.0.1. May be null.
2934 my( $self, $field ) = @_;
2935 if ( $self->getfield($field) =~ /^()$/ ) {
2936 $self->setfield($field,'');
2939 $self->ut_ip($field);
2943 =item ut_ip46 COLUMN
2945 Check/untaint IPv4 or IPv6 address.
2950 my( $self, $field ) = @_;
2951 my $ip = NetAddr::IP->new(
2952 $self->_ut_ip_strip_leading_zeros( $self->getfield( $field ) )
2953 ) or return "Illegal (IP address) $field: ".$self->getfield($field);
2954 $self->setfield($field, lc($ip->addr));
2960 Check/untaint IPv6 or IPv6 address. May be null.
2965 my( $self, $field ) = @_;
2966 if ( $self->getfield($field) =~ /^$/ ) {
2967 $self->setfield($field, '');
2970 $self->ut_ip46($field);
2973 sub _ut_ip_strip_leading_zeros {
2974 # strip user-entered leading 0's from IP addresses
2975 # so parsers like NetAddr::IP don't mangle the address
2976 # e.g. NetAddr::IP converts 10.0.022.220 into 10.0.18.220
2978 my ( $self, $ip ) = @_;
2980 return join '.', map int, split /\./, $ip
2988 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2990 Check/untaint coordinates.
2991 Accepts the following forms:
3001 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
3002 The latter form (that is, the MMM are thousands of minutes) is
3003 assumed if the "MMM" is exactly three digits or two digits > 59.
3005 To be safe, just use the DDD.DDDDD form.
3007 If LOWER or UPPER are specified, then the coordinate is checked
3008 for lower and upper bounds, respectively.
3013 my ($self, $field) = (shift, shift);
3016 if ( $field =~ /latitude/ ) {
3017 $lower = $lat_lower;
3019 } elsif ( $field =~ /longitude/ ) {
3021 $upper = $lon_upper;
3024 my $coord = $self->getfield($field);
3025 my $neg = $coord =~ s/^(-)//;
3027 # ignore degree symbol at the end,
3028 # but not otherwise supporting degree/minutes/seconds symbols
3029 $coord =~ s/\N{DEGREE SIGN}\s*$//;
3031 my ($d, $m, $s) = (0, 0, 0);
3034 (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
3035 (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
3036 (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
3038 $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
3041 return "Invalid (coordinate with minutes > 59) $field: "
3042 . $self->getfield($field);
3045 $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
3047 if (defined($lower) and ($coord < $lower)) {
3048 return "Invalid (coordinate < $lower) $field: "
3049 . $self->getfield($field);;
3052 if (defined($upper) and ($coord > $upper)) {
3053 return "Invalid (coordinate > $upper) $field: "
3054 . $self->getfield($field);;
3057 $self->setfield($field, $coord);
3061 return "Invalid (coordinate) $field: " . $self->getfield($field);
3065 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
3067 Same as ut_coord, except optionally null.
3073 my ($self, $field) = (shift, shift);
3075 if ($self->getfield($field) =~ /^\s*$/) {
3078 return $self->ut_coord($field, @_);
3083 =item ut_domain COLUMN
3085 Check/untaint host and domain names. May not be null.
3090 my( $self, $field ) = @_;
3091 #$self->getfield($field) =~/^(\w+\.)*\w+$/
3092 $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
3093 or return "Illegal (hostname) $field: ". $self->getfield($field);
3094 $self->setfield($field,$1);
3098 =item ut_domainn COLUMN
3100 Check/untaint host and domain names. May be null.
3105 my( $self, $field ) = @_;
3106 if ( $self->getfield($field) =~ /^()$/ ) {
3107 $self->setfield($field,'');
3110 $self->ut_domain($field);
3114 =item ut_name COLUMN
3116 Check/untaint proper names; allows alphanumerics, spaces and the following
3117 punctuation: , . - '
3124 my( $self, $field ) = @_;
3125 $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
3126 or return gettext('illegal_name'). " $field: ". $self->getfield($field);
3131 $self->setfield($field, $name);
3135 =item ut_namen COLUMN
3137 Check/untaint proper names; allows alphanumerics, spaces and the following
3138 punctuation: , . - '
3145 my( $self, $field ) = @_;
3146 return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
3147 $self->ut_name($field);
3152 Check/untaint zip codes.
3156 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
3159 my( $self, $field, $country ) = @_;
3161 if ( $country eq 'US' ) {
3163 $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
3164 or return gettext('illegal_zip'). " $field for country $country: ".
3165 $self->getfield($field);
3166 $self->setfield($field, $1);
3168 } elsif ( $country eq 'CA' ) {
3170 $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
3171 or return gettext('illegal_zip'). " $field for country $country: ".
3172 $self->getfield($field);
3173 $self->setfield($field, "$1 $2");
3175 } elsif ( $country eq 'AU' ) {
3177 $self->getfield($field) =~ /^\s*(\d{4})\s*$/
3178 or return gettext('illegal_zip'). " $field for country $country: ".
3179 $self->getfield($field);
3180 $self->setfield($field, $1);
3184 if ( $self->getfield($field) =~ /^\s*$/
3185 && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
3188 $self->setfield($field,'');
3190 $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
3191 or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
3192 $self->setfield($field,$1);
3200 =item ut_country COLUMN
3202 Check/untaint country codes. Country names are changed to codes, if possible -
3203 see L<Locale::Country>.
3208 my( $self, $field ) = @_;
3209 unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
3210 if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
3211 && country2code($1) ) {
3212 $self->setfield($field,uc(country2code($1)));
3215 $self->getfield($field) =~ /^(\w\w)$/
3216 or return "Illegal (country) $field: ". $self->getfield($field);
3217 $self->setfield($field,uc($1));
3221 =item ut_anything COLUMN
3223 Untaints arbitrary data. Be careful.
3228 my( $self, $field ) = @_;
3229 $self->getfield($field) =~ /^(.*)$/s
3230 or return "Illegal $field: ". $self->getfield($field);
3231 $self->setfield($field,$1);
3235 =item ut_enum COLUMN CHOICES_ARRAYREF
3237 Check/untaint a column, supplying all possible choices, like the "enum" type.
3242 my( $self, $field, $choices ) = @_;
3243 foreach my $choice ( @$choices ) {
3244 if ( $self->getfield($field) eq $choice ) {
3245 $self->setfield($field, $choice);
3249 return "Illegal (enum) field $field: ". $self->getfield($field);
3252 =item ut_enumn COLUMN CHOICES_ARRAYREF
3254 Like ut_enum, except the null value is also allowed.
3259 my( $self, $field, $choices ) = @_;
3260 $self->getfield($field)
3261 ? $self->ut_enum($field, $choices)
3265 =item ut_date COLUMN
3267 Check/untaint a column containing a date string.
3269 Date will be normalized to YYYY-MM-DD format
3274 my ( $self, $field ) = @_;
3275 my $value = $self->getfield( $field );
3277 my @date = split /[\-\/]/, $value;
3278 if ( scalar(@date) == 3 ) {
3279 @date = @date[2,0,1] if $date[2] >= 1900;
3284 # DateTime will die given invalid date
3285 $ymd = DateTime->new(
3293 $self->setfield( $field, $ymd ) unless $value eq $ymd;
3298 return "Illegal (date) field $field: $value";
3301 =item ut_daten COLUMN
3303 Check/untaint a column containing a date string.
3307 Date will be normalized to YYYY-MM-DD format
3312 my ( $self, $field ) = @_;
3314 $self->getfield( $field ) =~ /^()$/
3315 ? $self->setfield( $field, '' )
3316 : $self->ut_date( $field );
3319 =item ut_flag COLUMN
3321 Check/untaint a column if it contains either an empty string or 'Y'. This
3322 is the standard form for boolean flags in Freeside.
3327 my( $self, $field ) = @_;
3328 my $value = uc($self->getfield($field));
3329 if ( $value eq '' or $value eq 'Y' ) {
3330 $self->setfield($field, $value);
3333 return "Illegal (flag) field $field: $value";
3336 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3338 Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
3339 on the column first.
3343 sub ut_foreign_key {
3344 my( $self, $field, $table, $foreign ) = @_;
3345 return $self->ut_number($field) if $no_check_foreign;
3346 qsearchs($table, { $foreign => $self->getfield($field) })
3347 or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
3348 " in $table.$foreign";
3352 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3354 Like ut_foreign_key, except the null value is also allowed.
3358 sub ut_foreign_keyn {
3359 my( $self, $field, $table, $foreign ) = @_;
3360 $self->getfield($field)
3361 ? $self->ut_foreign_key($field, $table, $foreign)
3365 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
3367 Checks this column as an agentnum, taking into account the current users's
3368 ACLs. NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
3369 right or rights allowing no agentnum.
3373 sub ut_agentnum_acl {
3374 my( $self, $field ) = (shift, shift);
3375 my $null_acl = scalar(@_) ? shift : [];
3376 $null_acl = [ $null_acl ] unless ref($null_acl);
3378 my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
3379 return "Illegal agentnum: $error" if $error;
3381 my $curuser = $FS::CurrentUser::CurrentUser;
3383 if ( $self->$field() ) {
3385 return 'Access denied to agent '. $self->$field()
3386 unless $curuser->agentnum($self->$field());
3390 return 'Access denied to global'
3391 unless grep $curuser->access_right($_), @$null_acl;
3400 =item ut_email COLUMN
3402 Check column contains a valid E-Mail address
3407 my ( $self, $field ) = @_;
3408 Email::Valid->address( $self->getfield( $field ) )
3410 : "Illegal (email) field $field: ". $self->getfield( $field );
3413 =item ut_emailn COLUMN
3415 Check column contains a valid E-Mail address
3422 my ( $self, $field ) = @_;
3424 $self->getfield( $field ) =~ /^$/
3425 ? $self->getfield( $field, '' )
3426 : $self->ut_email( $field );
3429 =item trim_whitespace FIELD[, FIELD ... ]
3431 Strip leading and trailing spaces from the value in the named FIELD(s).
3435 sub trim_whitespace {
3437 foreach my $field (@_) {
3438 my $value = $self->get($field);
3441 $self->set($field, $value);
3445 =item fields [ TABLE ]
3447 This is a wrapper for real_fields. Code that called
3448 fields before should probably continue to call fields.
3453 my $something = shift;
3455 if($something->isa('FS::Record')) {
3456 $table = $something->table;
3458 $table = $something;
3459 #$something = "FS::$table";
3461 return (real_fields($table));
3465 =item encrypt($value)
3467 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
3469 Returns the encrypted string.
3471 You should generally not have to worry about calling this, as the system handles this for you.
3476 my ($self, $value) = @_;
3477 my $encrypted = $value;
3479 if ($conf_encryption) {
3480 if ($self->is_encrypted($value)) {
3481 # Return the original value if it isn't plaintext.
3482 $encrypted = $value;
3485 if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
3486 # RSA doesn't like the empty string so let's pack it up
3487 # The database doesn't like the RSA data so uuencode it
3488 my $length = length($value)+1;
3489 $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
3491 die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
3498 =item is_encrypted($value)
3500 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
3506 my ($self, $value) = @_;
3507 # could be more precise about it, but this will do for now
3508 $value =~ /^M/ && length($value) > 80;
3511 =item decrypt($value)
3513 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
3515 You should generally not have to worry about calling this, as the system handles this for you.
3520 my ($self,$value) = @_;
3521 my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
3522 if ($conf_encryption && $self->is_encrypted($value)) {
3524 if (ref($rsa_decrypt) =~ /::RSA/) {
3525 my $encrypted = unpack ("u*", $value);
3526 $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
3527 if ($@) {warn "Decryption Failed"};
3536 my $rsa_module = $conf_encryptionmodule || 'Crypt::OpenSSL::RSA';
3538 # Initialize Encryption
3539 if ($conf_encryptionpublickey && $conf_encryptionpublickey ne '') {
3540 $rsa_encrypt = $rsa_module->new_public_key($conf_encryptionpublickey);
3543 # Intitalize Decryption
3544 if ($conf_encryptionprivatekey && $conf_encryptionprivatekey ne '') {
3545 $rsa_decrypt = $rsa_module->new_private_key($conf_encryptionprivatekey);
3549 =item h_search ACTION
3551 Given an ACTION, either "insert", or "delete", returns the appropriate history
3552 record corresponding to this record, if any.
3557 my( $self, $action ) = @_;
3559 my $table = $self->table;
3562 my $primary_key = dbdef->table($table)->primary_key;
3565 'table' => "h_$table",
3566 'hashref' => { $primary_key => $self->$primary_key(),
3567 'history_action' => $action,
3575 Given an ACTION, either "insert", or "delete", returns the timestamp of the
3576 appropriate history record corresponding to this record, if any.
3581 my($self, $action) = @_;
3582 my $h = $self->h_search($action);
3583 $h ? $h->history_date : '';
3586 =item scalar_sql SQL [ PLACEHOLDER, ... ]
3588 A class or object method. Executes the sql statement represented by SQL and
3589 returns a scalar representing the result: the first column of the first row.
3591 Dies on bogus SQL. Returns an empty string if no row is returned.
3593 Typically used for statments which return a single value such as "SELECT
3594 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
3599 my($self, $sql) = (shift, shift);
3600 my $sth = dbh->prepare($sql) or die dbh->errstr;
3602 or die "Unexpected error executing statement $sql: ". $sth->errstr;
3603 my $row = $sth->fetchrow_arrayref or return '';
3604 my $scalar = $row->[0];
3605 defined($scalar) ? $scalar : '';
3608 =item count [ WHERE [, PLACEHOLDER ...] ]
3610 Convenience method for the common case of "SELECT COUNT(*) FROM table",
3611 with optional WHERE. Must be called as method on a class with an
3617 my($self, $where) = (shift, shift);
3618 my $table = $self->table or die 'count called on object of class '.ref($self);
3619 my $sql = "SELECT COUNT(*) FROM $table";
3620 $sql .= " WHERE $where" if $where;
3621 $self->scalar_sql($sql, @_);
3624 =item row_exists [ WHERE [, PLACEHOLDER ...] ]
3626 Convenience method for the common case of "SELECT 1 FROM table ... LIMIT 1"
3627 with optional (but almost always needed) WHERE.
3632 my($self, $where) = (shift, shift);
3633 my $table = $self->table or die 'row_exists called on object of class '.ref($self);
3634 my $sql = "SELECT 1 FROM $table";
3635 $sql .= " WHERE $where" if $where;
3637 $self->scalar_sql($sql, @_);
3646 =item real_fields [ TABLE ]
3648 Returns a list of the real columns in the specified table. Called only by
3649 fields() and other subroutines elsewhere in FS::Record.
3656 my($table_obj) = dbdef->table($table);
3657 confess "Unknown table $table" unless $table_obj;
3658 $table_obj->columns;
3661 =item pvf FIELD_NAME
3663 Returns the FS::part_virtual_field object corresponding to a field in the
3664 record (specified by FIELD_NAME).
3669 my ($self, $name) = (shift, shift);
3671 if(grep /^$name$/, $self->virtual_fields) {
3673 my $concat = [ "'cf_'", "name" ];
3674 return qsearchs({ table => 'part_virtual_field',
3675 hashref => { dbtable => $self->table,
3678 select => 'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
3684 =item _quote VALUE, TABLE, COLUMN
3686 This is an internal function used to construct SQL statements. It returns
3687 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3688 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3693 my($value, $table, $column) = @_;
3694 my $column_obj = dbdef->table($table)->column($column);
3695 my $column_type = $column_obj->type;
3696 my $nullable = $column_obj->null;
3698 utf8::upgrade($value);
3700 warn " $table.$column: $value ($column_type".
3701 ( $nullable ? ' NULL' : ' NOT NULL' ).
3702 ")\n" if $DEBUG > 2;
3704 if ( $value eq '' && $nullable ) {
3706 } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3707 cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3710 } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3711 ! $column_type =~ /(char|binary|text)$/i ) {
3713 } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3714 && driver_name eq 'Pg'
3719 eval { $value = dbh->quote($value, { pg_type => PG_BYTEA() }); };
3721 if ( $@ && $@ =~ /Wide character/i ) {
3722 warn 'Correcting malformed UTF-8 string for binary quote()'
3724 utf8::decode($value);
3725 utf8::encode($value);
3726 $value = dbh->quote($value, { pg_type => PG_BYTEA() });
3737 This is deprecated. Don't use it.
3739 It returns a hash-type list with the fields of this record's table set true.
3744 carp "warning: hfields is deprecated";
3747 foreach (fields($table)) {
3756 "$_: ". $self->getfield($_). "|"
3757 } (fields($self->table)) );
3760 sub DESTROY { return; }
3764 # #use Carp qw(cluck);
3765 # #cluck "DESTROYING $self";
3766 # warn "DESTROYING $self";
3770 # return ! eval { join('',@_), kill 0; 1; };
3773 =item str2time_sql [ DRIVER_NAME ]
3775 Returns a function to convert to unix time based on database type, such as
3776 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql. See
3777 the str2time_sql_closing method to return a closing string rather than just
3778 using a closing parenthesis as previously suggested.
3780 You can pass an optional driver name such as "Pg", "mysql" or
3781 $dbh->{Driver}->{Name} to return a function for that database instead of
3782 the current database.
3787 my $driver = shift || driver_name;
3789 return 'UNIX_TIMESTAMP(' if $driver =~ /^mysql/i;
3790 return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3792 warn "warning: unknown database type $driver; guessing how to convert ".
3793 "dates to UNIX timestamps";
3794 return 'EXTRACT(EPOCH FROM ';
3798 =item str2time_sql_closing [ DRIVER_NAME ]
3800 Returns the closing suffix of a function to convert to unix time based on
3801 database type, such as ")::integer" for Pg or ")" for mysql.
3803 You can pass an optional driver name such as "Pg", "mysql" or
3804 $dbh->{Driver}->{Name} to return a function for that database instead of
3805 the current database.
3809 sub str2time_sql_closing {
3810 my $driver = shift || driver_name;
3812 return ' )::INTEGER ' if $driver =~ /^Pg/i;
3816 =item regexp_sql [ DRIVER_NAME ]
3818 Returns the operator to do a regular expression comparison based on database
3819 type, such as '~' for Pg or 'REGEXP' for mysql.
3821 You can pass an optional driver name such as "Pg", "mysql" or
3822 $dbh->{Driver}->{Name} to return a function for that database instead of
3823 the current database.
3828 my $driver = shift || driver_name;
3830 return '~' if $driver =~ /^Pg/i;
3831 return 'REGEXP' if $driver =~ /^mysql/i;
3833 die "don't know how to use regular expressions in ". driver_name." databases";
3837 =item not_regexp_sql [ DRIVER_NAME ]
3839 Returns the operator to do a regular expression negation based on database
3840 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3842 You can pass an optional driver name such as "Pg", "mysql" or
3843 $dbh->{Driver}->{Name} to return a function for that database instead of
3844 the current database.
3848 sub not_regexp_sql {
3849 my $driver = shift || driver_name;
3851 return '!~' if $driver =~ /^Pg/i;
3852 return 'NOT REGEXP' if $driver =~ /^mysql/i;
3854 die "don't know how to use regular expressions in ". driver_name." databases";
3858 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3860 Returns the items concatenated based on database type, using "CONCAT()" for
3861 mysql and " || " for Pg and other databases.
3863 You can pass an optional driver name such as "Pg", "mysql" or
3864 $dbh->{Driver}->{Name} to return a function for that database instead of
3865 the current database.
3870 my $driver = ref($_[0]) ? driver_name : shift;
3873 if ( $driver =~ /^mysql/i ) {
3874 'CONCAT('. join(',', @$items). ')';
3876 join('||', @$items);
3881 =item group_concat_sql COLUMN, DELIMITER
3883 Returns an SQL expression to concatenate an aggregate column, using
3884 GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg.
3888 sub group_concat_sql {
3889 my ($col, $delim) = @_;
3890 $delim = dbh->quote($delim);
3891 if ( driver_name() =~ /^mysql/i ) {
3892 # DISTINCT(foo) is valid as $col
3893 return "GROUP_CONCAT($col SEPARATOR $delim)";
3895 return "array_to_string(array_agg($col), $delim)";
3899 =item midnight_sql DATE
3901 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3902 on that day in the system timezone, using the default driver name.
3907 my $driver = driver_name;
3909 if ( $driver =~ /^mysql/i ) {
3910 "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3913 "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3921 This module should probably be renamed, since much of the functionality is
3922 of general use. It is not completely unlike Adapter::DBI (see below).
3924 Exported qsearch and qsearchs should be deprecated in favor of method calls
3925 (against an FS::Record object like the old search and searchs that qsearch
3926 and qsearchs were on top of.)
3928 The whole fields / hfields mess should be removed.
3930 The various WHERE clauses should be subroutined.
3932 table string should be deprecated in favor of DBIx::DBSchema::Table.
3934 No doubt we could benefit from a Tied hash. Documenting how exists / defined
3935 true maps to the database (and WHERE clauses) would also help.
3937 The ut_ methods should ask the dbdef for a default length.
3939 ut_sqltype (like ut_varchar) should all be defined
3941 A fallback check method should be provided which uses the dbdef.
3943 The ut_money method assumes money has two decimal digits.
3945 The Pg money kludge in the new method only strips `$'.
3947 The ut_phonen method only checks US-style phone numbers.
3949 The _quote function should probably use ut_float instead of a regex.
3951 All the subroutines probably should be methods, here or elsewhere.
3953 Probably should borrow/use some dbdef methods where appropriate (like sub
3956 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3957 or allow it to be set. Working around it is ugly any way around - DBI should
3958 be fixed. (only affects RDBMS which return uppercase column names)
3960 ut_zip should take an optional country like ut_phone.
3964 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3966 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.