2 use base qw( Exporter );
7 %virtual_fields_cache %fk_method_cache $fk_table_cache
8 $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
29 use FS::part_virtual_field;
33 our @encrypt_payby = qw( CARD DCRD CHEK DCHK );
35 #export dbdef for now... everything else expects to find it here
37 dbh fields hfields qsearch qsearchs dbdef jsearch
38 str2time_sql str2time_sql_closing regexp_sql not_regexp_sql
39 concat_sql group_concat_sql
40 midnight_sql fk_methods_init
44 our $me = '[FS::Record]';
46 $use_placeholders = 0;
48 our $nowarn_identical = 0;
49 our $nowarn_classload = 0;
50 our $no_update_diff = 0;
53 our $qsearch_qualify_columns = 1;
55 our $no_check_foreign = 1; #well, not inefficiently in perl by default anymore
61 our $conf_encryption = '';
62 our $conf_encryptionmodule = '';
63 our $conf_encryptionpublickey = '';
64 our $conf_encryptionprivatekey = '';
65 FS::UID->install_callback( sub {
69 $conf = FS::Conf->new;
70 $conf_encryption = $conf->exists('encryption');
71 $conf_encryptionmodule = $conf->config('encryptionmodule');
72 $conf_encryptionpublickey = join("\n",$conf->config('encryptionpublickey'));
73 $conf_encryptionprivatekey = join("\n",$conf->config('encryptionprivatekey'));
74 $money_char = $conf->config('money_char') || '$';
75 my $nw_coords = $conf->exists('geocode-require_nw_coordinates');
76 $lat_lower = $nw_coords ? 1 : -90;
77 $lon_upper = $nw_coords ? -1 : 180;
79 $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
81 if ( driver_name eq 'Pg' ) {
82 eval "use DBD::Pg ':pg_types'";
85 eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }";
94 FS::Record - Database record objects
99 use FS::Record qw(dbh fields qsearch qsearchs);
101 $record = new FS::Record 'table', \%hash;
102 $record = new FS::Record 'table', { 'column' => 'value', ... };
104 $record = qsearchs FS::Record 'table', \%hash;
105 $record = qsearchs FS::Record 'table', { 'column' => 'value', ... };
106 @records = qsearch FS::Record 'table', \%hash;
107 @records = qsearch FS::Record 'table', { 'column' => 'value', ... };
109 $table = $record->table;
110 $dbdef_table = $record->dbdef_table;
112 $value = $record->get('column');
113 $value = $record->getfield('column');
114 $value = $record->column;
116 $record->set( 'column' => 'value' );
117 $record->setfield( 'column' => 'value' );
118 $record->column('value');
120 %hash = $record->hash;
122 $hashref = $record->hashref;
124 $error = $record->insert;
126 $error = $record->delete;
128 $error = $new_record->replace($old_record);
130 # external use deprecated - handled by the database (at least for Pg, mysql)
131 $value = $record->unique('column');
133 $error = $record->ut_float('column');
134 $error = $record->ut_floatn('column');
135 $error = $record->ut_number('column');
136 $error = $record->ut_numbern('column');
137 $error = $record->ut_decimal('column');
138 $error = $record->ut_decimaln('column');
139 $error = $record->ut_snumber('column');
140 $error = $record->ut_snumbern('column');
141 $error = $record->ut_money('column');
142 $error = $record->ut_text('column');
143 $error = $record->ut_textn('column');
144 $error = $record->ut_alpha('column');
145 $error = $record->ut_alphan('column');
146 $error = $record->ut_phonen('column');
147 $error = $record->ut_anything('column');
148 $error = $record->ut_name('column');
150 $quoted_value = _quote($value,'table','field');
153 $fields = hfields('table');
154 if ( $fields->{Field} ) { # etc.
156 @fields = fields 'table'; #as a subroutine
157 @fields = $record->fields; #as a method call
162 (Mostly) object-oriented interface to database records. Records are currently
163 implemented on top of DBI. FS::Record is intended as a base class for
164 table-specific classes to inherit from, i.e. FS::cust_main.
170 =item new [ TABLE, ] HASHREF
172 Creates a new record. It doesn't store it in the database, though. See
173 L<"insert"> for that.
175 Note that the object stores this hash reference, not a distinct copy of the
176 hash it points to. You can ask the object for a copy with the I<hash>
179 TABLE can only be omitted when a dervived class overrides the table method.
185 my $class = ref($proto) || $proto;
187 bless ($self, $class);
189 unless ( defined ( $self->table ) ) {
190 $self->{'Table'} = shift;
191 carp "warning: FS::Record::new called with table name ". $self->{'Table'}
192 unless $nowarn_classload;
195 $self->{'Hash'} = shift;
197 foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
198 $self->{'Hash'}{$field}='';
201 $self->_rebless if $self->can('_rebless');
203 $self->{'modified'} = 0;
205 $self->_simplecache($self->{'Hash'}) if $self->can('_simplecache');
206 $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
213 my $class = ref($proto) || $proto;
215 bless ($self, $class);
217 $self->{'Table'} = shift unless defined ( $self->table );
219 my $hashref = $self->{'Hash'} = shift;
221 if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
222 my $obj = $cache->cache->{$hashref->{$cache->key}};
223 $obj->_cache($hashref, $cache) if $obj->can('_cache');
226 $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
233 my $class = ref($proto) || $proto;
235 bless ($self, $class);
236 if ( defined $self->table ) {
237 cluck "create constructor is deprecated, use new!";
240 croak "FS::Record::create called (not from a subclass)!";
244 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
246 Searches the database for all records matching (at least) the key/value pairs
247 in HASHREF. Returns all the records found as `FS::TABLE' objects if that
248 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
251 The preferred usage is to pass a hash reference of named parameters:
253 @records = qsearch( {
254 'table' => 'table_name',
255 'hashref' => { 'field' => 'value'
256 'field' => { 'op' => '<',
261 #these are optional...
263 'extra_sql' => 'AND field = ? AND intfield = ?',
264 'extra_param' => [ 'value', [ 5, 'int' ] ],
265 'order_by' => 'ORDER BY something',
266 #'cache_obj' => '', #optional
267 'addl_from' => 'LEFT JOIN othtable USING ( field )',
272 Much code still uses old-style positional parameters, this is also probably
273 fine in the common case where there are only two parameters:
275 my @records = qsearch( 'table', { 'field' => 'value' } );
277 Also possible is an experimental LISTREF of PARAMS_HASHREFs for a UNION of
278 the individual PARAMS_HASHREF queries
280 ###oops, argh, FS::Record::new only lets us create database fields.
281 #Normal behaviour if SELECT is not specified is `*', as in
282 #C<SELECT * FROM table WHERE ...>. However, there is an experimental new
283 #feature where you can specify SELECT - remember, the objects returned,
284 #although blessed into the appropriate `FS::TABLE' package, will only have the
285 #fields you specify. This might have unwanted results if you then go calling
286 #regular FS::TABLE methods
291 my %TYPE = (); #for debugging
294 my($type, $value) = @_;
296 my $bind_type = { TYPE => SQL_VARCHAR };
298 if ( $type =~ /(big)?(int|serial)/i && $value =~ /^-?\d+(\.\d+)?$/ ) {
300 $bind_type = { TYPE => SQL_INTEGER };
302 } elsif ( $type =~ /^bytea$/i || $type =~ /(blob|varbinary)/i ) {
304 if ( driver_name eq 'Pg' ) {
306 $bind_type = { pg_type => PG_BYTEA };
308 # $bind_type = ? #SQL_VARCHAR could be fine?
311 #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT
312 #fixed by DBD::Pg 2.11.8
313 #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded
314 #(make a Tron test first)
315 } elsif ( _is_fs_float( $type, $value ) ) {
317 $bind_type = { TYPE => SQL_DECIMAL };
326 my($type, $value) = @_;
327 if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) ||
328 ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/)
336 my( @stable, @record, @cache );
337 my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
339 my %union_options = ();
340 if ( ref($_[0]) eq 'ARRAY' ) {
343 foreach my $href ( @$optlist ) {
344 push @stable, ( $href->{'table'} or die "table name is required" );
345 push @record, ( $href->{'hashref'} || {} );
346 push @select, ( $href->{'select'} || '*' );
347 push @extra_sql, ( $href->{'extra_sql'} || '' );
348 push @extra_param, ( $href->{'extra_param'} || [] );
349 push @order_by, ( $href->{'order_by'} || '' );
350 push @cache, ( $href->{'cache_obj'} || '' );
351 push @addl_from, ( $href->{'addl_from'} || '' );
352 push @debug, ( $href->{'debug'} || '' );
354 die "at least one hashref is required" unless scalar(@stable);
355 } elsif ( ref($_[0]) eq 'HASH' ) {
357 $stable[0] = $opt->{'table'} or die "table name is required";
358 $record[0] = $opt->{'hashref'} || {};
359 $select[0] = $opt->{'select'} || '*';
360 $extra_sql[0] = $opt->{'extra_sql'} || '';
361 $extra_param[0] = $opt->{'extra_param'} || [];
362 $order_by[0] = $opt->{'order_by'} || '';
363 $cache[0] = $opt->{'cache_obj'} || '';
364 $addl_from[0] = $opt->{'addl_from'} || '';
365 $debug[0] = $opt->{'debug'} || '';
376 my $cache = $cache[0];
382 foreach my $stable ( @stable ) {
384 carp '->qsearch on cust_main called' if $stable eq 'cust_main' && $DEBUG;
386 #stop altering the caller's hashref
387 my $record = { %{ shift(@record) || {} } };#and be liberal in receipt
388 my $select = shift @select;
389 my $extra_sql = shift @extra_sql;
390 my $extra_param = shift @extra_param;
391 my $order_by = shift @order_by;
392 my $cache = shift @cache;
393 my $addl_from = shift @addl_from;
394 my $debug = shift @debug;
396 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
398 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
401 my $table = $cache ? $cache->table : $stable;
402 my $dbdef_table = dbdef->table($table)
403 or die "No schema for table $table found - ".
404 "do you need to run freeside-upgrade?";
405 my $pkey = $dbdef_table->primary_key;
407 my @real_fields = grep exists($record->{$_}), real_fields($table);
409 my $statement .= "SELECT $select FROM $stable";
412 $statement .= " $addl_from";
413 # detect aliasing of the main table
414 if ( $addl_from =~ /^\s*AS\s+(\w+)/i ) {
418 if ( @real_fields ) {
419 $statement .= ' WHERE '. join(' AND ',
420 get_real_fields($table, $record, \@real_fields, $alias_main));
423 $statement .= " $extra_sql" if defined($extra_sql);
424 $statement .= " $order_by" if defined($order_by);
426 push @statement, $statement;
428 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
431 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
434 my $value = $record->{$field};
435 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
436 $value = $value->{'value'} if ref($value);
437 my $type = dbdef->table($table)->column($field)->type;
439 my $bind_type = _bind_type($type, $value);
443 # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
445 # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
449 push @bind_type, $bind_type;
453 foreach my $param ( @$extra_param ) {
454 my $bind_type = { TYPE => SQL_VARCHAR };
457 $value = $param->[0];
458 my $type = $param->[1];
459 $bind_type = _bind_type($type, $value);
462 push @bind_type, $bind_type;
466 my $statement = join( ' ) UNION ( ', @statement );
467 $statement = "( $statement )" if scalar(@statement) > 1;
468 $statement .= " $union_options{order_by}" if $union_options{order_by};
470 my $sth = $dbh->prepare($statement)
471 or croak "$dbh->errstr doing $statement";
474 foreach my $value ( @value ) {
475 my $bind_type = shift @bind_type;
476 $sth->bind_param($bind++, $value, $bind_type );
479 # $sth->execute( map $record->{$_},
480 # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
481 # ) or croak "Error executing \"$statement\": ". $sth->errstr;
483 my $ok = $sth->execute;
485 my $error = "Error executing \"$statement\"";
486 $error .= ' (' . join(', ', map {"'$_'"} @value) . ')' if @value;
487 $error .= ': '. $sth->errstr;
491 my $table = $stable[0];
493 $table = '' if grep { $_ ne $table } @stable;
494 $pkey = dbdef->table($table)->primary_key if $table;
497 tie %result, "Tie::IxHash";
498 my @stuff = @{ $sth->fetchall_arrayref( {} ) };
499 if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
500 %result = map { $_->{$pkey}, $_ } @stuff;
502 @result{@stuff} = @stuff;
507 #below was refactored out to _from_hashref, this should use it at some point
510 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
511 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
512 #derivied class didn't override new method, so this optimization is safe
515 new_or_cached( "FS::$table", { %{$_} }, $cache )
519 new( "FS::$table", { %{$_} } )
523 #okay, its been tested
524 # warn "untested code (class FS::$table uses custom new method)";
526 eval 'FS::'. $table. '->new( { %{$_} } )';
530 # Check for encrypted fields and decrypt them.
531 ## only in the local copy, not the cached object
532 no warnings 'deprecated'; # XXX silence the warning for now
533 if ( $conf_encryption
534 && eval '@FS::'. $table . '::encrypted_fields' ) {
535 foreach my $record (@return) {
536 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
537 next if $field eq 'payinfo'
538 && ($record->isa('FS::payinfo_transaction_Mixin')
539 || $record->isa('FS::payinfo_Mixin') )
541 && !grep { $record->payby eq $_ } @encrypt_payby;
542 # Set it directly... This may cause a problem in the future...
543 $record->setfield($field, $record->decrypt($record->getfield($field)));
548 cluck "warning: FS::$table not loaded; returning FS::Record objects"
549 unless $nowarn_classload;
551 FS::Record->new( $table, { %{$_} } );
559 Construct the SQL statement and parameter-binding list for qsearch. Takes
560 the qsearch parameters.
562 Returns a hash containing:
563 'table': The primary table name (if there is one).
564 'statement': The SQL statement itself.
565 'bind_type': An arrayref of bind types.
566 'value': An arrayref of parameter values.
567 'cache': The cache object, if one was passed.
572 my( @stable, @record, @cache );
573 my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
576 my %union_options = ();
577 if ( ref($_[0]) eq 'ARRAY' ) {
580 foreach my $href ( @$optlist ) {
581 push @stable, ( $href->{'table'} or die "table name is required" );
582 push @record, ( $href->{'hashref'} || {} );
583 push @select, ( $href->{'select'} || '*' );
584 push @extra_sql, ( $href->{'extra_sql'} || '' );
585 push @extra_param, ( $href->{'extra_param'} || [] );
586 push @order_by, ( $href->{'order_by'} || '' );
587 push @cache, ( $href->{'cache_obj'} || '' );
588 push @addl_from, ( $href->{'addl_from'} || '' );
589 push @debug, ( $href->{'debug'} || '' );
591 die "at least one hashref is required" unless scalar(@stable);
592 } elsif ( ref($_[0]) eq 'HASH' ) {
594 $stable[0] = $opt->{'table'} or die "table name is required";
595 $record[0] = $opt->{'hashref'} || {};
596 $select[0] = $opt->{'select'} || '*';
597 $extra_sql[0] = $opt->{'extra_sql'} || '';
598 $extra_param[0] = $opt->{'extra_param'} || [];
599 $order_by[0] = $opt->{'order_by'} || '';
600 $cache[0] = $opt->{'cache_obj'} || '';
601 $addl_from[0] = $opt->{'addl_from'} || '';
602 $debug[0] = $opt->{'debug'} || '';
613 my $cache = $cache[0];
619 my $result_table = $stable[0];
620 foreach my $stable ( @stable ) {
621 #stop altering the caller's hashref
622 my $record = { %{ shift(@record) || {} } };#and be liberal in receipt
623 my $select = shift @select;
624 my $extra_sql = shift @extra_sql;
625 my $extra_param = shift @extra_param;
626 my $order_by = shift @order_by;
627 my $cache = shift @cache;
628 my $addl_from = shift @addl_from;
629 my $debug = shift @debug;
631 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
633 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
636 $result_table = '' if $result_table ne $stable;
638 my $table = $cache ? $cache->table : $stable;
639 my $dbdef_table = dbdef->table($table)
640 or die "No schema for table $table found - ".
641 "do you need to run freeside-upgrade?";
642 my $pkey = $dbdef_table->primary_key;
644 my @real_fields = grep exists($record->{$_}), real_fields($table);
646 my $statement .= "SELECT $select FROM $stable";
647 $statement .= " $addl_from" if $addl_from;
648 if ( @real_fields ) {
649 $statement .= ' WHERE '. join(' AND ',
650 get_real_fields($table, $record, \@real_fields));
653 $statement .= " $extra_sql" if defined($extra_sql);
654 $statement .= " $order_by" if defined($order_by);
656 push @statement, $statement;
658 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
662 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
665 my $value = $record->{$field};
666 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
667 $value = $value->{'value'} if ref($value);
668 my $type = dbdef->table($table)->column($field)->type;
670 my $bind_type = _bind_type($type, $value);
674 # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
676 # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
680 push @bind_type, $bind_type;
684 foreach my $param ( @$extra_param ) {
685 my $bind_type = { TYPE => SQL_VARCHAR };
688 $value = $param->[0];
689 my $type = $param->[1];
690 $bind_type = _bind_type($type, $value);
693 push @bind_type, $bind_type;
697 my $statement = join( ' ) UNION ( ', @statement );
698 $statement = "( $statement )" if scalar(@statement) > 1;
699 $statement .= " $union_options{order_by}" if $union_options{order_by};
702 statement => $statement,
703 bind_type => \@bind_type,
705 table => $result_table,
710 # qsearch should eventually use this
712 my ($table, $cache, @hashrefs) = @_;
714 # XXX get rid of these string evals at some point
715 # (when we have time to test it)
716 # my $class = "FS::$table" if $table;
717 # if ( $class and $class->isa('FS::Record') )
718 # if ( $class->can('new') eq \&new )
720 if ( $table && eval 'scalar(@FS::'. $table. '::ISA);' ) {
721 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
722 #derivied class didn't override new method, so this optimization is safe
725 new_or_cached( "FS::$table", { %{$_} }, $cache )
729 new( "FS::$table", { %{$_} } )
733 #okay, its been tested
734 # warn "untested code (class FS::$table uses custom new method)";
736 eval 'FS::'. $table. '->new( { %{$_} } )';
740 # Check for encrypted fields and decrypt them.
741 ## only in the local copy, not the cached object
742 if ( $conf_encryption
743 && eval '@FS::'. $table . '::encrypted_fields' ) {
744 foreach my $record (@return) {
745 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
746 next if $field eq 'payinfo'
747 && ($record->isa('FS::payinfo_transaction_Mixin')
748 || $record->isa('FS::payinfo_Mixin') )
750 && !grep { $record->payby eq $_ } @encrypt_payby;
751 # Set it directly... This may cause a problem in the future...
752 $record->setfield($field, $record->decrypt($record->getfield($field)));
757 cluck "warning: FS::$table not loaded; returning FS::Record objects"
758 unless $nowarn_classload;
760 FS::Record->new( $table, { %{$_} } );
766 sub get_real_fields {
769 my $real_fields = shift;
770 my $alias_main = shift; # defaults to undef
771 $alias_main ||= $table;
773 ## could be optimized more for readability
779 my $table_column = $qsearch_qualify_columns ? "$alias_main.$column" : $column;
780 my $type = dbdef->table($table)->column($column)->type;
781 my $value = $record->{$column};
782 $value = $value->{'value'} if ref($value);
784 if ( ref($record->{$column}) ) {
785 $op = $record->{$column}{'op'} if $record->{$column}{'op'};
786 #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
787 if ( uc($op) eq 'ILIKE' ) {
789 $record->{$column}{'value'} = lc($record->{$column}{'value'});
790 $table_column = "LOWER($table_column)";
792 $record->{$column} = $record->{$column}{'value'}
795 if ( ! defined( $record->{$column} ) || $record->{$column} eq '' ) {
797 if ( driver_name eq 'Pg' ) {
798 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
799 qq-( $table_column IS NULL )-;
801 qq-( $table_column IS NULL OR $table_column = '' )-;
804 qq-( $table_column IS NULL OR $table_column = "" )-;
806 } elsif ( $op eq '!=' ) {
807 if ( driver_name eq 'Pg' ) {
808 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
809 qq-( $table_column IS NOT NULL )-;
811 qq-( $table_column IS NOT NULL AND $table_column != '' )-;
814 qq-( $table_column IS NOT NULL AND $table_column != "" )-;
817 if ( driver_name eq 'Pg' ) {
818 qq-( $table_column $op '' )-;
820 qq-( $table_column $op "" )-;
823 } elsif ( $op eq '!=' ) {
824 qq-( $table_column IS NULL OR $table_column != ? )-;
825 #if this needs to be re-enabled, it needs to use a custom op like
826 #"APPROX=" or something (better name?, not '=', to avoid affecting other
828 #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
829 # ( "$table_column <= ?", "$table_column >= ?" );
831 "$table_column $op ?";
838 =item by_key PRIMARY_KEY_VALUE
840 This is a class method that returns the record with the given primary key
841 value. This method is only useful in FS::Record subclasses. For example:
843 my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
847 my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
852 my ($class, $pkey_value) = @_;
854 my $table = $class->table
855 or croak "No table for $class found";
857 my $dbdef_table = dbdef->table($table)
858 or die "No schema for table $table found - ".
859 "do you need to create it or run dbdef-create?";
860 my $pkey = $dbdef_table->primary_key
861 or die "No primary key for table $table";
863 return qsearchs($table, { $pkey => $pkey_value });
866 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
868 Experimental JOINed search method. Using this method, you can execute a
869 single SELECT spanning multiple tables, and cache the results for subsequent
870 method calls. Interface will almost definately change in an incompatible
878 my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
879 my $cache = FS::SearchCache->new( $ptable, $pkey );
882 grep { !$saw{$_->getfield($pkey)}++ }
883 qsearch($table, $record, $select, $extra_sql, $cache )
887 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
889 Same as qsearch, except that if more than one record matches, it B<carp>s but
890 returns the first. If this happens, you either made a logic error in asking
891 for a single item, or your data is corrupted.
895 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
897 my(@result) = qsearch(@_);
898 cluck "warning: Multiple records in scalar search ($table)"
899 #.join(' / ', map "$_=>".$_[1]->{$_}, keys %{ $_[1] } )
900 if scalar(@result) > 1;
901 #should warn more vehemently if the search was on a primary key?
902 scalar(@result) ? ($result[0]) : ();
913 Returns the table name.
918 # cluck "warning: FS::Record::table deprecated; supply one in subclass!";
925 Returns the DBIx::DBSchema::Table object for the table.
931 my($table)=$self->table;
932 dbdef->table($table);
937 Returns the primary key for the table.
943 my $pkey = $self->dbdef_table->primary_key;
946 =item get, getfield COLUMN
948 Returns the value of the column/field/key COLUMN.
953 my($self,$field) = @_;
954 # to avoid "Use of unitialized value" errors
955 if ( defined ( $self->{Hash}->{$field} ) ) {
956 $self->{Hash}->{$field};
966 =item set, setfield COLUMN, VALUE
968 Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE.
973 my($self,$field,$value) = @_;
974 $self->{'modified'} = 1;
975 $self->{'Hash'}->{$field} = $value;
984 Returns true if the column/field/key COLUMN exists.
989 my($self,$field) = @_;
990 exists($self->{Hash}->{$field});
993 =item AUTOLOADED METHODS
995 $record->column is a synonym for $record->get('column');
997 $record->column('value') is a synonym for $record->set('column','value');
999 $record->foreign_table_name calls qsearchs and returns a single
1000 FS::foreign_table record (for tables referenced by a column of this table) or
1001 qsearch and returns an array of FS::foreign_table records (for tables
1002 referenced by a column in the foreign table).
1008 my($self,$value)=@_;
1009 my($field)=$AUTOLOAD;
1012 confess "errant AUTOLOAD $field for $self (arg $value)"
1013 unless blessed($self) && $self->can('setfield');
1015 if ( my $fk_info = get_fk_method($self->table, $field) ) {
1017 my $method = $fk_info->{method} || 'qsearchs';
1018 my $table = $fk_info->{table} || $field;
1019 my $column = $fk_info->{column};
1020 my $foreign_column = $fk_info->{references} || $column;
1022 eval "use FS::$table";
1025 carp '->cust_main called' if $table eq 'cust_main' && $DEBUG;
1027 my $pkey_value = $self->$column();
1028 my %search = ( $foreign_column => $pkey_value );
1030 # FS::Record->$method() ? they're actually just subs :/
1031 if ( $method eq 'qsearchs' ) {
1032 return $pkey_value ? qsearchs( $table, \%search ) : '';
1033 } elsif ( $method eq 'qsearch' ) {
1034 return $pkey_value ? qsearch( $table, \%search ) : ();
1036 die "unknown method $method";
1041 if ( defined($value) ) {
1042 $self->setfield($field,$value);
1044 $self->getfield($field);
1048 # efficient (also, old, doesn't support FK stuff)
1050 # my $field = $AUTOLOAD;
1051 # $field =~ s/.*://;
1052 # if ( defined($_[1]) ) {
1053 # $_[0]->setfield($field, $_[1]);
1055 # $_[0]->getfield($field);
1059 # get_fk_method(TABLE, FIELD)
1060 # Internal subroutine for fetching the foreign key descriptor for TABLE.FIELD
1061 # if there is one. If not, returns undef.
1062 # This will initialize fk_method_cache if it hasn't happened yet. It is the
1063 # _only_ allowed way to access the contents of %fk_method_cache.
1065 # if we wanted to be even more efficient we'd create the fk methods in the
1066 # symbol table instead of relying on AUTOLOAD every time
1069 my ($table, $field) = @_;
1071 fk_methods_init() unless exists($fk_method_cache{$table});
1073 if ( exists($fk_method_cache{$table}) and
1074 exists($fk_method_cache{$table}{$field}) ) {
1075 return $fk_method_cache{$table}{$field};
1082 sub fk_methods_init {
1083 warn "[fk_methods_init]\n" if $DEBUG;
1084 foreach my $table ( dbdef->tables ) {
1085 $fk_method_cache{$table} = fk_methods($table);
1094 # foreign keys we reference in other tables
1095 foreach my $fk (dbdef->table($table)->foreign_keys) {
1098 if ( scalar( @{$fk->columns} ) == 1 ) {
1099 if ( ! defined($fk->references)
1100 || ! @{$fk->references}
1101 || $fk->columns->[0] eq $fk->references->[0]
1103 $method = $fk->table;
1105 #some sort of hint in the table.pm or schema for methods not named
1106 # after their foreign table (well, not a whole lot different than
1107 # just providing a small subroutine...)
1111 $hash{$method} = { #fk_info
1112 'method' => 'qsearchs',
1113 'column' => $fk->columns->[0],
1114 #'references' => $fk->references->[0],
1122 # foreign keys referenced in other tables to us
1123 # (alas. why we're cached. still, might this loop better be done once at
1124 # schema load time insetad of every time we AUTOLOAD a method on a new
1126 if (! defined $fk_table_cache) {
1127 foreach my $f_table ( dbdef->tables ) {
1128 foreach my $fk (dbdef->table($f_table)->foreign_keys) {
1129 push @{$fk_table_cache->{$fk->table}},[$f_table,$fk];
1133 foreach my $fks (@{$fk_table_cache->{$table}}) {
1134 my ($f_table,$fk) = @$fks;
1136 if ( scalar( @{$fk->columns} ) == 1 ) {
1137 if ( ! defined($fk->references)
1138 || ! @{$fk->references}
1139 || $fk->columns->[0] eq $fk->references->[0]
1143 #some sort of hint in the table.pm or schema for methods not named
1144 # after their foreign table (well, not a whole lot different than
1145 # just providing a small subroutine...)
1149 $hash{$method} = { #fk_info
1150 'method' => 'qsearch',
1151 'column' => $fk->columns->[0], #references||column
1152 #'references' => $fk->column->[0],
1164 Returns a list of the column/value pairs, usually for assigning to a new hash.
1166 To make a distinct duplicate of an FS::Record object, you can do:
1168 $new = new FS::Record ( $old->table, { $old->hash } );
1174 confess $self. ' -> hash: Hash attribute is undefined'
1175 unless defined($self->{'Hash'});
1176 %{ $self->{'Hash'} };
1181 Returns a reference to the column/value hash. This may be deprecated in the
1182 future; if there's a reason you can't just use the autoloaded or get/set
1196 +{ ( map { $_=>$self->$_ } $self->fields ),
1201 my( $class, %opt ) = @_;
1202 my $table = $class->table;
1203 my $self = $class->new( { map { $_ => $opt{$_} } fields($table) } );
1204 my $error = $self->insert;
1205 return +{ 'error' => $error } if $error;
1206 my $pkey = $self->pkey;
1207 return +{ 'error' => '',
1208 'primary_key' => $pkey,
1209 $pkey => $self->$pkey,
1215 Returns true if any of this object's values have been modified with set (or via
1216 an autoloaded method). Doesn't yet recognize when you retreive a hashref and
1223 $self->{'modified'};
1226 =item select_for_update
1228 Selects this record with the SQL "FOR UPDATE" command. This can be useful as
1233 sub select_for_update {
1235 my $primary_key = $self->primary_key;
1238 'table' => $self->table,
1239 'hashref' => { $primary_key => $self->$primary_key() },
1240 'extra_sql' => 'FOR UPDATE',
1246 Locks this table with a database-driver specific lock method. This is used
1247 as a mutex in order to do a duplicate search.
1249 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
1251 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
1253 Errors are fatal; no useful return value.
1255 Note: To use this method for new tables other than svc_acct and svc_phone,
1256 edit freeside-upgrade and add those tables to the duplicate_lock list.
1262 my $table = $self->table;
1264 warn "$me locking $table table\n" if $DEBUG;
1266 if ( driver_name =~ /^Pg/i ) {
1268 dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
1271 } elsif ( driver_name =~ /^mysql/i ) {
1273 dbh->do("SELECT * FROM duplicate_lock
1274 WHERE lockname = '$table'
1276 ) or die dbh->errstr;
1280 die "unknown database ". driver_name. "; don't know how to lock table";
1284 warn "$me acquired $table table lock\n" if $DEBUG;
1290 Inserts this record to the database. If there is an error, returns the error,
1291 otherwise returns false.
1299 warn "$self -> insert" if $DEBUG;
1301 my $error = $self->check;
1302 return $error if $error;
1304 #single-field non-null unique keys are given a value if empty
1305 #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
1306 foreach ( $self->dbdef_table->unique_singles) {
1307 next if $self->getfield($_);
1308 next if $self->dbdef_table->column($_)->null eq 'NULL';
1312 #and also the primary key, if the database isn't going to
1313 my $primary_key = $self->dbdef_table->primary_key;
1315 if ( $primary_key ) {
1316 my $col = $self->dbdef_table->column($primary_key);
1319 uc($col->type) =~ /^(BIG)?SERIAL\d?/
1320 || ( driver_name eq 'Pg'
1321 && defined($col->default)
1322 && $col->quoted_default =~ /^nextval\(/i
1324 || ( driver_name eq 'mysql'
1325 && defined($col->local)
1326 && $col->local =~ /AUTO_INCREMENT/i
1328 $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
1331 my $table = $self->table;
1333 # Encrypt before the database
1334 if ( scalar( eval '@FS::'. $table . '::encrypted_fields')
1337 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
1338 next if $field eq 'payinfo'
1339 && ($self->isa('FS::payinfo_transaction_Mixin')
1340 || $self->isa('FS::payinfo_Mixin') )
1342 && !grep { $self->payby eq $_ } @encrypt_payby;
1343 $saved->{$field} = $self->getfield($field);
1344 $self->setfield($field, $self->encrypt($self->getfield($field)));
1348 #false laziness w/delete
1350 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1354 my $statement = "INSERT INTO $table ";
1355 my @bind_values = ();
1357 if ( ! @real_fields ) {
1359 $statement .= 'DEFAULT VALUES';
1363 if ( $use_placeholders ) {
1365 @bind_values = map $self->getfield($_), @real_fields;
1369 join( ', ', @real_fields ).
1371 join( ', ', map '?', @real_fields ). # @bind_values ).
1377 my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
1381 join( ', ', @real_fields ).
1383 join( ', ', @values ).
1391 warn "[debug]$me $statement\n" if $DEBUG > 1;
1392 my $sth = dbh->prepare($statement) or return dbh->errstr;
1394 local $SIG{HUP} = 'IGNORE';
1395 local $SIG{INT} = 'IGNORE';
1396 local $SIG{QUIT} = 'IGNORE';
1397 local $SIG{TERM} = 'IGNORE';
1398 local $SIG{TSTP} = 'IGNORE';
1399 local $SIG{PIPE} = 'IGNORE';
1401 $sth->execute(@bind_values) or return $sth->errstr;
1403 # get inserted id from the database, if applicable & needed
1404 if ( $db_seq && ! $self->getfield($primary_key) ) {
1405 warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
1409 if ( driver_name eq 'Pg' ) {
1411 #my $oid = $sth->{'pg_oid_status'};
1412 #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
1414 my $default = $self->dbdef_table->column($primary_key)->quoted_default;
1415 unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
1416 dbh->rollback if $FS::UID::AutoCommit;
1417 return "can't parse $table.$primary_key default value".
1418 " for sequence name: $default";
1422 my $i_sql = "SELECT currval('$sequence')";
1423 my $i_sth = dbh->prepare($i_sql) or do {
1424 dbh->rollback if $FS::UID::AutoCommit;
1427 $i_sth->execute() or do { #$i_sth->execute($oid)
1428 dbh->rollback if $FS::UID::AutoCommit;
1429 return $i_sth->errstr;
1431 $insertid = $i_sth->fetchrow_arrayref->[0];
1433 } elsif ( driver_name eq 'mysql' ) {
1435 $insertid = dbh->{'mysql_insertid'};
1436 # work around mysql_insertid being null some of the time, ala RT :/
1437 unless ( $insertid ) {
1438 warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
1439 "using SELECT LAST_INSERT_ID();";
1440 my $i_sql = "SELECT LAST_INSERT_ID()";
1441 my $i_sth = dbh->prepare($i_sql) or do {
1442 dbh->rollback if $FS::UID::AutoCommit;
1445 $i_sth->execute or do {
1446 dbh->rollback if $FS::UID::AutoCommit;
1447 return $i_sth->errstr;
1449 $insertid = $i_sth->fetchrow_arrayref->[0];
1454 dbh->rollback if $FS::UID::AutoCommit;
1455 return "don't know how to retreive inserted ids from ". driver_name.
1456 ", try using counterfiles (maybe run dbdef-create?)";
1460 $self->setfield($primary_key, $insertid);
1465 if ( defined( dbdef->table('h_'. $table) ) && ! $no_history ) {
1466 my $h_statement = $self->_h_statement('insert');
1467 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1468 $h_sth = dbh->prepare($h_statement) or do {
1469 dbh->rollback if $FS::UID::AutoCommit;
1475 $h_sth->execute or return $h_sth->errstr if $h_sth;
1477 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1479 # Now that it has been saved, reset the encrypted fields so that $new
1480 # can still be used.
1481 foreach my $field (keys %{$saved}) {
1482 $self->setfield($field, $saved->{$field});
1490 Depriciated (use insert instead).
1495 cluck "warning: FS::Record::add deprecated!";
1496 insert @_; #call method in this scope
1501 Delete this record from the database. If there is an error, returns the error,
1502 otherwise returns false.
1509 my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1511 $self->getfield($_) eq ''
1512 #? "( $_ IS NULL OR $_ = \"\" )"
1513 ? ( driver_name eq 'Pg'
1515 : "( $_ IS NULL OR $_ = \"\" )"
1517 : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1518 } ( $self->dbdef_table->primary_key )
1519 ? ( $self->dbdef_table->primary_key)
1520 : real_fields($self->table)
1522 warn "[debug]$me $statement\n" if $DEBUG > 1;
1523 my $sth = dbh->prepare($statement) or return dbh->errstr;
1526 if ( defined dbdef->table('h_'. $self->table) ) {
1527 my $h_statement = $self->_h_statement('delete');
1528 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1529 $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1534 my $primary_key = $self->dbdef_table->primary_key;
1536 local $SIG{HUP} = 'IGNORE';
1537 local $SIG{INT} = 'IGNORE';
1538 local $SIG{QUIT} = 'IGNORE';
1539 local $SIG{TERM} = 'IGNORE';
1540 local $SIG{TSTP} = 'IGNORE';
1541 local $SIG{PIPE} = 'IGNORE';
1543 my $rc = $sth->execute or return $sth->errstr;
1544 #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1545 $h_sth->execute or return $h_sth->errstr if $h_sth;
1547 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1549 #no need to needlessly destoy the data either (causes problems actually)
1550 #undef $self; #no need to keep object!
1557 Depriciated (use delete instead).
1562 cluck "warning: FS::Record::del deprecated!";
1563 &delete(@_); #call method in this scope
1566 =item replace OLD_RECORD
1568 Replace the OLD_RECORD with this one in the database. If there is an error,
1569 returns the error, otherwise returns false.
1574 my ($new, $old) = (shift, shift);
1576 $old = $new->replace_old unless defined($old);
1578 warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1580 if ( $new->can('replace_check') ) {
1581 my $error = $new->replace_check($old);
1582 return $error if $error;
1585 return "Records not in same table!" unless $new->table eq $old->table;
1587 my $primary_key = $old->dbdef_table->primary_key;
1588 return "Can't change primary key $primary_key ".
1589 'from '. $old->getfield($primary_key).
1590 ' to ' . $new->getfield($primary_key)
1592 && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1594 my $error = $new->check;
1595 return $error if $error;
1597 # Encrypt for replace
1599 if ( scalar( eval '@FS::'. $new->table . '::encrypted_fields')
1602 foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1603 next if $field eq 'payinfo'
1604 && ($new->isa('FS::payinfo_transaction_Mixin')
1605 || $new->isa('FS::payinfo_Mixin') )
1607 && !grep { $new->payby eq $_ } @encrypt_payby;
1608 $saved->{$field} = $new->getfield($field);
1609 $new->setfield($field, $new->encrypt($new->getfield($field)));
1613 #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1614 my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1615 ? ($_, $new->getfield($_)) : () } $old->fields;
1617 unless (keys(%diff) || $no_update_diff ) {
1618 carp "[warning]$me ". ref($new)."->replace ".
1619 ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
1620 ": records identical"
1621 unless $nowarn_identical;
1625 my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1627 "$_ = ". _quote($new->getfield($_),$old->table,$_)
1628 } real_fields($old->table)
1633 if ( $old->getfield($_) eq '' ) {
1635 #false laziness w/qsearch
1636 if ( driver_name eq 'Pg' ) {
1637 my $type = $old->dbdef_table->column($_)->type;
1638 if ( $type =~ /(int|(big)?serial)/i ) {
1641 qq-( $_ IS NULL OR $_ = '' )-;
1644 qq-( $_ IS NULL OR $_ = "" )-;
1648 "$_ = ". _quote($old->getfield($_),$old->table,$_);
1651 } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1654 warn "[debug]$me $statement\n" if $DEBUG > 1;
1655 my $sth = dbh->prepare($statement) or return dbh->errstr;
1658 if ( defined dbdef->table('h_'. $old->table) ) {
1659 my $h_old_statement = $old->_h_statement('replace_old');
1660 warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1661 $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1667 if ( defined dbdef->table('h_'. $new->table) ) {
1668 my $h_new_statement = $new->_h_statement('replace_new');
1669 warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1670 $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1675 local $SIG{HUP} = 'IGNORE';
1676 local $SIG{INT} = 'IGNORE';
1677 local $SIG{QUIT} = 'IGNORE';
1678 local $SIG{TERM} = 'IGNORE';
1679 local $SIG{TSTP} = 'IGNORE';
1680 local $SIG{PIPE} = 'IGNORE';
1682 my $rc = $sth->execute or return $sth->errstr;
1683 #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1684 $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1685 $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1687 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1689 # Now that it has been saved, reset the encrypted fields so that $new
1690 # can still be used.
1691 foreach my $field (keys %{$saved}) {
1692 $new->setfield($field, $saved->{$field});
1700 my( $self ) = shift;
1701 warn "[$me] replace called with no arguments; autoloading old record\n"
1704 my $primary_key = $self->dbdef_table->primary_key;
1705 if ( $primary_key ) {
1706 $self->by_key( $self->$primary_key() ) #this is what's returned
1707 or croak "can't find ". $self->table. ".$primary_key ".
1708 $self->$primary_key();
1710 croak $self->table. " has no primary key; pass old record as argument";
1717 Depriciated (use replace instead).
1722 cluck "warning: FS::Record::rep deprecated!";
1723 replace @_; #call method in this scope
1728 Checks custom fields. Subclasses should still provide a check method to validate
1729 non-custom fields, etc., and call this method via $self->SUPER::check.
1735 foreach my $field ($self->virtual_fields) {
1736 my $error = $self->ut_textn($field);
1737 return $error if $error;
1742 =item virtual_fields [ TABLE ]
1744 Returns a list of virtual fields defined for the table. This should not
1745 be exported, and should only be called as an instance or class method.
1749 sub virtual_fields {
1752 $table = $self->table or confess "virtual_fields called on non-table";
1754 confess "Unknown table $table" unless dbdef->table($table);
1756 return () unless dbdef->table('part_virtual_field');
1758 unless ( $virtual_fields_cache{$table} ) {
1759 my $concat = [ "'cf_'", "name" ];
1760 my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' .
1761 "WHERE dbtable = '$table'";
1763 my $result = $dbh->selectcol_arrayref($query);
1764 confess "Error executing virtual fields query: $query: ". $dbh->errstr
1766 $virtual_fields_cache{$table} = $result;
1769 @{$virtual_fields_cache{$table}};
1773 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1775 Processes a batch import as a queued JSRPC job
1777 JOB is an FS::queue entry.
1779 OPTIONS_HASHREF can have the following keys:
1785 Table name (required).
1789 Arrayref of field names for static fields. They will be given values from the
1790 PARAMS hashref and passed as a "params" hashref to batch_import.
1794 Formats hashref. Keys are field names, values are listrefs that define the
1797 Each listref value can be a column name or a code reference. Coderefs are run
1798 with the row object, data and a FS::Conf object as the three parameters.
1799 For example, this coderef does the same thing as using the "columnname" string:
1802 my( $record, $data, $conf ) = @_;
1803 $record->columnname( $data );
1806 Coderefs are run after all "column name" fields are assigned.
1810 Optional format hashref of types. Keys are field names, values are "csv",
1811 "xls" or "fixedlength". Overrides automatic determination of file type
1814 =item format_headers
1816 Optional format hashref of header lines. Keys are field names, values are 0
1817 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1820 =item format_sep_chars
1822 Optional format hashref of CSV sep_chars. Keys are field names, values are the
1823 CSV separation character.
1825 =item format_fixedlenth_formats
1827 Optional format hashref of fixed length format defintiions. Keys are field
1828 names, values Parse::FixedLength listrefs of field definitions.
1832 Set true to default to CSV file type if the filename does not contain a
1833 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1838 PARAMS is a hashref (or base64-encoded Storable hashref) containing the
1839 POSTed data. It must contain the field "uploaded files", generated by
1840 /elements/file-upload.html and containing the list of uploaded files.
1841 Currently only supports a single file named "file".
1846 sub process_batch_import {
1847 my($job, $opt, $param) = @_;
1849 my $table = $opt->{table};
1850 my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1851 my %formats = %{ $opt->{formats} };
1853 warn Dumper($param) if $DEBUG;
1855 my $files = $param->{'uploaded_files'}
1856 or die "No files provided.\n";
1858 my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1860 my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1861 my $file = $dir. $files{'file'};
1866 formats => \%formats,
1867 format_types => $opt->{format_types},
1868 format_headers => $opt->{format_headers},
1869 format_sep_chars => $opt->{format_sep_chars},
1870 format_fixedlength_formats => $opt->{format_fixedlength_formats},
1871 format_xml_formats => $opt->{format_xml_formats},
1872 format_asn_formats => $opt->{format_asn_formats},
1873 format_row_callbacks => $opt->{format_row_callbacks},
1874 format_hash_callbacks => $opt->{format_hash_callbacks},
1879 format => $param->{format},
1880 params => { map { $_ => $param->{$_} } @pass_params },
1882 default_csv => $opt->{default_csv},
1883 preinsert_callback => $opt->{preinsert_callback},
1884 postinsert_callback => $opt->{postinsert_callback},
1885 insert_args_callback => $opt->{insert_args_callback},
1888 if ( $opt->{'batch_namecol'} ) {
1889 $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1890 $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1893 my $error = FS::Record::batch_import( \%iopt );
1897 die "$error\n" if $error;
1900 =item batch_import PARAM_HASHREF
1902 Class method for batch imports. Available params:
1908 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1914 =item format_headers
1916 =item format_sep_chars
1918 =item format_fixedlength_formats
1920 =item format_row_callbacks
1922 =item format_hash_callbacks - After parsing, before object creation
1924 =item fields - Alternate way to specify import, specifying import fields directly as a listref
1926 =item preinsert_callback
1928 =item postinsert_callback
1934 FS::queue object, will be updated with progress
1940 csv, xls, fixedlength, xml
1952 warn "$me batch_import call with params: \n". Dumper($param)
1955 my $table = $param->{table};
1957 my $job = $param->{job};
1958 my $file = $param->{file};
1959 my $params = $param->{params} || {};
1961 my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
1962 my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
1964 my( $type, $header, $sep_char,
1965 $fixedlength_format, $xml_format, $asn_format,
1966 $parser_opt, $row_callback, $hash_callback, @fields );
1968 my $postinsert_callback = '';
1969 $postinsert_callback = $param->{'postinsert_callback'}
1970 if $param->{'postinsert_callback'};
1971 my $preinsert_callback = '';
1972 $preinsert_callback = $param->{'preinsert_callback'}
1973 if $param->{'preinsert_callback'};
1974 my $insert_args_callback = '';
1975 $insert_args_callback = $param->{'insert_args_callback'}
1976 if $param->{'insert_args_callback'};
1978 if ( $param->{'format'} ) {
1980 my $format = $param->{'format'};
1981 my $formats = $param->{formats};
1982 die "unknown format $format" unless exists $formats->{ $format };
1984 $type = $param->{'format_types'}
1985 ? $param->{'format_types'}{ $format }
1986 : $param->{type} || 'csv';
1989 $header = $param->{'format_headers'}
1990 ? $param->{'format_headers'}{ $param->{'format'} }
1993 $sep_char = $param->{'format_sep_chars'}
1994 ? $param->{'format_sep_chars'}{ $param->{'format'} }
1997 $fixedlength_format =
1998 $param->{'format_fixedlength_formats'}
1999 ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
2003 $param->{'format_parser_opts'}
2004 ? $param->{'format_parser_opts'}{ $param->{'format'} }
2008 $param->{'format_xml_formats'}
2009 ? $param->{'format_xml_formats'}{ $param->{'format'} }
2013 $param->{'format_asn_formats'}
2014 ? $param->{'format_asn_formats'}{ $param->{'format'} }
2018 $param->{'format_row_callbacks'}
2019 ? $param->{'format_row_callbacks'}{ $param->{'format'} }
2023 $param->{'format_hash_callbacks'}
2024 ? $param->{'format_hash_callbacks'}{ $param->{'format'} }
2027 @fields = @{ $formats->{ $format } };
2029 } elsif ( $param->{'fields'} ) {
2031 $type = ''; #infer from filename
2034 $fixedlength_format = '';
2036 $hash_callback = '';
2037 @fields = @{ $param->{'fields'} };
2040 die "neither format nor fields specified";
2043 #my $file = $param->{file};
2046 if ( $file =~ /\.(\w+)$/i ) {
2050 warn "can't parse file type from filename $file; defaulting to CSV";
2054 if $param->{'default_csv'} && $type ne 'xls';
2062 my $asn_header_buffer;
2063 if ( $type eq 'csv' || $type eq 'fixedlength' ) {
2065 if ( $type eq 'csv' ) {
2067 $parser_opt->{'binary'} = 1;
2068 $parser_opt->{'sep_char'} = $sep_char if $sep_char;
2069 $parser = Text::CSV_XS->new($parser_opt);
2071 } elsif ( $type eq 'fixedlength' ) {
2073 eval "use Parse::FixedLength;";
2075 $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
2078 die "Unknown file type $type\n";
2081 @buffer = split(/\r?\n/, slurp($file) );
2082 splice(@buffer, 0, ($header || 0) );
2083 $count = scalar(@buffer);
2085 } elsif ( $type eq 'xls' ) {
2087 eval "use Spreadsheet::ParseExcel;";
2090 eval "use DateTime::Format::Excel;";
2091 #for now, just let the error be thrown if it is used, since only CDR
2092 # formats bill_west and troop use it, not other excel-parsing things
2095 my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
2097 $parser = $excel->{Worksheet}[0]; #first sheet
2099 $count = $parser->{MaxRow} || $parser->{MinRow};
2102 $row = $header || 0;
2104 } elsif ( $type eq 'xml' ) {
2107 eval "use XML::Simple;";
2109 my $xmlrow = $xml_format->{'xmlrow'};
2110 $parser = $xml_format->{'xmlkeys'};
2111 die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
2112 my $data = XML::Simple::XMLin(
2114 'SuppressEmpty' => '', #sets empty values to ''
2118 $rows = $rows->{$_} foreach @$xmlrow;
2119 $rows = [ $rows ] if ref($rows) ne 'ARRAY';
2120 $count = @buffer = @$rows;
2122 } elsif ( $type eq 'asn.1' ) {
2124 eval "use Convert::ASN1";
2127 my $asn = Convert::ASN1->new;
2128 $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
2130 $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
2132 my $data = slurp($file);
2133 my $asn_output = $parser->decode( $data )
2134 or return "No ". $asn_format->{'macro'}. " found\n";
2136 $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
2138 my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
2139 $count = @buffer = @$rows;
2142 die "Unknown file type $type\n";
2147 local $SIG{HUP} = 'IGNORE';
2148 local $SIG{INT} = 'IGNORE';
2149 local $SIG{QUIT} = 'IGNORE';
2150 local $SIG{TERM} = 'IGNORE';
2151 local $SIG{TSTP} = 'IGNORE';
2152 local $SIG{PIPE} = 'IGNORE';
2154 my $oldAutoCommit = $FS::UID::AutoCommit;
2155 local $FS::UID::AutoCommit = 0;
2158 #my $params = $param->{params} || {};
2159 if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
2160 my $batch_col = $param->{'batch_keycol'};
2162 my $batch_class = 'FS::'. $param->{'batch_table'};
2163 my $batch = $batch_class->new({
2164 $param->{'batch_namecol'} => $param->{'batch_namevalue'}
2166 my $error = $batch->insert;
2168 $dbh->rollback if $oldAutoCommit;
2169 return "can't insert batch record: $error";
2171 #primary key via dbdef? (so the column names don't have to match)
2172 my $batch_value = $batch->get( $param->{'batch_keycol'} );
2174 $params->{ $batch_col } = $batch_value;
2177 #my $job = $param->{job};
2180 my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
2184 my %hash = %$params;
2185 if ( $type eq 'csv' ) {
2187 last unless scalar(@buffer);
2188 $line = shift(@buffer);
2190 next if $line =~ /^\s*$/; #skip empty lines
2192 $line = &{$row_callback}($line) if $row_callback;
2194 next if $line =~ /^\s*$/; #skip empty lines
2196 $parser->parse($line) or do {
2197 $dbh->rollback if $oldAutoCommit;
2198 return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
2200 @columns = $parser->fields();
2202 } elsif ( $type eq 'fixedlength' ) {
2204 last unless scalar(@buffer);
2205 $line = shift(@buffer);
2207 @columns = $parser->parse($line);
2209 } elsif ( $type eq 'xls' ) {
2211 last if $row > ($parser->{MaxRow} || $parser->{MinRow})
2212 || ! $parser->{Cells}[$row];
2214 my @row = @{ $parser->{Cells}[$row] };
2215 @columns = map $_->{Val}, @row;
2218 #warn $z++. ": $_\n" for @columns;
2220 } elsif ( $type eq 'xml' ) {
2222 # $parser = [ 'Column0Key', 'Column1Key' ... ]
2223 last unless scalar(@buffer);
2224 my $row = shift @buffer;
2225 @columns = @{ $row }{ @$parser };
2227 } elsif ( $type eq 'asn.1' ) {
2229 last unless scalar(@buffer);
2230 my $row = shift @buffer;
2231 &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2232 if $asn_format->{row_callback};
2233 foreach my $key ( keys %{ $asn_format->{map} } ) {
2234 $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2238 die "Unknown file type $type\n";
2243 foreach my $field ( @fields ) {
2245 my $value = shift @columns;
2247 if ( ref($field) eq 'CODE' ) {
2248 #&{$field}(\%hash, $value);
2249 push @later, $field, $value;
2251 #??? $hash{$field} = $value if length($value);
2252 $hash{$field} = $value if defined($value) && length($value);
2257 if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
2258 && length($1) == $custnum_length ) {
2259 $hash{custnum} = $2;
2262 %hash = &{$hash_callback}(%hash) if $hash_callback;
2264 #my $table = $param->{table};
2265 my $class = "FS::$table";
2267 my $record = $class->new( \%hash );
2270 while ( scalar(@later) ) {
2271 my $sub = shift @later;
2272 my $data = shift @later;
2274 &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2277 $dbh->rollback if $oldAutoCommit;
2278 return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2280 last if exists( $param->{skiprow} );
2282 next if exists( $param->{skiprow} );
2284 if ( $preinsert_callback ) {
2285 my $error = &{$preinsert_callback}($record, $param);
2287 $dbh->rollback if $oldAutoCommit;
2288 return "preinsert_callback error". ( $line ? " for $line" : '' ).
2291 next if exists $param->{skiprow} && $param->{skiprow};
2294 my @insert_args = ();
2295 if ( $insert_args_callback ) {
2296 @insert_args = &{$insert_args_callback}($record, $param);
2299 my $error = $record->insert(@insert_args);
2302 $dbh->rollback if $oldAutoCommit;
2303 return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2309 if ( $postinsert_callback ) {
2310 my $error = &{$postinsert_callback}($record, $param);
2312 $dbh->rollback if $oldAutoCommit;
2313 return "postinsert_callback error". ( $line ? " for $line" : '' ).
2318 if ( $job && time - $min_sec > $last ) { #progress bar
2319 $job->update_statustext( int(100 * $imported / $count) );
2325 unless ( $imported || $param->{empty_ok} ) {
2326 $dbh->rollback if $oldAutoCommit;
2327 return "Empty file!";
2330 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2337 my( $self, $action, $time ) = @_;
2341 my %nohistory = map { $_=>1 } $self->nohistory_fields;
2344 grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2345 real_fields($self->table);
2348 # If we're encrypting then don't store the payinfo in the history
2349 if ( $conf_encryption && $self->table ne 'banned_pay' ) {
2350 @fields = grep { $_ ne 'payinfo' } @fields;
2353 my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2355 "INSERT INTO h_". $self->table. " ( ".
2356 join(', ', qw(history_date history_usernum history_action), @fields ).
2359 $FS::CurrentUser::CurrentUser->usernum,
2360 dbh->quote($action),
2369 B<Warning>: External use is B<deprecated>.
2371 Replaces COLUMN in record with a unique number, using counters in the
2372 filesystem. Used by the B<insert> method on single-field unique columns
2373 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2374 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2376 Returns the new value.
2381 my($self,$field) = @_;
2382 my($table)=$self->table;
2384 croak "Unique called on field $field, but it is ",
2385 $self->getfield($field),
2387 if $self->getfield($field);
2389 #warn "table $table is tainted" if is_tainted($table);
2390 #warn "field $field is tainted" if is_tainted($field);
2392 my($counter) = new File::CounterFile "$table.$field",0;
2394 my $index = $counter->inc;
2395 $index = $counter->inc while qsearchs($table, { $field=>$index } );
2397 $index =~ /^(\d*)$/;
2400 $self->setfield($field,$index);
2404 =item ut_float COLUMN
2406 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be
2407 null. If there is an error, returns the error, otherwise returns false.
2412 my($self,$field)=@_ ;
2413 ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2414 $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2415 $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2416 $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2417 or return "Illegal or empty (float) $field: ". $self->getfield($field);
2418 $self->setfield($field,$1);
2421 =item ut_floatn COLUMN
2423 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
2424 null. If there is an error, returns the error, otherwise returns false.
2428 #false laziness w/ut_ipn
2430 my( $self, $field ) = @_;
2431 if ( $self->getfield($field) =~ /^()$/ ) {
2432 $self->setfield($field,'');
2435 $self->ut_float($field);
2439 =item ut_sfloat COLUMN
2441 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2442 May not be null. If there is an error, returns the error, otherwise returns
2448 my($self,$field)=@_ ;
2449 ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2450 $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2451 $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2452 $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2453 or return "Illegal or empty (float) $field: ". $self->getfield($field);
2454 $self->setfield($field,$1);
2457 =item ut_sfloatn COLUMN
2459 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
2460 null. If there is an error, returns the error, otherwise returns false.
2465 my( $self, $field ) = @_;
2466 if ( $self->getfield($field) =~ /^()$/ ) {
2467 $self->setfield($field,'');
2470 $self->ut_sfloat($field);
2474 =item ut_snumber COLUMN
2476 Check/untaint signed numeric data (whole numbers). If there is an error,
2477 returns the error, otherwise returns false.
2482 my($self, $field) = @_;
2483 $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2484 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2485 $self->setfield($field, "$1$2");
2489 =item ut_snumbern COLUMN
2491 Check/untaint signed numeric data (whole numbers). If there is an error,
2492 returns the error, otherwise returns false.
2497 my($self, $field) = @_;
2498 $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2499 or return "Illegal (numeric) $field: ". $self->getfield($field);
2501 return "Illegal (numeric) $field: ". $self->getfield($field)
2504 $self->setfield($field, "$1$2");
2508 =item ut_number COLUMN
2510 Check/untaint simple numeric data (whole numbers). May not be null. If there
2511 is an error, returns the error, otherwise returns false.
2516 my($self,$field)=@_;
2517 $self->getfield($field) =~ /^\s*(\d+)\s*$/
2518 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2519 $self->setfield($field,$1);
2523 =item ut_numbern COLUMN
2525 Check/untaint simple numeric data (whole numbers). May be null. If there is
2526 an error, returns the error, otherwise returns false.
2531 my($self,$field)=@_;
2532 $self->getfield($field) =~ /^\s*(\d*)\s*$/
2533 or return "Illegal (numeric) $field: ". $self->getfield($field);
2534 $self->setfield($field,$1);
2538 =item ut_decimal COLUMN[, DIGITS]
2540 Check/untaint decimal numbers (up to DIGITS decimal places. If there is an
2541 error, returns the error, otherwise returns false.
2543 =item ut_decimaln COLUMN[, DIGITS]
2545 Check/untaint decimal numbers. May be null. If there is an error, returns
2546 the error, otherwise returns false.
2551 my($self, $field, $digits) = @_;
2553 $self->getfield($field) =~ /^\s*(\d+(\.\d{0,$digits})?)\s*$/
2554 or return "Illegal or empty (decimal) $field: ".$self->getfield($field);
2555 $self->setfield($field, $1);
2560 my($self, $field, $digits) = @_;
2561 $self->getfield($field) =~ /^\s*(\d*(\.\d{0,$digits})?)\s*$/
2562 or return "Illegal (decimal) $field: ".$self->getfield($field);
2563 $self->setfield($field, $1);
2567 =item ut_money COLUMN
2569 Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
2570 is an error, returns the error, otherwise returns false.
2575 my($self,$field)=@_;
2577 if ( $self->getfield($field) eq '' ) {
2578 $self->setfield($field, 0);
2579 } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2580 #handle one decimal place without barfing out
2581 $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2582 } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2583 $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2585 return "Illegal (money) $field: ". $self->getfield($field);
2591 =item ut_moneyn COLUMN
2593 Check/untaint monetary numbers. May be negative. If there
2594 is an error, returns the error, otherwise returns false.
2599 my($self,$field)=@_;
2600 if ($self->getfield($field) eq '') {
2601 $self->setfield($field, '');
2604 $self->ut_money($field);
2607 =item ut_currencyn COLUMN
2609 Check/untaint currency indicators, such as USD or EUR. May be null. If there
2610 is an error, returns the error, otherwise returns false.
2615 my($self, $field) = @_;
2616 if ($self->getfield($field) eq '') { #can be null
2617 $self->setfield($field, '');
2620 $self->ut_currency($field);
2623 =item ut_currency COLUMN
2625 Check/untaint currency indicators, such as USD or EUR. May not be null. If
2626 there is an error, returns the error, otherwise returns false.
2631 my($self, $field) = @_;
2632 my $value = uc( $self->getfield($field) );
2633 if ( code2currency($value) ) {
2634 $self->setfield($value);
2636 return "Unknown currency $value";
2642 =item ut_text COLUMN
2644 Check/untaint text. Alphanumerics, spaces, and the following punctuation
2645 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < > ~
2646 May not be null. If there is an error, returns the error, otherwise returns
2652 my($self,$field)=@_;
2653 #warn "msgcat ". \&msgcat. "\n";
2654 #warn "notexist ". \¬exist. "\n";
2655 #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2656 # \p{Word} = alphanumerics, marks (diacritics), and connectors
2657 # see perldoc perluniprops
2658 $self->getfield($field)
2659 =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>\~$money_char]+)$/
2660 or return gettext('illegal_or_empty_text'). " $field: ".
2661 $self->getfield($field);
2662 $self->setfield($field,$1);
2666 =item ut_textn COLUMN
2668 Check/untaint text. Alphanumerics, spaces, and the following punctuation
2669 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2670 May be null. If there is an error, returns the error, otherwise returns false.
2675 my($self,$field)=@_;
2676 return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2677 $self->ut_text($field);
2680 =item ut_alpha COLUMN
2682 Check/untaint alphanumeric strings (no spaces). May not be null. If there is
2683 an error, returns the error, otherwise returns false.
2688 my($self,$field)=@_;
2689 $self->getfield($field) =~ /^(\w+)$/
2690 or return "Illegal or empty (alphanumeric) $field: ".
2691 $self->getfield($field);
2692 $self->setfield($field,$1);
2696 =item ut_alphan COLUMN
2698 Check/untaint alphanumeric strings (no spaces). May be null. If there is an
2699 error, returns the error, otherwise returns false.
2704 my($self,$field)=@_;
2705 $self->getfield($field) =~ /^(\w*)$/
2706 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2707 $self->setfield($field,$1);
2711 =item ut_alphasn COLUMN
2713 Check/untaint alphanumeric strings, spaces allowed. May be null. If there is
2714 an error, returns the error, otherwise returns false.
2719 my($self,$field)=@_;
2720 $self->getfield($field) =~ /^([\w ]*)$/
2721 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2722 $self->setfield($field,$1);
2727 =item ut_alpha_lower COLUMN
2729 Check/untaint lowercase alphanumeric strings (no spaces). May not be null. If
2730 there is an error, returns the error, otherwise returns false.
2734 sub ut_alpha_lower {
2735 my($self,$field)=@_;
2736 $self->getfield($field) =~ /[[:upper:]]/
2737 and return "Uppercase characters are not permitted in $field";
2738 $self->ut_alpha($field);
2741 =item ut_phonen COLUMN [ COUNTRY ]
2743 Check/untaint phone numbers. May be null. If there is an error, returns
2744 the error, otherwise returns false.
2746 Takes an optional two-letter ISO 3166-1 alpha-2 country code; without
2747 it or with unsupported countries, ut_phonen simply calls ut_alphan.
2752 my( $self, $field, $country ) = @_;
2753 return $self->ut_alphan($field) unless defined $country;
2754 my $phonen = $self->getfield($field);
2755 if ( $phonen eq '' ) {
2756 $self->setfield($field,'');
2757 } elsif ( $country eq 'US' || $country eq 'CA' ) {
2759 $phonen = $conf->config('cust_main-default_areacode').$phonen
2760 if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2761 $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2762 or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2763 $phonen = "$1-$2-$3";
2764 $phonen .= " x$4" if $4;
2765 $self->setfield($field,$phonen);
2767 warn "warning: don't know how to check phone numbers for country $country";
2768 return $self->ut_textn($field);
2775 Check/untaint hexadecimal values.
2780 my($self, $field) = @_;
2781 $self->getfield($field) =~ /^([\da-fA-F]+)$/
2782 or return "Illegal (hex) $field: ". $self->getfield($field);
2783 $self->setfield($field, uc($1));
2787 =item ut_hexn COLUMN
2789 Check/untaint hexadecimal values. May be null.
2794 my($self, $field) = @_;
2795 $self->getfield($field) =~ /^([\da-fA-F]*)$/
2796 or return "Illegal (hex) $field: ". $self->getfield($field);
2797 $self->setfield($field, uc($1));
2801 =item ut_mac_addr COLUMN
2803 Check/untaint mac addresses. May be null.
2808 my($self, $field) = @_;
2810 my $mac = $self->get($field);
2813 $self->set($field, $mac);
2815 my $e = $self->ut_hex($field);
2818 return "Illegal (mac address) $field: ". $self->getfield($field)
2819 unless length($self->getfield($field)) == 12;
2825 =item ut_mac_addrn COLUMN
2827 Check/untaint mac addresses. May be null.
2832 my($self, $field) = @_;
2833 ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2838 Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
2844 my( $self, $field ) = @_;
2845 $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2846 $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2847 or return "Illegal (IP address) $field: ". $self->getfield($field);
2848 for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2849 $self->setfield($field, "$1.$2.$3.$4");
2855 Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
2856 to 127.0.0.1. May be null.
2861 my( $self, $field ) = @_;
2862 if ( $self->getfield($field) =~ /^()$/ ) {
2863 $self->setfield($field,'');
2866 $self->ut_ip($field);
2870 =item ut_ip46 COLUMN
2872 Check/untaint IPv4 or IPv6 address.
2877 my( $self, $field ) = @_;
2878 my $ip = NetAddr::IP->new($self->getfield($field))
2879 or return "Illegal (IP address) $field: ".$self->getfield($field);
2880 $self->setfield($field, lc($ip->addr));
2886 Check/untaint IPv6 or IPv6 address. May be null.
2891 my( $self, $field ) = @_;
2892 if ( $self->getfield($field) =~ /^$/ ) {
2893 $self->setfield($field, '');
2896 $self->ut_ip46($field);
2899 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2901 Check/untaint coordinates.
2902 Accepts the following forms:
2912 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2913 The latter form (that is, the MMM are thousands of minutes) is
2914 assumed if the "MMM" is exactly three digits or two digits > 59.
2916 To be safe, just use the DDD.DDDDD form.
2918 If LOWER or UPPER are specified, then the coordinate is checked
2919 for lower and upper bounds, respectively.
2924 my ($self, $field) = (shift, shift);
2927 if ( $field =~ /latitude/ ) {
2928 $lower = $lat_lower;
2930 } elsif ( $field =~ /longitude/ ) {
2932 $upper = $lon_upper;
2935 my $coord = $self->getfield($field);
2936 my $neg = $coord =~ s/^(-)//;
2938 # ignore degree symbol at the end,
2939 # but not otherwise supporting degree/minutes/seconds symbols
2940 $coord =~ s/\N{DEGREE SIGN}\s*$//;
2942 my ($d, $m, $s) = (0, 0, 0);
2945 (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2946 (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2947 (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2949 $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2952 return "Invalid (coordinate with minutes > 59) $field: "
2953 . $self->getfield($field);
2956 $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2958 if (defined($lower) and ($coord < $lower)) {
2959 return "Invalid (coordinate < $lower) $field: "
2960 . $self->getfield($field);;
2963 if (defined($upper) and ($coord > $upper)) {
2964 return "Invalid (coordinate > $upper) $field: "
2965 . $self->getfield($field);;
2968 $self->setfield($field, $coord);
2972 return "Invalid (coordinate) $field: " . $self->getfield($field);
2976 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2978 Same as ut_coord, except optionally null.
2984 my ($self, $field) = (shift, shift);
2986 if ($self->getfield($field) =~ /^\s*$/) {
2989 return $self->ut_coord($field, @_);
2994 =item ut_domain COLUMN
2996 Check/untaint host and domain names. May not be null.
3001 my( $self, $field ) = @_;
3002 #$self->getfield($field) =~/^(\w+\.)*\w+$/
3003 $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
3004 or return "Illegal (hostname) $field: ". $self->getfield($field);
3005 $self->setfield($field,$1);
3009 =item ut_domainn COLUMN
3011 Check/untaint host and domain names. May be null.
3016 my( $self, $field ) = @_;
3017 if ( $self->getfield($field) =~ /^()$/ ) {
3018 $self->setfield($field,'');
3021 $self->ut_domain($field);
3025 =item ut_name COLUMN
3027 Check/untaint proper names; allows alphanumerics, spaces and the following
3028 punctuation: , . - '
3035 my( $self, $field ) = @_;
3036 $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
3037 or return gettext('illegal_name'). " $field: ". $self->getfield($field);
3042 $self->setfield($field, $name);
3046 =item ut_namen COLUMN
3048 Check/untaint proper names; allows alphanumerics, spaces and the following
3049 punctuation: , . - '
3056 my( $self, $field ) = @_;
3057 return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
3058 $self->ut_name($field);
3063 Check/untaint zip codes.
3067 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
3070 my( $self, $field, $country ) = @_;
3072 if ( $country eq 'US' ) {
3074 $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
3075 or return gettext('illegal_zip'). " $field for country $country: ".
3076 $self->getfield($field);
3077 $self->setfield($field, $1);
3079 } elsif ( $country eq 'CA' ) {
3081 $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
3082 or return gettext('illegal_zip'). " $field for country $country: ".
3083 $self->getfield($field);
3084 $self->setfield($field, "$1 $2");
3086 } elsif ( $country eq 'AU' ) {
3088 $self->getfield($field) =~ /^\s*(\d{4})\s*$/
3089 or return gettext('illegal_zip'). " $field for country $country: ".
3090 $self->getfield($field);
3091 $self->setfield($field, $1);
3095 if ( $self->getfield($field) =~ /^\s*$/
3096 && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
3099 $self->setfield($field,'');
3101 $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
3102 or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
3103 $self->setfield($field,$1);
3111 =item ut_country COLUMN
3113 Check/untaint country codes. Country names are changed to codes, if possible -
3114 see L<Locale::Country>.
3119 my( $self, $field ) = @_;
3120 unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
3121 if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
3122 && country2code($1) ) {
3123 $self->setfield($field,uc(country2code($1)));
3126 $self->getfield($field) =~ /^(\w\w)$/
3127 or return "Illegal (country) $field: ". $self->getfield($field);
3128 $self->setfield($field,uc($1));
3132 =item ut_anything COLUMN
3134 Untaints arbitrary data. Be careful.
3139 my( $self, $field ) = @_;
3140 $self->getfield($field) =~ /^(.*)$/s
3141 or return "Illegal $field: ". $self->getfield($field);
3142 $self->setfield($field,$1);
3146 =item ut_enum COLUMN CHOICES_ARRAYREF
3148 Check/untaint a column, supplying all possible choices, like the "enum" type.
3153 my( $self, $field, $choices ) = @_;
3154 foreach my $choice ( @$choices ) {
3155 if ( $self->getfield($field) eq $choice ) {
3156 $self->setfield($field, $choice);
3160 return "Illegal (enum) field $field: ". $self->getfield($field);
3163 =item ut_enumn COLUMN CHOICES_ARRAYREF
3165 Like ut_enum, except the null value is also allowed.
3170 my( $self, $field, $choices ) = @_;
3171 $self->getfield($field)
3172 ? $self->ut_enum($field, $choices)
3176 =item ut_flag COLUMN
3178 Check/untaint a column if it contains either an empty string or 'Y'. This
3179 is the standard form for boolean flags in Freeside.
3184 my( $self, $field ) = @_;
3185 my $value = uc($self->getfield($field));
3186 if ( $value eq '' or $value eq 'Y' ) {
3187 $self->setfield($field, $value);
3190 return "Illegal (flag) field $field: $value";
3193 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3195 Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
3196 on the column first.
3200 sub ut_foreign_key {
3201 my( $self, $field, $table, $foreign ) = @_;
3202 return $self->ut_number($field) if $no_check_foreign;
3203 qsearchs($table, { $foreign => $self->getfield($field) })
3204 or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
3205 " in $table.$foreign";
3209 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3211 Like ut_foreign_key, except the null value is also allowed.
3215 sub ut_foreign_keyn {
3216 my( $self, $field, $table, $foreign ) = @_;
3217 $self->getfield($field)
3218 ? $self->ut_foreign_key($field, $table, $foreign)
3222 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
3224 Checks this column as an agentnum, taking into account the current users's
3225 ACLs. NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
3226 right or rights allowing no agentnum.
3230 sub ut_agentnum_acl {
3231 my( $self, $field ) = (shift, shift);
3232 my $null_acl = scalar(@_) ? shift : [];
3233 $null_acl = [ $null_acl ] unless ref($null_acl);
3235 my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
3236 return "Illegal agentnum: $error" if $error;
3238 my $curuser = $FS::CurrentUser::CurrentUser;
3240 if ( $self->$field() ) {
3242 return 'Access denied to agent '. $self->$field()
3243 unless $curuser->agentnum($self->$field());
3247 return 'Access denied to global'
3248 unless grep $curuser->access_right($_), @$null_acl;
3256 =item trim_whitespace FIELD[, FIELD ... ]
3258 Strip leading and trailing spaces from the value in the named FIELD(s).
3262 sub trim_whitespace {
3264 foreach my $field (@_) {
3265 my $value = $self->get($field);
3268 $self->set($field, $value);
3272 =item fields [ TABLE ]
3274 This is a wrapper for real_fields. Code that called
3275 fields before should probably continue to call fields.
3280 my $something = shift;
3282 if($something->isa('FS::Record')) {
3283 $table = $something->table;
3285 $table = $something;
3286 #$something = "FS::$table";
3288 return (real_fields($table));
3292 =item encrypt($value)
3294 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
3296 Returns the encrypted string.
3298 You should generally not have to worry about calling this, as the system handles this for you.
3303 my ($self, $value) = @_;
3304 my $encrypted = $value;
3306 if ($conf_encryption) {
3307 if ($self->is_encrypted($value)) {
3308 # Return the original value if it isn't plaintext.
3309 $encrypted = $value;
3312 if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
3313 # RSA doesn't like the empty string so let's pack it up
3314 # The database doesn't like the RSA data so uuencode it
3315 my $length = length($value)+1;
3316 $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
3318 die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
3325 =item is_encrypted($value)
3327 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
3333 my ($self, $value) = @_;
3334 # could be more precise about it, but this will do for now
3335 $value =~ /^M/ && length($value) > 80;
3338 =item decrypt($value)
3340 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
3342 You should generally not have to worry about calling this, as the system handles this for you.
3347 my ($self,$value) = @_;
3348 my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
3349 if ($conf_encryption && $self->is_encrypted($value)) {
3351 if (ref($rsa_decrypt) =~ /::RSA/) {
3352 my $encrypted = unpack ("u*", $value);
3353 $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
3354 if ($@) {warn "Decryption Failed"};
3363 my $rsa_module = $conf_encryptionmodule || 'Crypt::OpenSSL::RSA';
3365 # Initialize Encryption
3366 if ($conf_encryptionpublickey && $conf_encryptionpublickey ne '') {
3367 $rsa_encrypt = $rsa_module->new_public_key($conf_encryptionpublickey);
3370 # Intitalize Decryption
3371 if ($conf_encryptionprivatekey && $conf_encryptionprivatekey ne '') {
3372 $rsa_decrypt = $rsa_module->new_private_key($conf_encryptionprivatekey);
3376 =item h_search ACTION
3378 Given an ACTION, either "insert", or "delete", returns the appropriate history
3379 record corresponding to this record, if any.
3384 my( $self, $action ) = @_;
3386 my $table = $self->table;
3389 my $primary_key = dbdef->table($table)->primary_key;
3392 'table' => "h_$table",
3393 'hashref' => { $primary_key => $self->$primary_key(),
3394 'history_action' => $action,
3402 Given an ACTION, either "insert", or "delete", returns the timestamp of the
3403 appropriate history record corresponding to this record, if any.
3408 my($self, $action) = @_;
3409 my $h = $self->h_search($action);
3410 $h ? $h->history_date : '';
3413 =item scalar_sql SQL [ PLACEHOLDER, ... ]
3415 A class or object method. Executes the sql statement represented by SQL and
3416 returns a scalar representing the result: the first column of the first row.
3418 Dies on bogus SQL. Returns an empty string if no row is returned.
3420 Typically used for statments which return a single value such as "SELECT
3421 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
3426 my($self, $sql) = (shift, shift);
3427 my $sth = dbh->prepare($sql) or die dbh->errstr;
3429 or die "Unexpected error executing statement $sql: ". $sth->errstr;
3430 my $row = $sth->fetchrow_arrayref or return '';
3431 my $scalar = $row->[0];
3432 defined($scalar) ? $scalar : '';
3435 =item count [ WHERE [, PLACEHOLDER ...] ]
3437 Convenience method for the common case of "SELECT COUNT(*) FROM table",
3438 with optional WHERE. Must be called as method on a class with an
3444 my($self, $where) = (shift, shift);
3445 my $table = $self->table or die 'count called on object of class '.ref($self);
3446 my $sql = "SELECT COUNT(*) FROM $table";
3447 $sql .= " WHERE $where" if $where;
3448 $self->scalar_sql($sql, @_);
3451 =item row_exists [ WHERE [, PLACEHOLDER ...] ]
3453 Convenience method for the common case of "SELECT 1 FROM table ... LIMIT 1"
3454 with optional (but almost always needed) WHERE.
3459 my($self, $where) = (shift, shift);
3460 my $table = $self->table or die 'row_exists called on object of class '.ref($self);
3461 my $sql = "SELECT 1 FROM $table";
3462 $sql .= " WHERE $where" if $where;
3464 $self->scalar_sql($sql, @_);
3473 =item real_fields [ TABLE ]
3475 Returns a list of the real columns in the specified table. Called only by
3476 fields() and other subroutines elsewhere in FS::Record.
3483 my($table_obj) = dbdef->table($table);
3484 confess "Unknown table $table" unless $table_obj;
3485 $table_obj->columns;
3488 =item pvf FIELD_NAME
3490 Returns the FS::part_virtual_field object corresponding to a field in the
3491 record (specified by FIELD_NAME).
3496 my ($self, $name) = (shift, shift);
3498 if(grep /^$name$/, $self->virtual_fields) {
3500 my $concat = [ "'cf_'", "name" ];
3501 return qsearchs({ table => 'part_virtual_field',
3502 hashref => { dbtable => $self->table,
3505 select => 'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
3511 =item _quote VALUE, TABLE, COLUMN
3513 This is an internal function used to construct SQL statements. It returns
3514 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3515 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3520 my($value, $table, $column) = @_;
3521 my $column_obj = dbdef->table($table)->column($column);
3522 my $column_type = $column_obj->type;
3523 my $nullable = $column_obj->null;
3525 utf8::upgrade($value);
3527 warn " $table.$column: $value ($column_type".
3528 ( $nullable ? ' NULL' : ' NOT NULL' ).
3529 ")\n" if $DEBUG > 2;
3531 if ( $value eq '' && $nullable ) {
3533 } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3534 cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3537 } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3538 ! $column_type =~ /(char|binary|text)$/i ) {
3540 } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3541 && driver_name eq 'Pg'
3544 dbh->quote($value, { pg_type => PG_BYTEA() });
3552 This is deprecated. Don't use it.
3554 It returns a hash-type list with the fields of this record's table set true.
3559 carp "warning: hfields is deprecated";
3562 foreach (fields($table)) {
3571 "$_: ". $self->getfield($_). "|"
3572 } (fields($self->table)) );
3575 sub DESTROY { return; }
3579 # #use Carp qw(cluck);
3580 # #cluck "DESTROYING $self";
3581 # warn "DESTROYING $self";
3585 # return ! eval { join('',@_), kill 0; 1; };
3588 =item str2time_sql [ DRIVER_NAME ]
3590 Returns a function to convert to unix time based on database type, such as
3591 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql. See
3592 the str2time_sql_closing method to return a closing string rather than just
3593 using a closing parenthesis as previously suggested.
3595 You can pass an optional driver name such as "Pg", "mysql" or
3596 $dbh->{Driver}->{Name} to return a function for that database instead of
3597 the current database.
3602 my $driver = shift || driver_name;
3604 return 'UNIX_TIMESTAMP(' if $driver =~ /^mysql/i;
3605 return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3607 warn "warning: unknown database type $driver; guessing how to convert ".
3608 "dates to UNIX timestamps";
3609 return 'EXTRACT(EPOCH FROM ';
3613 =item str2time_sql_closing [ DRIVER_NAME ]
3615 Returns the closing suffix of a function to convert to unix time based on
3616 database type, such as ")::integer" for Pg or ")" for mysql.
3618 You can pass an optional driver name such as "Pg", "mysql" or
3619 $dbh->{Driver}->{Name} to return a function for that database instead of
3620 the current database.
3624 sub str2time_sql_closing {
3625 my $driver = shift || driver_name;
3627 return ' )::INTEGER ' if $driver =~ /^Pg/i;
3631 =item regexp_sql [ DRIVER_NAME ]
3633 Returns the operator to do a regular expression comparison based on database
3634 type, such as '~' for Pg or 'REGEXP' for mysql.
3636 You can pass an optional driver name such as "Pg", "mysql" or
3637 $dbh->{Driver}->{Name} to return a function for that database instead of
3638 the current database.
3643 my $driver = shift || driver_name;
3645 return '~' if $driver =~ /^Pg/i;
3646 return 'REGEXP' if $driver =~ /^mysql/i;
3648 die "don't know how to use regular expressions in ". driver_name." databases";
3652 =item not_regexp_sql [ DRIVER_NAME ]
3654 Returns the operator to do a regular expression negation based on database
3655 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3657 You can pass an optional driver name such as "Pg", "mysql" or
3658 $dbh->{Driver}->{Name} to return a function for that database instead of
3659 the current database.
3663 sub not_regexp_sql {
3664 my $driver = shift || driver_name;
3666 return '!~' if $driver =~ /^Pg/i;
3667 return 'NOT REGEXP' if $driver =~ /^mysql/i;
3669 die "don't know how to use regular expressions in ". driver_name." databases";
3673 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3675 Returns the items concatenated based on database type, using "CONCAT()" for
3676 mysql and " || " for Pg and other databases.
3678 You can pass an optional driver name such as "Pg", "mysql" or
3679 $dbh->{Driver}->{Name} to return a function for that database instead of
3680 the current database.
3685 my $driver = ref($_[0]) ? driver_name : shift;
3688 if ( $driver =~ /^mysql/i ) {
3689 'CONCAT('. join(',', @$items). ')';
3691 join('||', @$items);
3696 =item group_concat_sql COLUMN, DELIMITER
3698 Returns an SQL expression to concatenate an aggregate column, using
3699 GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg.
3703 sub group_concat_sql {
3704 my ($col, $delim) = @_;
3705 $delim = dbh->quote($delim);
3706 if ( driver_name() =~ /^mysql/i ) {
3707 # DISTINCT(foo) is valid as $col
3708 return "GROUP_CONCAT($col SEPARATOR $delim)";
3710 return "array_to_string(array_agg($col), $delim)";
3714 =item midnight_sql DATE
3716 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3717 on that day in the system timezone, using the default driver name.
3722 my $driver = driver_name;
3724 if ( $driver =~ /^mysql/i ) {
3725 "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3728 "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3736 This module should probably be renamed, since much of the functionality is
3737 of general use. It is not completely unlike Adapter::DBI (see below).
3739 Exported qsearch and qsearchs should be deprecated in favor of method calls
3740 (against an FS::Record object like the old search and searchs that qsearch
3741 and qsearchs were on top of.)
3743 The whole fields / hfields mess should be removed.
3745 The various WHERE clauses should be subroutined.
3747 table string should be deprecated in favor of DBIx::DBSchema::Table.
3749 No doubt we could benefit from a Tied hash. Documenting how exists / defined
3750 true maps to the database (and WHERE clauses) would also help.
3752 The ut_ methods should ask the dbdef for a default length.
3754 ut_sqltype (like ut_varchar) should all be defined
3756 A fallback check method should be provided which uses the dbdef.
3758 The ut_money method assumes money has two decimal digits.
3760 The Pg money kludge in the new method only strips `$'.
3762 The ut_phonen method only checks US-style phone numbers.
3764 The _quote function should probably use ut_float instead of a regex.
3766 All the subroutines probably should be methods, here or elsewhere.
3768 Probably should borrow/use some dbdef methods where appropriate (like sub
3771 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3772 or allow it to be set. Working around it is ugly any way around - DBI should
3773 be fixed. (only affects RDBMS which return uppercase column names)
3775 ut_zip should take an optional country like ut_phone.
3779 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3781 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.