2 use base qw( Exporter );
6 %virtual_fields_cache %fk_method_cache
7 $money_char $lat_lower $lon_upper
9 use Carp qw(carp cluck croak confess);
10 use Scalar::Util qw( blessed );
11 use File::Slurp qw( slurp );
12 use File::CounterFile;
14 use DBI qw(:sql_types);
15 use DBIx::DBSchema 0.43; #0.43 for foreign keys
18 use NetAddr::IP; # for validation
19 use FS::UID qw(dbh datasrc driver_name);
21 use FS::Schema qw(dbdef);
23 use FS::Msgcat qw(gettext);
24 #use FS::Conf; #dependency loop bs, in install_callback below instead
26 use FS::part_virtual_field;
30 our @encrypt_payby = qw( CARD DCRD CHEK DCHK );
32 #export dbdef for now... everything else expects to find it here
34 dbh fields hfields qsearch qsearchs dbdef jsearch
35 str2time_sql str2time_sql_closing regexp_sql not_regexp_sql concat_sql
40 our $me = '[FS::Record]';
42 our $nowarn_identical = 0;
43 our $nowarn_classload = 0;
44 our $no_update_diff = 0;
47 our $no_check_foreign = 1; #well, not inefficiently in perl by default anymore
55 our $conf_encryption = '';
56 FS::UID->install_callback( sub {
60 $conf = FS::Conf->new;
61 $conf_encryption = $conf->exists('encryption');
62 $money_char = $conf->config('money_char') || '$';
63 my $nw_coords = $conf->exists('geocode-require_nw_coordinates');
64 $lat_lower = $nw_coords ? 1 : -90;
65 $lon_upper = $nw_coords ? -1 : 180;
67 $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
69 if ( driver_name eq 'Pg' ) {
70 eval "use DBD::Pg ':pg_types'";
73 eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }";
76 foreach my $table ( dbdef->tables ) {
77 $fk_method_cache{$table} = fk_methods($table);
84 FS::Record - Database record objects
89 use FS::Record qw(dbh fields qsearch qsearchs);
91 $record = new FS::Record 'table', \%hash;
92 $record = new FS::Record 'table', { 'column' => 'value', ... };
94 $record = qsearchs FS::Record 'table', \%hash;
95 $record = qsearchs FS::Record 'table', { 'column' => 'value', ... };
96 @records = qsearch FS::Record 'table', \%hash;
97 @records = qsearch FS::Record 'table', { 'column' => 'value', ... };
99 $table = $record->table;
100 $dbdef_table = $record->dbdef_table;
102 $value = $record->get('column');
103 $value = $record->getfield('column');
104 $value = $record->column;
106 $record->set( 'column' => 'value' );
107 $record->setfield( 'column' => 'value' );
108 $record->column('value');
110 %hash = $record->hash;
112 $hashref = $record->hashref;
114 $error = $record->insert;
116 $error = $record->delete;
118 $error = $new_record->replace($old_record);
120 # external use deprecated - handled by the database (at least for Pg, mysql)
121 $value = $record->unique('column');
123 $error = $record->ut_float('column');
124 $error = $record->ut_floatn('column');
125 $error = $record->ut_number('column');
126 $error = $record->ut_numbern('column');
127 $error = $record->ut_snumber('column');
128 $error = $record->ut_snumbern('column');
129 $error = $record->ut_money('column');
130 $error = $record->ut_text('column');
131 $error = $record->ut_textn('column');
132 $error = $record->ut_alpha('column');
133 $error = $record->ut_alphan('column');
134 $error = $record->ut_phonen('column');
135 $error = $record->ut_anything('column');
136 $error = $record->ut_name('column');
138 $quoted_value = _quote($value,'table','field');
141 $fields = hfields('table');
142 if ( $fields->{Field} ) { # etc.
144 @fields = fields 'table'; #as a subroutine
145 @fields = $record->fields; #as a method call
150 (Mostly) object-oriented interface to database records. Records are currently
151 implemented on top of DBI. FS::Record is intended as a base class for
152 table-specific classes to inherit from, i.e. FS::cust_main.
158 =item new [ TABLE, ] HASHREF
160 Creates a new record. It doesn't store it in the database, though. See
161 L<"insert"> for that.
163 Note that the object stores this hash reference, not a distinct copy of the
164 hash it points to. You can ask the object for a copy with the I<hash>
167 TABLE can only be omitted when a dervived class overrides the table method.
173 my $class = ref($proto) || $proto;
175 bless ($self, $class);
177 unless ( defined ( $self->table ) ) {
178 $self->{'Table'} = shift;
179 carp "warning: FS::Record::new called with table name ". $self->{'Table'}
180 unless $nowarn_classload;
183 $self->{'Hash'} = shift;
185 foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
186 $self->{'Hash'}{$field}='';
189 $self->_rebless if $self->can('_rebless');
191 $self->{'modified'} = 0;
193 $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
200 my $class = ref($proto) || $proto;
202 bless ($self, $class);
204 $self->{'Table'} = shift unless defined ( $self->table );
206 my $hashref = $self->{'Hash'} = shift;
208 if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
209 my $obj = $cache->cache->{$hashref->{$cache->key}};
210 $obj->_cache($hashref, $cache) if $obj->can('_cache');
213 $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
220 my $class = ref($proto) || $proto;
222 bless ($self, $class);
223 if ( defined $self->table ) {
224 cluck "create constructor is deprecated, use new!";
227 croak "FS::Record::create called (not from a subclass)!";
231 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
233 Searches the database for all records matching (at least) the key/value pairs
234 in HASHREF. Returns all the records found as `FS::TABLE' objects if that
235 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
238 The preferred usage is to pass a hash reference of named parameters:
240 @records = qsearch( {
241 'table' => 'table_name',
242 'hashref' => { 'field' => 'value'
243 'field' => { 'op' => '<',
248 #these are optional...
250 'extra_sql' => 'AND field = ? AND intfield = ?',
251 'extra_param' => [ 'value', [ 5, 'int' ] ],
252 'order_by' => 'ORDER BY something',
253 #'cache_obj' => '', #optional
254 'addl_from' => 'LEFT JOIN othtable USING ( field )',
259 Much code still uses old-style positional parameters, this is also probably
260 fine in the common case where there are only two parameters:
262 my @records = qsearch( 'table', { 'field' => 'value' } );
264 Also possible is an experimental LISTREF of PARAMS_HASHREFs for a UNION of
265 the individual PARAMS_HASHREF queries
267 ###oops, argh, FS::Record::new only lets us create database fields.
268 #Normal behaviour if SELECT is not specified is `*', as in
269 #C<SELECT * FROM table WHERE ...>. However, there is an experimental new
270 #feature where you can specify SELECT - remember, the objects returned,
271 #although blessed into the appropriate `FS::TABLE' package, will only have the
272 #fields you specify. This might have unwanted results if you then go calling
273 #regular FS::TABLE methods
278 my %TYPE = (); #for debugging
281 my($type, $value) = @_;
283 my $bind_type = { TYPE => SQL_VARCHAR };
285 if ( $type =~ /(big)?(int|serial)/i && $value =~ /^-?\d+(\.\d+)?$/ ) {
287 $bind_type = { TYPE => SQL_INTEGER };
289 } elsif ( $type =~ /^bytea$/i || $type =~ /(blob|varbinary)/i ) {
291 if ( driver_name eq 'Pg' ) {
293 $bind_type = { pg_type => PG_BYTEA };
295 # $bind_type = ? #SQL_VARCHAR could be fine?
298 #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT
299 #fixed by DBD::Pg 2.11.8
300 #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded
301 #(make a Tron test first)
302 } elsif ( _is_fs_float( $type, $value ) ) {
304 $bind_type = { TYPE => SQL_DECIMAL };
313 my($type, $value) = @_;
314 if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) ||
315 ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/)
323 my( @stable, @record, @cache );
324 my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
326 my %union_options = ();
327 if ( ref($_[0]) eq 'ARRAY' ) {
330 foreach my $href ( @$optlist ) {
331 push @stable, ( $href->{'table'} or die "table name is required" );
332 push @record, ( $href->{'hashref'} || {} );
333 push @select, ( $href->{'select'} || '*' );
334 push @extra_sql, ( $href->{'extra_sql'} || '' );
335 push @extra_param, ( $href->{'extra_param'} || [] );
336 push @order_by, ( $href->{'order_by'} || '' );
337 push @cache, ( $href->{'cache_obj'} || '' );
338 push @addl_from, ( $href->{'addl_from'} || '' );
339 push @debug, ( $href->{'debug'} || '' );
341 die "at least one hashref is required" unless scalar(@stable);
342 } elsif ( ref($_[0]) eq 'HASH' ) {
344 $stable[0] = $opt->{'table'} or die "table name is required";
345 $record[0] = $opt->{'hashref'} || {};
346 $select[0] = $opt->{'select'} || '*';
347 $extra_sql[0] = $opt->{'extra_sql'} || '';
348 $extra_param[0] = $opt->{'extra_param'} || [];
349 $order_by[0] = $opt->{'order_by'} || '';
350 $cache[0] = $opt->{'cache_obj'} || '';
351 $addl_from[0] = $opt->{'addl_from'} || '';
352 $debug[0] = $opt->{'debug'} || '';
363 my $cache = $cache[0];
369 foreach my $stable ( @stable ) {
371 carp '->qsearch on cust_main called' if $stable eq 'cust_main' && $DEBUG;
373 #stop altering the caller's hashref
374 my $record = { %{ shift(@record) || {} } };#and be liberal in receipt
375 my $select = shift @select;
376 my $extra_sql = shift @extra_sql;
377 my $extra_param = shift @extra_param;
378 my $order_by = shift @order_by;
379 my $cache = shift @cache;
380 my $addl_from = shift @addl_from;
381 my $debug = shift @debug;
383 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
385 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
388 my $table = $cache ? $cache->table : $stable;
389 my $dbdef_table = dbdef->table($table)
390 or die "No schema for table $table found - ".
391 "do you need to run freeside-upgrade?";
392 my $pkey = $dbdef_table->primary_key;
394 my @real_fields = grep exists($record->{$_}), real_fields($table);
396 my $statement .= "SELECT $select FROM $stable";
397 $statement .= " $addl_from" if $addl_from;
398 if ( @real_fields ) {
399 $statement .= ' WHERE '. join(' AND ',
400 get_real_fields($table, $record, \@real_fields));
403 $statement .= " $extra_sql" if defined($extra_sql);
404 $statement .= " $order_by" if defined($order_by);
406 push @statement, $statement;
408 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
412 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
415 my $value = $record->{$field};
416 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
417 $value = $value->{'value'} if ref($value);
418 my $type = dbdef->table($table)->column($field)->type;
420 my $bind_type = _bind_type($type, $value);
424 # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
426 # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
430 push @bind_type, $bind_type;
434 foreach my $param ( @$extra_param ) {
435 my $bind_type = { TYPE => SQL_VARCHAR };
438 $value = $param->[0];
439 my $type = $param->[1];
440 $bind_type = _bind_type($type, $value);
443 push @bind_type, $bind_type;
447 my $statement = join( ' ) UNION ( ', @statement );
448 $statement = "( $statement )" if scalar(@statement) > 1;
449 $statement .= " $union_options{order_by}" if $union_options{order_by};
451 my $sth = $dbh->prepare($statement)
452 or croak "$dbh->errstr doing $statement";
455 foreach my $value ( @value ) {
456 my $bind_type = shift @bind_type;
457 $sth->bind_param($bind++, $value, $bind_type );
460 # $sth->execute( map $record->{$_},
461 # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
462 # ) or croak "Error executing \"$statement\": ". $sth->errstr;
464 my $ok = $sth->execute;
466 my $error = "Error executing \"$statement\"";
467 $error .= ' (' . join(', ', map {"'$_'"} @value) . ')' if @value;
468 $error .= ': '. $sth->errstr;
472 my $table = $stable[0];
474 $table = '' if grep { $_ ne $table } @stable;
475 $pkey = dbdef->table($table)->primary_key if $table;
478 tie %result, "Tie::IxHash";
479 my @stuff = @{ $sth->fetchall_arrayref( {} ) };
480 if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
481 %result = map { $_->{$pkey}, $_ } @stuff;
483 @result{@stuff} = @stuff;
489 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
490 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
491 #derivied class didn't override new method, so this optimization is safe
494 new_or_cached( "FS::$table", { %{$_} }, $cache )
498 new( "FS::$table", { %{$_} } )
502 #okay, its been tested
503 # warn "untested code (class FS::$table uses custom new method)";
505 eval 'FS::'. $table. '->new( { %{$_} } )';
509 # Check for encrypted fields and decrypt them.
510 ## only in the local copy, not the cached object
511 if ( $conf_encryption
512 && eval '@FS::'. $table . '::encrypted_fields' ) {
513 foreach my $record (@return) {
514 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
515 next if $field eq 'payinfo'
516 && ($record->isa('FS::payinfo_transaction_Mixin')
517 || $record->isa('FS::payinfo_Mixin') )
519 && !grep { $record->payby eq $_ } @encrypt_payby;
520 # Set it directly... This may cause a problem in the future...
521 $record->setfield($field, $record->decrypt($record->getfield($field)));
526 cluck "warning: FS::$table not loaded; returning FS::Record objects"
527 unless $nowarn_classload;
529 FS::Record->new( $table, { %{$_} } );
537 Construct the SQL statement and parameter-binding list for qsearch. Takes
538 the qsearch parameters.
540 Returns a hash containing:
541 'table': The primary table name (if there is one).
542 'statement': The SQL statement itself.
543 'bind_type': An arrayref of bind types.
544 'value': An arrayref of parameter values.
545 'cache': The cache object, if one was passed.
550 my( @stable, @record, @cache );
551 my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
554 my %union_options = ();
555 if ( ref($_[0]) eq 'ARRAY' ) {
558 foreach my $href ( @$optlist ) {
559 push @stable, ( $href->{'table'} or die "table name is required" );
560 push @record, ( $href->{'hashref'} || {} );
561 push @select, ( $href->{'select'} || '*' );
562 push @extra_sql, ( $href->{'extra_sql'} || '' );
563 push @extra_param, ( $href->{'extra_param'} || [] );
564 push @order_by, ( $href->{'order_by'} || '' );
565 push @cache, ( $href->{'cache_obj'} || '' );
566 push @addl_from, ( $href->{'addl_from'} || '' );
567 push @debug, ( $href->{'debug'} || '' );
569 die "at least one hashref is required" unless scalar(@stable);
570 } elsif ( ref($_[0]) eq 'HASH' ) {
572 $stable[0] = $opt->{'table'} or die "table name is required";
573 $record[0] = $opt->{'hashref'} || {};
574 $select[0] = $opt->{'select'} || '*';
575 $extra_sql[0] = $opt->{'extra_sql'} || '';
576 $extra_param[0] = $opt->{'extra_param'} || [];
577 $order_by[0] = $opt->{'order_by'} || '';
578 $cache[0] = $opt->{'cache_obj'} || '';
579 $addl_from[0] = $opt->{'addl_from'} || '';
580 $debug[0] = $opt->{'debug'} || '';
591 my $cache = $cache[0];
597 my $result_table = $stable[0];
598 foreach my $stable ( @stable ) {
599 #stop altering the caller's hashref
600 my $record = { %{ shift(@record) || {} } };#and be liberal in receipt
601 my $select = shift @select;
602 my $extra_sql = shift @extra_sql;
603 my $extra_param = shift @extra_param;
604 my $order_by = shift @order_by;
605 my $cache = shift @cache;
606 my $addl_from = shift @addl_from;
607 my $debug = shift @debug;
609 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
611 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
614 $result_table = '' if $result_table ne $stable;
616 my $table = $cache ? $cache->table : $stable;
617 my $dbdef_table = dbdef->table($table)
618 or die "No schema for table $table found - ".
619 "do you need to run freeside-upgrade?";
620 my $pkey = $dbdef_table->primary_key;
622 my @real_fields = grep exists($record->{$_}), real_fields($table);
624 my $statement .= "SELECT $select FROM $stable";
625 $statement .= " $addl_from" if $addl_from;
626 if ( @real_fields ) {
627 $statement .= ' WHERE '. join(' AND ',
628 get_real_fields($table, $record, \@real_fields));
631 $statement .= " $extra_sql" if defined($extra_sql);
632 $statement .= " $order_by" if defined($order_by);
634 push @statement, $statement;
636 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
640 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
643 my $value = $record->{$field};
644 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
645 $value = $value->{'value'} if ref($value);
646 my $type = dbdef->table($table)->column($field)->type;
648 my $bind_type = _bind_type($type, $value);
652 # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
654 # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
658 push @bind_type, $bind_type;
662 foreach my $param ( @$extra_param ) {
663 my $bind_type = { TYPE => SQL_VARCHAR };
666 $value = $param->[0];
667 my $type = $param->[1];
668 $bind_type = _bind_type($type, $value);
671 push @bind_type, $bind_type;
675 my $statement = join( ' ) UNION ( ', @statement );
676 $statement = "( $statement )" if scalar(@statement) > 1;
677 $statement .= " $union_options{order_by}" if $union_options{order_by};
680 statement => $statement,
681 bind_type => \@bind_type,
683 table => $result_table,
688 # qsearch should eventually use this
690 my ($table, $cache, @hashrefs) = @_;
692 # XXX get rid of these string evals at some point
693 # (when we have time to test it)
694 # my $class = "FS::$table" if $table;
695 # if ( $class and $class->isa('FS::Record') )
696 # if ( $class->can('new') eq \&new )
698 if ( $table && eval 'scalar(@FS::'. $table. '::ISA);' ) {
699 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
700 #derivied class didn't override new method, so this optimization is safe
703 new_or_cached( "FS::$table", { %{$_} }, $cache )
707 new( "FS::$table", { %{$_} } )
711 #okay, its been tested
712 # warn "untested code (class FS::$table uses custom new method)";
714 eval 'FS::'. $table. '->new( { %{$_} } )';
718 # Check for encrypted fields and decrypt them.
719 ## only in the local copy, not the cached object
720 if ( $conf_encryption
721 && eval '@FS::'. $table . '::encrypted_fields' ) {
722 foreach my $record (@return) {
723 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
724 next if $field eq 'payinfo'
725 && ($record->isa('FS::payinfo_transaction_Mixin')
726 || $record->isa('FS::payinfo_Mixin') )
728 && !grep { $record->payby eq $_ } @encrypt_payby;
729 # Set it directly... This may cause a problem in the future...
730 $record->setfield($field, $record->decrypt($record->getfield($field)));
735 cluck "warning: FS::$table not loaded; returning FS::Record objects"
736 unless $nowarn_classload;
738 FS::Record->new( $table, { %{$_} } );
744 ## makes this easier to read
746 sub get_real_fields {
749 my $real_fields = shift;
751 ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability
757 my $type = dbdef->table($table)->column($column)->type;
758 my $value = $record->{$column};
759 $value = $value->{'value'} if ref($value);
760 if ( ref($record->{$_}) ) {
761 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
762 #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
763 if ( uc($op) eq 'ILIKE' ) {
765 $record->{$_}{'value'} = lc($record->{$_}{'value'});
766 $column = "LOWER($_)";
768 $record->{$_} = $record->{$_}{'value'}
771 if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
773 if ( driver_name eq 'Pg' ) {
774 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
775 qq-( $column IS NULL )-;
777 qq-( $column IS NULL OR $column = '' )-;
780 qq-( $column IS NULL OR $column = "" )-;
782 } elsif ( $op eq '!=' ) {
783 if ( driver_name eq 'Pg' ) {
784 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
785 qq-( $column IS NOT NULL )-;
787 qq-( $column IS NOT NULL AND $column != '' )-;
790 qq-( $column IS NOT NULL AND $column != "" )-;
793 if ( driver_name eq 'Pg' ) {
794 qq-( $column $op '' )-;
796 qq-( $column $op "" )-;
799 } elsif ( $op eq '!=' ) {
800 qq-( $column IS NULL OR $column != ? )-;
801 #if this needs to be re-enabled, it needs to use a custom op like
802 #"APPROX=" or something (better name?, not '=', to avoid affecting other
804 #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
805 # ( "$column <= ?", "$column >= ?" );
809 } @{ $real_fields } );
812 =item by_key PRIMARY_KEY_VALUE
814 This is a class method that returns the record with the given primary key
815 value. This method is only useful in FS::Record subclasses. For example:
817 my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
821 my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
826 my ($class, $pkey_value) = @_;
828 my $table = $class->table
829 or croak "No table for $class found";
831 my $dbdef_table = dbdef->table($table)
832 or die "No schema for table $table found - ".
833 "do you need to create it or run dbdef-create?";
834 my $pkey = $dbdef_table->primary_key
835 or die "No primary key for table $table";
837 return qsearchs($table, { $pkey => $pkey_value });
840 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
842 Experimental JOINed search method. Using this method, you can execute a
843 single SELECT spanning multiple tables, and cache the results for subsequent
844 method calls. Interface will almost definately change in an incompatible
852 my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
853 my $cache = FS::SearchCache->new( $ptable, $pkey );
856 grep { !$saw{$_->getfield($pkey)}++ }
857 qsearch($table, $record, $select, $extra_sql, $cache )
861 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
863 Same as qsearch, except that if more than one record matches, it B<carp>s but
864 returns the first. If this happens, you either made a logic error in asking
865 for a single item, or your data is corrupted.
869 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
871 my(@result) = qsearch(@_);
872 cluck "warning: Multiple records in scalar search ($table)"
873 if scalar(@result) > 1;
874 #should warn more vehemently if the search was on a primary key?
875 scalar(@result) ? ($result[0]) : ();
886 Returns the table name.
891 # cluck "warning: FS::Record::table deprecated; supply one in subclass!";
898 Returns the DBIx::DBSchema::Table object for the table.
904 my($table)=$self->table;
905 dbdef->table($table);
910 Returns the primary key for the table.
916 my $pkey = $self->dbdef_table->primary_key;
919 =item get, getfield COLUMN
921 Returns the value of the column/field/key COLUMN.
926 my($self,$field) = @_;
927 # to avoid "Use of unitialized value" errors
928 if ( defined ( $self->{Hash}->{$field} ) ) {
929 $self->{Hash}->{$field};
939 =item set, setfield COLUMN, VALUE
941 Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE.
946 my($self,$field,$value) = @_;
947 $self->{'modified'} = 1;
948 $self->{'Hash'}->{$field} = $value;
957 Returns true if the column/field/key COLUMN exists.
962 my($self,$field) = @_;
963 exists($self->{Hash}->{$field});
966 =item AUTLOADED METHODS
968 $record->column is a synonym for $record->get('column');
970 $record->column('value') is a synonym for $record->set('column','value');
972 $record->foreign_table_name calls qsearchs and returns a single
973 FS::foreign_table record (for tables referenced by a column of this table) or
974 qsearch and returns an array of FS::foreign_table records (for tables
975 referenced by a column in the foreign table).
982 my($field)=$AUTOLOAD;
985 confess "errant AUTOLOAD $field for $self (arg $value)"
986 unless blessed($self) && $self->can('setfield');
988 #$fk_method_cache{$self->table} ||= fk_methods($self->table);
989 if ( exists($fk_method_cache{$self->table}->{$field}) ) {
991 my $fk_info = $fk_method_cache{$self->table}->{$field};
992 my $method = $fk_info->{method} || 'qsearchs';
993 my $table = $fk_info->{table} || $field;
994 my $column = $fk_info->{column};
995 my $foreign_column = $fk_info->{references} || $column;
997 eval "use FS::$table";
1000 carp '->cust_main called' if $table eq 'cust_main' && $DEBUG;
1002 my $pkey_value = $self->$column();
1003 my %search = ( $foreign_column => $pkey_value );
1005 # FS::Record->$method() ? they're actually just subs :/
1006 if ( $method eq 'qsearchs' ) {
1007 return $pkey_value ? qsearchs( $table, \%search ) : '';
1008 } elsif ( $method eq 'qsearch' ) {
1009 return $pkey_value ? qsearch( $table, \%search ) : ();
1011 die "unknown method $method";
1016 if ( defined($value) ) {
1017 $self->setfield($field,$value);
1019 $self->getfield($field);
1023 # efficient (also, old, doesn't support FK stuff)
1025 # my $field = $AUTOLOAD;
1026 # $field =~ s/.*://;
1027 # if ( defined($_[1]) ) {
1028 # $_[0]->setfield($field, $_[1]);
1030 # $_[0]->getfield($field);
1039 # foreign keys we reference in other tables
1040 foreach my $fk (dbdef->table($table)->foreign_keys) {
1043 if ( scalar( @{$fk->columns} ) == 1 ) {
1044 if ( ! @{$fk->references} || $fk->columns->[0] eq $fk->references->[0] ){
1045 $method = $fk->table;
1047 #some sort of hint in the table.pm or schema for methods not named
1048 # after their foreign table (well, not a whole lot different than
1049 # just providing a small subroutine...)
1053 $hash{$method} = { #fk_info
1054 'method' => 'qsearchs',
1055 'column' => $fk->columns->[0],
1056 #'references' => $fk->references->[0],
1064 # foreign keys referenced in other tables to us
1065 # (alas. why we're cached. still, might this loop better be done once at
1066 # schema load time insetad of every time we AUTOLOAD a method on a new
1068 foreach my $f_table ( dbdef->tables ) {
1069 foreach my $fk (dbdef->table($f_table)->foreign_keys) {
1071 next unless $fk->table eq $table;
1074 if ( scalar( @{$fk->columns} ) == 1 ) {
1075 if ( ! @{$fk->references} || $fk->columns->[0] eq $fk->references->[0] ){
1078 #some sort of hint in the table.pm or schema for methods not named
1079 # after their foreign table (well, not a whole lot different than
1080 # just providing a small subroutine...)
1084 $hash{$method} = { #fk_info
1085 'method' => 'qsearch',
1086 'column' => $fk->columns->[0], #references||column
1087 #'references' => $fk->column->[0],
1102 Returns a list of the column/value pairs, usually for assigning to a new hash.
1104 To make a distinct duplicate of an FS::Record object, you can do:
1106 $new = new FS::Record ( $old->table, { $old->hash } );
1112 confess $self. ' -> hash: Hash attribute is undefined'
1113 unless defined($self->{'Hash'});
1114 %{ $self->{'Hash'} };
1119 Returns a reference to the column/value hash. This may be deprecated in the
1120 future; if there's a reason you can't just use the autoloaded or get/set
1134 +{ ( map { $_=>$self->$_ } $self->fields ),
1139 my( $class, %opt ) = @_;
1140 my $table = $class->table;
1141 my $self = $class->new( { map { $_ => $opt{$_} } fields($table) } );
1142 my $error = $self->insert;
1143 return +{ 'error' => $error } if $error;
1144 my $pkey = $self->pkey;
1145 return +{ 'error' => '',
1146 'primary_key' => $pkey,
1147 $pkey => $self->$pkey,
1153 Returns true if any of this object's values have been modified with set (or via
1154 an autoloaded method). Doesn't yet recognize when you retreive a hashref and
1161 $self->{'modified'};
1164 =item select_for_update
1166 Selects this record with the SQL "FOR UPDATE" command. This can be useful as
1171 sub select_for_update {
1173 my $primary_key = $self->primary_key;
1176 'table' => $self->table,
1177 'hashref' => { $primary_key => $self->$primary_key() },
1178 'extra_sql' => 'FOR UPDATE',
1184 Locks this table with a database-driver specific lock method. This is used
1185 as a mutex in order to do a duplicate search.
1187 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
1189 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
1191 Errors are fatal; no useful return value.
1193 Note: To use this method for new tables other than svc_acct and svc_phone,
1194 edit freeside-upgrade and add those tables to the duplicate_lock list.
1200 my $table = $self->table;
1202 warn "$me locking $table table\n" if $DEBUG;
1204 if ( driver_name =~ /^Pg/i ) {
1206 dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
1209 } elsif ( driver_name =~ /^mysql/i ) {
1211 dbh->do("SELECT * FROM duplicate_lock
1212 WHERE lockname = '$table'
1214 ) or die dbh->errstr;
1218 die "unknown database ". driver_name. "; don't know how to lock table";
1222 warn "$me acquired $table table lock\n" if $DEBUG;
1228 Inserts this record to the database. If there is an error, returns the error,
1229 otherwise returns false.
1237 warn "$self -> insert" if $DEBUG;
1239 my $error = $self->check;
1240 return $error if $error;
1242 #single-field non-null unique keys are given a value if empty
1243 #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
1244 foreach ( $self->dbdef_table->unique_singles) {
1245 next if $self->getfield($_);
1246 next if $self->dbdef_table->column($_)->null eq 'NULL';
1250 #and also the primary key, if the database isn't going to
1251 my $primary_key = $self->dbdef_table->primary_key;
1253 if ( $primary_key ) {
1254 my $col = $self->dbdef_table->column($primary_key);
1257 uc($col->type) =~ /^(BIG)?SERIAL\d?/
1258 || ( driver_name eq 'Pg'
1259 && defined($col->default)
1260 && $col->quoted_default =~ /^nextval\(/i
1262 || ( driver_name eq 'mysql'
1263 && defined($col->local)
1264 && $col->local =~ /AUTO_INCREMENT/i
1266 $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
1269 my $table = $self->table;
1271 # Encrypt before the database
1272 if ( defined(eval '@FS::'. $table . '::encrypted_fields')
1273 && scalar( eval '@FS::'. $table . '::encrypted_fields')
1274 && $conf->exists('encryption')
1276 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
1277 next if $field eq 'payinfo'
1278 && ($self->isa('FS::payinfo_transaction_Mixin')
1279 || $self->isa('FS::payinfo_Mixin') )
1281 && !grep { $self->payby eq $_ } @encrypt_payby;
1282 $saved->{$field} = $self->getfield($field);
1283 $self->setfield($field, $self->encrypt($self->getfield($field)));
1287 #false laziness w/delete
1289 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1292 my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
1295 my $statement = "INSERT INTO $table ";
1296 if ( @real_fields ) {
1299 join( ', ', @real_fields ).
1301 join( ', ', @values ).
1305 $statement .= 'DEFAULT VALUES';
1307 warn "[debug]$me $statement\n" if $DEBUG > 1;
1308 my $sth = dbh->prepare($statement) or return dbh->errstr;
1310 local $SIG{HUP} = 'IGNORE';
1311 local $SIG{INT} = 'IGNORE';
1312 local $SIG{QUIT} = 'IGNORE';
1313 local $SIG{TERM} = 'IGNORE';
1314 local $SIG{TSTP} = 'IGNORE';
1315 local $SIG{PIPE} = 'IGNORE';
1317 $sth->execute or return $sth->errstr;
1319 # get inserted id from the database, if applicable & needed
1320 if ( $db_seq && ! $self->getfield($primary_key) ) {
1321 warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
1325 if ( driver_name eq 'Pg' ) {
1327 #my $oid = $sth->{'pg_oid_status'};
1328 #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
1330 my $default = $self->dbdef_table->column($primary_key)->quoted_default;
1331 unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
1332 dbh->rollback if $FS::UID::AutoCommit;
1333 return "can't parse $table.$primary_key default value".
1334 " for sequence name: $default";
1338 my $i_sql = "SELECT currval('$sequence')";
1339 my $i_sth = dbh->prepare($i_sql) or do {
1340 dbh->rollback if $FS::UID::AutoCommit;
1343 $i_sth->execute() or do { #$i_sth->execute($oid)
1344 dbh->rollback if $FS::UID::AutoCommit;
1345 return $i_sth->errstr;
1347 $insertid = $i_sth->fetchrow_arrayref->[0];
1349 } elsif ( driver_name eq 'mysql' ) {
1351 $insertid = dbh->{'mysql_insertid'};
1352 # work around mysql_insertid being null some of the time, ala RT :/
1353 unless ( $insertid ) {
1354 warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
1355 "using SELECT LAST_INSERT_ID();";
1356 my $i_sql = "SELECT LAST_INSERT_ID()";
1357 my $i_sth = dbh->prepare($i_sql) or do {
1358 dbh->rollback if $FS::UID::AutoCommit;
1361 $i_sth->execute or do {
1362 dbh->rollback if $FS::UID::AutoCommit;
1363 return $i_sth->errstr;
1365 $insertid = $i_sth->fetchrow_arrayref->[0];
1370 dbh->rollback if $FS::UID::AutoCommit;
1371 return "don't know how to retreive inserted ids from ". driver_name.
1372 ", try using counterfiles (maybe run dbdef-create?)";
1376 $self->setfield($primary_key, $insertid);
1381 if ( defined( dbdef->table('h_'. $table) ) && ! $no_history ) {
1382 my $h_statement = $self->_h_statement('insert');
1383 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1384 $h_sth = dbh->prepare($h_statement) or do {
1385 dbh->rollback if $FS::UID::AutoCommit;
1391 $h_sth->execute or return $h_sth->errstr if $h_sth;
1393 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1395 # Now that it has been saved, reset the encrypted fields so that $new
1396 # can still be used.
1397 foreach my $field (keys %{$saved}) {
1398 $self->setfield($field, $saved->{$field});
1406 Depriciated (use insert instead).
1411 cluck "warning: FS::Record::add deprecated!";
1412 insert @_; #call method in this scope
1417 Delete this record from the database. If there is an error, returns the error,
1418 otherwise returns false.
1425 my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1427 $self->getfield($_) eq ''
1428 #? "( $_ IS NULL OR $_ = \"\" )"
1429 ? ( driver_name eq 'Pg'
1431 : "( $_ IS NULL OR $_ = \"\" )"
1433 : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1434 } ( $self->dbdef_table->primary_key )
1435 ? ( $self->dbdef_table->primary_key)
1436 : real_fields($self->table)
1438 warn "[debug]$me $statement\n" if $DEBUG > 1;
1439 my $sth = dbh->prepare($statement) or return dbh->errstr;
1442 if ( defined dbdef->table('h_'. $self->table) ) {
1443 my $h_statement = $self->_h_statement('delete');
1444 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1445 $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1450 my $primary_key = $self->dbdef_table->primary_key;
1452 local $SIG{HUP} = 'IGNORE';
1453 local $SIG{INT} = 'IGNORE';
1454 local $SIG{QUIT} = 'IGNORE';
1455 local $SIG{TERM} = 'IGNORE';
1456 local $SIG{TSTP} = 'IGNORE';
1457 local $SIG{PIPE} = 'IGNORE';
1459 my $rc = $sth->execute or return $sth->errstr;
1460 #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1461 $h_sth->execute or return $h_sth->errstr if $h_sth;
1463 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1465 #no need to needlessly destoy the data either (causes problems actually)
1466 #undef $self; #no need to keep object!
1473 Depriciated (use delete instead).
1478 cluck "warning: FS::Record::del deprecated!";
1479 &delete(@_); #call method in this scope
1482 =item replace OLD_RECORD
1484 Replace the OLD_RECORD with this one in the database. If there is an error,
1485 returns the error, otherwise returns false.
1490 my ($new, $old) = (shift, shift);
1492 $old = $new->replace_old unless defined($old);
1494 warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1496 if ( $new->can('replace_check') ) {
1497 my $error = $new->replace_check($old);
1498 return $error if $error;
1501 return "Records not in same table!" unless $new->table eq $old->table;
1503 my $primary_key = $old->dbdef_table->primary_key;
1504 return "Can't change primary key $primary_key ".
1505 'from '. $old->getfield($primary_key).
1506 ' to ' . $new->getfield($primary_key)
1508 && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1510 my $error = $new->check;
1511 return $error if $error;
1513 # Encrypt for replace
1515 if ( $conf->exists('encryption')
1516 && defined(eval '@FS::'. $new->table . '::encrypted_fields')
1517 && scalar( eval '@FS::'. $new->table . '::encrypted_fields')
1519 foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1520 next if $field eq 'payinfo'
1521 && ($new->isa('FS::payinfo_transaction_Mixin')
1522 || $new->isa('FS::payinfo_Mixin') )
1524 && !grep { $new->payby eq $_ } @encrypt_payby;
1525 $saved->{$field} = $new->getfield($field);
1526 $new->setfield($field, $new->encrypt($new->getfield($field)));
1530 #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1531 my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1532 ? ($_, $new->getfield($_)) : () } $old->fields;
1534 unless (keys(%diff) || $no_update_diff ) {
1535 carp "[warning]$me ". ref($new)."->replace ".
1536 ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ).
1537 ": records identical"
1538 unless $nowarn_identical;
1542 my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1544 "$_ = ". _quote($new->getfield($_),$old->table,$_)
1545 } real_fields($old->table)
1550 if ( $old->getfield($_) eq '' ) {
1552 #false laziness w/qsearch
1553 if ( driver_name eq 'Pg' ) {
1554 my $type = $old->dbdef_table->column($_)->type;
1555 if ( $type =~ /(int|(big)?serial)/i ) {
1558 qq-( $_ IS NULL OR $_ = '' )-;
1561 qq-( $_ IS NULL OR $_ = "" )-;
1565 "$_ = ". _quote($old->getfield($_),$old->table,$_);
1568 } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1571 warn "[debug]$me $statement\n" if $DEBUG > 1;
1572 my $sth = dbh->prepare($statement) or return dbh->errstr;
1575 if ( defined dbdef->table('h_'. $old->table) ) {
1576 my $h_old_statement = $old->_h_statement('replace_old');
1577 warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1578 $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1584 if ( defined dbdef->table('h_'. $new->table) ) {
1585 my $h_new_statement = $new->_h_statement('replace_new');
1586 warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1587 $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1592 local $SIG{HUP} = 'IGNORE';
1593 local $SIG{INT} = 'IGNORE';
1594 local $SIG{QUIT} = 'IGNORE';
1595 local $SIG{TERM} = 'IGNORE';
1596 local $SIG{TSTP} = 'IGNORE';
1597 local $SIG{PIPE} = 'IGNORE';
1599 my $rc = $sth->execute or return $sth->errstr;
1600 #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1601 $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1602 $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1604 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1606 # Now that it has been saved, reset the encrypted fields so that $new
1607 # can still be used.
1608 foreach my $field (keys %{$saved}) {
1609 $new->setfield($field, $saved->{$field});
1617 my( $self ) = shift;
1618 warn "[$me] replace called with no arguments; autoloading old record\n"
1621 my $primary_key = $self->dbdef_table->primary_key;
1622 if ( $primary_key ) {
1623 $self->by_key( $self->$primary_key() ) #this is what's returned
1624 or croak "can't find ". $self->table. ".$primary_key ".
1625 $self->$primary_key();
1627 croak $self->table. " has no primary key; pass old record as argument";
1634 Depriciated (use replace instead).
1639 cluck "warning: FS::Record::rep deprecated!";
1640 replace @_; #call method in this scope
1645 Checks custom fields. Subclasses should still provide a check method to validate
1646 non-custom fields, etc., and call this method via $self->SUPER::check.
1652 foreach my $field ($self->virtual_fields) {
1653 my $error = $self->ut_textn($field);
1654 return $error if $error;
1659 =item virtual_fields [ TABLE ]
1661 Returns a list of virtual fields defined for the table. This should not
1662 be exported, and should only be called as an instance or class method.
1666 sub virtual_fields {
1669 $table = $self->table or confess "virtual_fields called on non-table";
1671 confess "Unknown table $table" unless dbdef->table($table);
1673 return () unless dbdef->table('part_virtual_field');
1675 unless ( $virtual_fields_cache{$table} ) {
1676 my $concat = [ "'cf_'", "name" ];
1677 my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' .
1678 "WHERE dbtable = '$table'";
1680 my $result = $dbh->selectcol_arrayref($query);
1681 confess "Error executing virtual fields query: $query: ". $dbh->errstr
1683 $virtual_fields_cache{$table} = $result;
1686 @{$virtual_fields_cache{$table}};
1690 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1692 Processes a batch import as a queued JSRPC job
1694 JOB is an FS::queue entry.
1696 OPTIONS_HASHREF can have the following keys:
1702 Table name (required).
1706 Listref of field names for static fields. They will be given values from the
1707 PARAMS hashref and passed as a "params" hashref to batch_import.
1711 Formats hashref. Keys are field names, values are listrefs that define the
1714 Each listref value can be a column name or a code reference. Coderefs are run
1715 with the row object, data and a FS::Conf object as the three parameters.
1716 For example, this coderef does the same thing as using the "columnname" string:
1719 my( $record, $data, $conf ) = @_;
1720 $record->columnname( $data );
1723 Coderefs are run after all "column name" fields are assigned.
1727 Optional format hashref of types. Keys are field names, values are "csv",
1728 "xls" or "fixedlength". Overrides automatic determination of file type
1731 =item format_headers
1733 Optional format hashref of header lines. Keys are field names, values are 0
1734 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1737 =item format_sep_chars
1739 Optional format hashref of CSV sep_chars. Keys are field names, values are the
1740 CSV separation character.
1742 =item format_fixedlenth_formats
1744 Optional format hashref of fixed length format defintiions. Keys are field
1745 names, values Parse::FixedLength listrefs of field definitions.
1749 Set true to default to CSV file type if the filename does not contain a
1750 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1755 PARAMS is a base64-encoded Storable string containing the POSTed data as
1756 a hash ref. It normally contains at least one field, "uploaded files",
1757 generated by /elements/file-upload.html and containing the list of uploaded
1758 files. Currently only supports a single file named "file".
1762 use Storable qw(thaw);
1765 sub process_batch_import {
1766 my($job, $opt) = ( shift, shift );
1768 my $table = $opt->{table};
1769 my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1770 my %formats = %{ $opt->{formats} };
1772 my $param = thaw(decode_base64(shift));
1773 warn Dumper($param) if $DEBUG;
1775 my $files = $param->{'uploaded_files'}
1776 or die "No files provided.\n";
1778 my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1780 my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1781 my $file = $dir. $files{'file'};
1786 formats => \%formats,
1787 format_types => $opt->{format_types},
1788 format_headers => $opt->{format_headers},
1789 format_sep_chars => $opt->{format_sep_chars},
1790 format_fixedlength_formats => $opt->{format_fixedlength_formats},
1791 format_xml_formats => $opt->{format_xml_formats},
1792 format_asn_formats => $opt->{format_asn_formats},
1793 format_row_callbacks => $opt->{format_row_callbacks},
1798 format => $param->{format},
1799 params => { map { $_ => $param->{$_} } @pass_params },
1801 default_csv => $opt->{default_csv},
1802 postinsert_callback => $opt->{postinsert_callback},
1805 if ( $opt->{'batch_namecol'} ) {
1806 $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1807 $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1810 my $error = FS::Record::batch_import( \%iopt );
1814 die "$error\n" if $error;
1817 =item batch_import PARAM_HASHREF
1819 Class method for batch imports. Available params:
1825 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1831 =item format_headers
1833 =item format_sep_chars
1835 =item format_fixedlength_formats
1837 =item format_row_callbacks
1839 =item fields - Alternate way to specify import, specifying import fields directly as a listref
1841 =item preinsert_callback
1843 =item postinsert_callback
1849 FS::queue object, will be updated with progress
1855 csv, xls, fixedlength, xml
1867 warn "$me batch_import call with params: \n". Dumper($param)
1870 my $table = $param->{table};
1872 my $job = $param->{job};
1873 my $file = $param->{file};
1874 my $params = $param->{params} || {};
1876 my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
1877 my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
1879 my( $type, $header, $sep_char,
1880 $fixedlength_format, $xml_format, $asn_format,
1881 $parser_opt, $row_callback, @fields );
1883 my $postinsert_callback = '';
1884 $postinsert_callback = $param->{'postinsert_callback'}
1885 if $param->{'postinsert_callback'};
1886 my $preinsert_callback = '';
1887 $preinsert_callback = $param->{'preinsert_callback'}
1888 if $param->{'preinsert_callback'};
1890 if ( $param->{'format'} ) {
1892 my $format = $param->{'format'};
1893 my $formats = $param->{formats};
1894 die "unknown format $format" unless exists $formats->{ $format };
1896 $type = $param->{'format_types'}
1897 ? $param->{'format_types'}{ $format }
1898 : $param->{type} || 'csv';
1901 $header = $param->{'format_headers'}
1902 ? $param->{'format_headers'}{ $param->{'format'} }
1905 $sep_char = $param->{'format_sep_chars'}
1906 ? $param->{'format_sep_chars'}{ $param->{'format'} }
1909 $fixedlength_format =
1910 $param->{'format_fixedlength_formats'}
1911 ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1915 $param->{'format_parser_opts'}
1916 ? $param->{'format_parser_opts'}{ $param->{'format'} }
1920 $param->{'format_xml_formats'}
1921 ? $param->{'format_xml_formats'}{ $param->{'format'} }
1925 $param->{'format_asn_formats'}
1926 ? $param->{'format_asn_formats'}{ $param->{'format'} }
1930 $param->{'format_row_callbacks'}
1931 ? $param->{'format_row_callbacks'}{ $param->{'format'} }
1934 @fields = @{ $formats->{ $format } };
1936 } elsif ( $param->{'fields'} ) {
1938 $type = ''; #infer from filename
1941 $fixedlength_format = '';
1943 @fields = @{ $param->{'fields'} };
1946 die "neither format nor fields specified";
1949 #my $file = $param->{file};
1952 if ( $file =~ /\.(\w+)$/i ) {
1956 warn "can't parse file type from filename $file; defaulting to CSV";
1960 if $param->{'default_csv'} && $type ne 'xls';
1968 my $asn_header_buffer;
1969 if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1971 if ( $type eq 'csv' ) {
1973 $parser_opt->{'binary'} = 1;
1974 $parser_opt->{'sep_char'} = $sep_char if $sep_char;
1975 $parser = Text::CSV_XS->new($parser_opt);
1977 } elsif ( $type eq 'fixedlength' ) {
1979 eval "use Parse::FixedLength;";
1981 $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
1984 die "Unknown file type $type\n";
1987 @buffer = split(/\r?\n/, slurp($file) );
1988 splice(@buffer, 0, ($header || 0) );
1989 $count = scalar(@buffer);
1991 } elsif ( $type eq 'xls' ) {
1993 eval "use Spreadsheet::ParseExcel;";
1996 eval "use DateTime::Format::Excel;";
1997 #for now, just let the error be thrown if it is used, since only CDR
1998 # formats bill_west and troop use it, not other excel-parsing things
2001 my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
2003 $parser = $excel->{Worksheet}[0]; #first sheet
2005 $count = $parser->{MaxRow} || $parser->{MinRow};
2008 $row = $header || 0;
2010 } elsif ( $type eq 'xml' ) {
2013 eval "use XML::Simple;";
2015 my $xmlrow = $xml_format->{'xmlrow'};
2016 $parser = $xml_format->{'xmlkeys'};
2017 die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
2018 my $data = XML::Simple::XMLin(
2020 'SuppressEmpty' => '', #sets empty values to ''
2024 $rows = $rows->{$_} foreach @$xmlrow;
2025 $rows = [ $rows ] if ref($rows) ne 'ARRAY';
2026 $count = @buffer = @$rows;
2028 } elsif ( $type eq 'asn.1' ) {
2030 eval "use Convert::ASN1";
2033 my $asn = Convert::ASN1->new;
2034 $asn->prepare( $asn_format->{'spec'} ) or die $asn->error;
2036 $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error;
2038 my $data = slurp($file);
2039 my $asn_output = $parser->decode( $data )
2040 or return "No ". $asn_format->{'macro'}. " found\n";
2042 $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output );
2044 my $rows = &{ $asn_format->{'arrayref'} }( $asn_output );
2045 $count = @buffer = @$rows;
2048 die "Unknown file type $type\n";
2053 local $SIG{HUP} = 'IGNORE';
2054 local $SIG{INT} = 'IGNORE';
2055 local $SIG{QUIT} = 'IGNORE';
2056 local $SIG{TERM} = 'IGNORE';
2057 local $SIG{TSTP} = 'IGNORE';
2058 local $SIG{PIPE} = 'IGNORE';
2060 my $oldAutoCommit = $FS::UID::AutoCommit;
2061 local $FS::UID::AutoCommit = 0;
2064 #my $params = $param->{params} || {};
2065 if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
2066 my $batch_col = $param->{'batch_keycol'};
2068 my $batch_class = 'FS::'. $param->{'batch_table'};
2069 my $batch = $batch_class->new({
2070 $param->{'batch_namecol'} => $param->{'batch_namevalue'}
2072 my $error = $batch->insert;
2074 $dbh->rollback if $oldAutoCommit;
2075 return "can't insert batch record: $error";
2077 #primary key via dbdef? (so the column names don't have to match)
2078 my $batch_value = $batch->get( $param->{'batch_keycol'} );
2080 $params->{ $batch_col } = $batch_value;
2083 #my $job = $param->{job};
2086 my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
2090 my %hash = %$params;
2091 if ( $type eq 'csv' ) {
2093 last unless scalar(@buffer);
2094 $line = shift(@buffer);
2096 next if $line =~ /^\s*$/; #skip empty lines
2098 $line = &{$row_callback}($line) if $row_callback;
2100 next if $line =~ /^\s*$/; #skip empty lines
2102 $parser->parse($line) or do {
2103 $dbh->rollback if $oldAutoCommit;
2104 return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
2106 @columns = $parser->fields();
2108 } elsif ( $type eq 'fixedlength' ) {
2110 last unless scalar(@buffer);
2111 $line = shift(@buffer);
2113 @columns = $parser->parse($line);
2115 } elsif ( $type eq 'xls' ) {
2117 last if $row > ($parser->{MaxRow} || $parser->{MinRow})
2118 || ! $parser->{Cells}[$row];
2120 my @row = @{ $parser->{Cells}[$row] };
2121 @columns = map $_->{Val}, @row;
2124 #warn $z++. ": $_\n" for @columns;
2126 } elsif ( $type eq 'xml' ) {
2128 # $parser = [ 'Column0Key', 'Column1Key' ... ]
2129 last unless scalar(@buffer);
2130 my $row = shift @buffer;
2131 @columns = @{ $row }{ @$parser };
2133 } elsif ( $type eq 'asn.1' ) {
2135 last unless scalar(@buffer);
2136 my $row = shift @buffer;
2137 &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
2138 if $asn_format->{row_callback};
2139 foreach my $key ( keys %{ $asn_format->{map} } ) {
2140 $hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
2144 die "Unknown file type $type\n";
2149 foreach my $field ( @fields ) {
2151 my $value = shift @columns;
2153 if ( ref($field) eq 'CODE' ) {
2154 #&{$field}(\%hash, $value);
2155 push @later, $field, $value;
2157 #??? $hash{$field} = $value if length($value);
2158 $hash{$field} = $value if defined($value) && length($value);
2163 if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
2164 && length($1) == $custnum_length ) {
2165 $hash{custnum} = $2;
2168 #my $table = $param->{table};
2169 my $class = "FS::$table";
2171 my $record = $class->new( \%hash );
2174 while ( scalar(@later) ) {
2175 my $sub = shift @later;
2176 my $data = shift @later;
2178 &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
2181 $dbh->rollback if $oldAutoCommit;
2182 return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
2184 last if exists( $param->{skiprow} );
2186 next if exists( $param->{skiprow} );
2188 if ( $preinsert_callback ) {
2189 my $error = &{$preinsert_callback}($record, $param);
2191 $dbh->rollback if $oldAutoCommit;
2192 return "preinsert_callback error". ( $line ? " for $line" : '' ).
2195 next if exists $param->{skiprow} && $param->{skiprow};
2198 my $error = $record->insert;
2201 $dbh->rollback if $oldAutoCommit;
2202 return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
2208 if ( $postinsert_callback ) {
2209 my $error = &{$postinsert_callback}($record, $param);
2211 $dbh->rollback if $oldAutoCommit;
2212 return "postinsert_callback error". ( $line ? " for $line" : '' ).
2217 if ( $job && time - $min_sec > $last ) { #progress bar
2218 $job->update_statustext( int(100 * $imported / $count) );
2224 unless ( $imported || $param->{empty_ok} ) {
2225 $dbh->rollback if $oldAutoCommit;
2226 return "Empty file!";
2229 $dbh->commit or die $dbh->errstr if $oldAutoCommit;
2236 my( $self, $action, $time ) = @_;
2240 my %nohistory = map { $_=>1 } $self->nohistory_fields;
2243 grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2244 real_fields($self->table);
2247 # If we're encrypting then don't store the payinfo in the history
2248 if ( $conf && $conf->exists('encryption') && $self->table ne 'banned_pay' ) {
2249 @fields = grep { $_ ne 'payinfo' } @fields;
2252 my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2254 "INSERT INTO h_". $self->table. " ( ".
2255 join(', ', qw(history_date history_usernum history_action), @fields ).
2258 $FS::CurrentUser::CurrentUser->usernum,
2259 dbh->quote($action),
2268 B<Warning>: External use is B<deprecated>.
2270 Replaces COLUMN in record with a unique number, using counters in the
2271 filesystem. Used by the B<insert> method on single-field unique columns
2272 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2273 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2275 Returns the new value.
2280 my($self,$field) = @_;
2281 my($table)=$self->table;
2283 croak "Unique called on field $field, but it is ",
2284 $self->getfield($field),
2286 if $self->getfield($field);
2288 #warn "table $table is tainted" if is_tainted($table);
2289 #warn "field $field is tainted" if is_tainted($field);
2291 my($counter) = new File::CounterFile "$table.$field",0;
2293 my $index = $counter->inc;
2294 $index = $counter->inc while qsearchs($table, { $field=>$index } );
2296 $index =~ /^(\d*)$/;
2299 $self->setfield($field,$index);
2303 =item ut_float COLUMN
2305 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be
2306 null. If there is an error, returns the error, otherwise returns false.
2311 my($self,$field)=@_ ;
2312 ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2313 $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2314 $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2315 $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2316 or return "Illegal or empty (float) $field: ". $self->getfield($field);
2317 $self->setfield($field,$1);
2320 =item ut_floatn COLUMN
2322 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
2323 null. If there is an error, returns the error, otherwise returns false.
2327 #false laziness w/ut_ipn
2329 my( $self, $field ) = @_;
2330 if ( $self->getfield($field) =~ /^()$/ ) {
2331 $self->setfield($field,'');
2334 $self->ut_float($field);
2338 =item ut_sfloat COLUMN
2340 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2341 May not be null. If there is an error, returns the error, otherwise returns
2347 my($self,$field)=@_ ;
2348 ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2349 $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2350 $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2351 $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2352 or return "Illegal or empty (float) $field: ". $self->getfield($field);
2353 $self->setfield($field,$1);
2356 =item ut_sfloatn COLUMN
2358 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
2359 null. If there is an error, returns the error, otherwise returns false.
2364 my( $self, $field ) = @_;
2365 if ( $self->getfield($field) =~ /^()$/ ) {
2366 $self->setfield($field,'');
2369 $self->ut_sfloat($field);
2373 =item ut_snumber COLUMN
2375 Check/untaint signed numeric data (whole numbers). If there is an error,
2376 returns the error, otherwise returns false.
2381 my($self, $field) = @_;
2382 $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2383 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2384 $self->setfield($field, "$1$2");
2388 =item ut_snumbern COLUMN
2390 Check/untaint signed numeric data (whole numbers). If there is an error,
2391 returns the error, otherwise returns false.
2396 my($self, $field) = @_;
2397 $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2398 or return "Illegal (numeric) $field: ". $self->getfield($field);
2400 return "Illegal (numeric) $field: ". $self->getfield($field)
2403 $self->setfield($field, "$1$2");
2407 =item ut_number COLUMN
2409 Check/untaint simple numeric data (whole numbers). May not be null. If there
2410 is an error, returns the error, otherwise returns false.
2415 my($self,$field)=@_;
2416 $self->getfield($field) =~ /^\s*(\d+)\s*$/
2417 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2418 $self->setfield($field,$1);
2422 =item ut_numbern COLUMN
2424 Check/untaint simple numeric data (whole numbers). May be null. If there is
2425 an error, returns the error, otherwise returns false.
2430 my($self,$field)=@_;
2431 $self->getfield($field) =~ /^\s*(\d*)\s*$/
2432 or return "Illegal (numeric) $field: ". $self->getfield($field);
2433 $self->setfield($field,$1);
2437 =item ut_money COLUMN
2439 Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
2440 is an error, returns the error, otherwise returns false.
2445 my($self,$field)=@_;
2447 if ( $self->getfield($field) eq '' ) {
2448 $self->setfield($field, 0);
2449 } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) {
2450 #handle one decimal place without barfing out
2451 $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0);
2452 } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) {
2453 $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2455 return "Illegal (money) $field: ". $self->getfield($field);
2461 =item ut_moneyn COLUMN
2463 Check/untaint monetary numbers. May be negative. If there
2464 is an error, returns the error, otherwise returns false.
2469 my($self,$field)=@_;
2470 if ($self->getfield($field) eq '') {
2471 $self->setfield($field, '');
2474 $self->ut_money($field);
2477 =item ut_currencyn COLUMN
2479 Check/untaint currency indicators, such as USD or EUR. May be null. If there
2480 is an error, returns the error, otherwise returns false.
2485 my($self, $field) = @_;
2486 if ($self->getfield($field) eq '') { #can be null
2487 $self->setfield($field, '');
2490 $self->ut_currency($field);
2493 =item ut_currency COLUMN
2495 Check/untaint currency indicators, such as USD or EUR. May not be null. If
2496 there is an error, returns the error, otherwise returns false.
2501 my($self, $field) = @_;
2502 my $value = uc( $self->getfield($field) );
2503 if ( code2currency($value) ) {
2504 $self->setfield($value);
2506 return "Unknown currency $value";
2512 =item ut_text COLUMN
2514 Check/untaint text. Alphanumerics, spaces, and the following punctuation
2515 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2516 May not be null. If there is an error, returns the error, otherwise returns
2522 my($self,$field)=@_;
2523 #warn "msgcat ". \&msgcat. "\n";
2524 #warn "notexist ". \¬exist. "\n";
2525 #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2526 # \p{Word} = alphanumerics, marks (diacritics), and connectors
2527 # see perldoc perluniprops
2528 $self->getfield($field)
2529 =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
2530 or return gettext('illegal_or_empty_text'). " $field: ".
2531 $self->getfield($field);
2532 $self->setfield($field,$1);
2536 =item ut_textn COLUMN
2538 Check/untaint text. Alphanumerics, spaces, and the following punctuation
2539 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2540 May be null. If there is an error, returns the error, otherwise returns false.
2545 my($self,$field)=@_;
2546 return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2547 $self->ut_text($field);
2550 =item ut_alpha COLUMN
2552 Check/untaint alphanumeric strings (no spaces). May not be null. If there is
2553 an error, returns the error, otherwise returns false.
2558 my($self,$field)=@_;
2559 $self->getfield($field) =~ /^(\w+)$/
2560 or return "Illegal or empty (alphanumeric) $field: ".
2561 $self->getfield($field);
2562 $self->setfield($field,$1);
2566 =item ut_alphan COLUMN
2568 Check/untaint alphanumeric strings (no spaces). May be null. If there is an
2569 error, returns the error, otherwise returns false.
2574 my($self,$field)=@_;
2575 $self->getfield($field) =~ /^(\w*)$/
2576 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2577 $self->setfield($field,$1);
2581 =item ut_alphasn COLUMN
2583 Check/untaint alphanumeric strings, spaces allowed. May be null. If there is
2584 an error, returns the error, otherwise returns false.
2589 my($self,$field)=@_;
2590 $self->getfield($field) =~ /^([\w ]*)$/
2591 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2592 $self->setfield($field,$1);
2597 =item ut_alpha_lower COLUMN
2599 Check/untaint lowercase alphanumeric strings (no spaces). May not be null. If
2600 there is an error, returns the error, otherwise returns false.
2604 sub ut_alpha_lower {
2605 my($self,$field)=@_;
2606 $self->getfield($field) =~ /[[:upper:]]/
2607 and return "Uppercase characters are not permitted in $field";
2608 $self->ut_alpha($field);
2611 =item ut_phonen COLUMN [ COUNTRY ]
2613 Check/untaint phone numbers. May be null. If there is an error, returns
2614 the error, otherwise returns false.
2616 Takes an optional two-letter ISO country code; without it or with unsupported
2617 countries, ut_phonen simply calls ut_alphan.
2622 my( $self, $field, $country ) = @_;
2623 return $self->ut_alphan($field) unless defined $country;
2624 my $phonen = $self->getfield($field);
2625 if ( $phonen eq '' ) {
2626 $self->setfield($field,'');
2627 } elsif ( $country eq 'US' || $country eq 'CA' ) {
2629 $phonen = $conf->config('cust_main-default_areacode').$phonen
2630 if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2631 $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2632 or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2633 $phonen = "$1-$2-$3";
2634 $phonen .= " x$4" if $4;
2635 $self->setfield($field,$phonen);
2637 warn "warning: don't know how to check phone numbers for country $country";
2638 return $self->ut_textn($field);
2645 Check/untaint hexadecimal values.
2650 my($self, $field) = @_;
2651 $self->getfield($field) =~ /^([\da-fA-F]+)$/
2652 or return "Illegal (hex) $field: ". $self->getfield($field);
2653 $self->setfield($field, uc($1));
2657 =item ut_hexn COLUMN
2659 Check/untaint hexadecimal values. May be null.
2664 my($self, $field) = @_;
2665 $self->getfield($field) =~ /^([\da-fA-F]*)$/
2666 or return "Illegal (hex) $field: ". $self->getfield($field);
2667 $self->setfield($field, uc($1));
2671 =item ut_mac_addr COLUMN
2673 Check/untaint mac addresses. May be null.
2678 my($self, $field) = @_;
2680 my $mac = $self->get($field);
2683 $self->set($field, $mac);
2685 my $e = $self->ut_hex($field);
2688 return "Illegal (mac address) $field: ". $self->getfield($field)
2689 unless length($self->getfield($field)) == 12;
2695 =item ut_mac_addrn COLUMN
2697 Check/untaint mac addresses. May be null.
2702 my($self, $field) = @_;
2703 ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field);
2708 Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
2714 my( $self, $field ) = @_;
2715 $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2716 $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2717 or return "Illegal (IP address) $field: ". $self->getfield($field);
2718 for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2719 $self->setfield($field, "$1.$2.$3.$4");
2725 Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
2726 to 127.0.0.1. May be null.
2731 my( $self, $field ) = @_;
2732 if ( $self->getfield($field) =~ /^()$/ ) {
2733 $self->setfield($field,'');
2736 $self->ut_ip($field);
2740 =item ut_ip46 COLUMN
2742 Check/untaint IPv4 or IPv6 address.
2747 my( $self, $field ) = @_;
2748 my $ip = NetAddr::IP->new($self->getfield($field))
2749 or return "Illegal (IP address) $field: ".$self->getfield($field);
2750 $self->setfield($field, lc($ip->addr));
2756 Check/untaint IPv6 or IPv6 address. May be null.
2761 my( $self, $field ) = @_;
2762 if ( $self->getfield($field) =~ /^$/ ) {
2763 $self->setfield($field, '');
2766 $self->ut_ip46($field);
2769 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2771 Check/untaint coordinates.
2772 Accepts the following forms:
2782 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2783 The latter form (that is, the MMM are thousands of minutes) is
2784 assumed if the "MMM" is exactly three digits or two digits > 59.
2786 To be safe, just use the DDD.DDDDD form.
2788 If LOWER or UPPER are specified, then the coordinate is checked
2789 for lower and upper bounds, respectively.
2794 my ($self, $field) = (shift, shift);
2797 if ( $field =~ /latitude/ ) {
2798 $lower = $lat_lower;
2800 } elsif ( $field =~ /longitude/ ) {
2802 $upper = $lon_upper;
2805 my $coord = $self->getfield($field);
2806 my $neg = $coord =~ s/^(-)//;
2808 my ($d, $m, $s) = (0, 0, 0);
2811 (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2812 (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2813 (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2815 $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2818 return "Invalid (coordinate with minutes > 59) $field: "
2819 . $self->getfield($field);
2822 $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2824 if (defined($lower) and ($coord < $lower)) {
2825 return "Invalid (coordinate < $lower) $field: "
2826 . $self->getfield($field);;
2829 if (defined($upper) and ($coord > $upper)) {
2830 return "Invalid (coordinate > $upper) $field: "
2831 . $self->getfield($field);;
2834 $self->setfield($field, $coord);
2838 return "Invalid (coordinate) $field: " . $self->getfield($field);
2842 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2844 Same as ut_coord, except optionally null.
2850 my ($self, $field) = (shift, shift);
2852 if ($self->getfield($field) =~ /^\s*$/) {
2855 return $self->ut_coord($field, @_);
2860 =item ut_domain COLUMN
2862 Check/untaint host and domain names. May not be null.
2867 my( $self, $field ) = @_;
2868 #$self->getfield($field) =~/^(\w+\.)*\w+$/
2869 $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2870 or return "Illegal (hostname) $field: ". $self->getfield($field);
2871 $self->setfield($field,$1);
2875 =item ut_domainn COLUMN
2877 Check/untaint host and domain names. May be null.
2882 my( $self, $field ) = @_;
2883 if ( $self->getfield($field) =~ /^()$/ ) {
2884 $self->setfield($field,'');
2887 $self->ut_domain($field);
2891 =item ut_name COLUMN
2893 Check/untaint proper names; allows alphanumerics, spaces and the following
2894 punctuation: , . - '
2901 my( $self, $field ) = @_;
2902 # warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
2903 $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
2904 or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2909 $self->setfield($field, $name);
2913 =item ut_namen COLUMN
2915 Check/untaint proper names; allows alphanumerics, spaces and the following
2916 punctuation: , . - '
2923 my( $self, $field ) = @_;
2924 return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2925 $self->ut_name($field);
2930 Check/untaint zip codes.
2934 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2937 my( $self, $field, $country ) = @_;
2939 if ( $country eq 'US' ) {
2941 $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2942 or return gettext('illegal_zip'). " $field for country $country: ".
2943 $self->getfield($field);
2944 $self->setfield($field, $1);
2946 } elsif ( $country eq 'CA' ) {
2948 $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2949 or return gettext('illegal_zip'). " $field for country $country: ".
2950 $self->getfield($field);
2951 $self->setfield($field, "$1 $2");
2955 if ( $self->getfield($field) =~ /^\s*$/
2956 && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2959 $self->setfield($field,'');
2961 $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/
2962 or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2963 $self->setfield($field,$1);
2971 =item ut_country COLUMN
2973 Check/untaint country codes. Country names are changed to codes, if possible -
2974 see L<Locale::Country>.
2979 my( $self, $field ) = @_;
2980 unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2981 if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2982 && country2code($1) ) {
2983 $self->setfield($field,uc(country2code($1)));
2986 $self->getfield($field) =~ /^(\w\w)$/
2987 or return "Illegal (country) $field: ". $self->getfield($field);
2988 $self->setfield($field,uc($1));
2992 =item ut_anything COLUMN
2994 Untaints arbitrary data. Be careful.
2999 my( $self, $field ) = @_;
3000 $self->getfield($field) =~ /^(.*)$/s
3001 or return "Illegal $field: ". $self->getfield($field);
3002 $self->setfield($field,$1);
3006 =item ut_enum COLUMN CHOICES_ARRAYREF
3008 Check/untaint a column, supplying all possible choices, like the "enum" type.
3013 my( $self, $field, $choices ) = @_;
3014 foreach my $choice ( @$choices ) {
3015 if ( $self->getfield($field) eq $choice ) {
3016 $self->setfield($field, $choice);
3020 return "Illegal (enum) field $field: ". $self->getfield($field);
3023 =item ut_enumn COLUMN CHOICES_ARRAYREF
3025 Like ut_enum, except the null value is also allowed.
3030 my( $self, $field, $choices ) = @_;
3031 $self->getfield($field)
3032 ? $self->ut_enum($field, $choices)
3036 =item ut_flag COLUMN
3038 Check/untaint a column if it contains either an empty string or 'Y'. This
3039 is the standard form for boolean flags in Freeside.
3044 my( $self, $field ) = @_;
3045 my $value = uc($self->getfield($field));
3046 if ( $value eq '' or $value eq 'Y' ) {
3047 $self->setfield($field, $value);
3050 return "Illegal (flag) field $field: $value";
3053 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3055 Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
3056 on the column first.
3060 sub ut_foreign_key {
3061 my( $self, $field, $table, $foreign ) = @_;
3062 return '' if $no_check_foreign;
3063 qsearchs($table, { $foreign => $self->getfield($field) })
3064 or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
3065 " in $table.$foreign";
3069 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
3071 Like ut_foreign_key, except the null value is also allowed.
3075 sub ut_foreign_keyn {
3076 my( $self, $field, $table, $foreign ) = @_;
3077 $self->getfield($field)
3078 ? $self->ut_foreign_key($field, $table, $foreign)
3082 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
3084 Checks this column as an agentnum, taking into account the current users's
3085 ACLs. NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
3086 right or rights allowing no agentnum.
3090 sub ut_agentnum_acl {
3091 my( $self, $field ) = (shift, shift);
3092 my $null_acl = scalar(@_) ? shift : [];
3093 $null_acl = [ $null_acl ] unless ref($null_acl);
3095 my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
3096 return "Illegal agentnum: $error" if $error;
3098 my $curuser = $FS::CurrentUser::CurrentUser;
3100 if ( $self->$field() ) {
3102 return "Access denied"
3103 unless $curuser->agentnum($self->$field());
3107 return "Access denied"
3108 unless grep $curuser->access_right($_), @$null_acl;
3116 =item fields [ TABLE ]
3118 This is a wrapper for real_fields. Code that called
3119 fields before should probably continue to call fields.
3124 my $something = shift;
3126 if($something->isa('FS::Record')) {
3127 $table = $something->table;
3129 $table = $something;
3130 $something = "FS::$table";
3132 return (real_fields($table));
3136 =item encrypt($value)
3138 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
3140 Returns the encrypted string.
3142 You should generally not have to worry about calling this, as the system handles this for you.
3147 my ($self, $value) = @_;
3148 my $encrypted = $value;
3150 if ($conf->exists('encryption')) {
3151 if ($self->is_encrypted($value)) {
3152 # Return the original value if it isn't plaintext.
3153 $encrypted = $value;
3156 if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
3157 # RSA doesn't like the empty string so let's pack it up
3158 # The database doesn't like the RSA data so uuencode it
3159 my $length = length($value)+1;
3160 $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
3162 die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
3169 =item is_encrypted($value)
3171 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
3177 my ($self, $value) = @_;
3178 # could be more precise about it, but this will do for now
3179 $value =~ /^M/ && length($value) > 80;
3182 =item decrypt($value)
3184 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
3186 You should generally not have to worry about calling this, as the system handles this for you.
3191 my ($self,$value) = @_;
3192 my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
3193 if ($conf->exists('encryption') && $self->is_encrypted($value)) {
3195 if (ref($rsa_decrypt) =~ /::RSA/) {
3196 my $encrypted = unpack ("u*", $value);
3197 $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
3198 if ($@) {warn "Decryption Failed"};
3206 #Initialize the Module
3207 $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
3209 if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
3210 $rsa_module = $conf->config('encryptionmodule');
3214 eval ("require $rsa_module"); # No need to import the namespace
3217 # Initialize Encryption
3218 if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
3219 my $public_key = join("\n",$conf->config('encryptionpublickey'));
3220 $rsa_encrypt = $rsa_module->new_public_key($public_key);
3223 # Intitalize Decryption
3224 if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
3225 my $private_key = join("\n",$conf->config('encryptionprivatekey'));
3226 $rsa_decrypt = $rsa_module->new_private_key($private_key);
3230 =item h_search ACTION
3232 Given an ACTION, either "insert", or "delete", returns the appropriate history
3233 record corresponding to this record, if any.
3238 my( $self, $action ) = @_;
3240 my $table = $self->table;
3243 my $primary_key = dbdef->table($table)->primary_key;
3246 'table' => "h_$table",
3247 'hashref' => { $primary_key => $self->$primary_key(),
3248 'history_action' => $action,
3256 Given an ACTION, either "insert", or "delete", returns the timestamp of the
3257 appropriate history record corresponding to this record, if any.
3262 my($self, $action) = @_;
3263 my $h = $self->h_search($action);
3264 $h ? $h->history_date : '';
3267 =item scalar_sql SQL [ PLACEHOLDER, ... ]
3269 A class or object method. Executes the sql statement represented by SQL and
3270 returns a scalar representing the result: the first column of the first row.
3272 Dies on bogus SQL. Returns an empty string if no row is returned.
3274 Typically used for statments which return a single value such as "SELECT
3275 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
3280 my($self, $sql) = (shift, shift);
3281 my $sth = dbh->prepare($sql) or die dbh->errstr;
3283 or die "Unexpected error executing statement $sql: ". $sth->errstr;
3284 my $row = $sth->fetchrow_arrayref or return '';
3285 my $scalar = $row->[0];
3286 defined($scalar) ? $scalar : '';
3289 =item count [ WHERE ]
3291 Convenience method for the common case of "SELECT COUNT(*) FROM table",
3292 with optional WHERE. Must be called as method on a class with an
3298 my($self, $where) = (shift, shift);
3299 my $table = $self->table or die 'count called on object of class '.ref($self);
3300 my $sql = "SELECT COUNT(*) FROM $table";
3301 $sql .= " WHERE $where" if $where;
3302 $self->scalar_sql($sql);
3311 =item real_fields [ TABLE ]
3313 Returns a list of the real columns in the specified table. Called only by
3314 fields() and other subroutines elsewhere in FS::Record.
3321 my($table_obj) = dbdef->table($table);
3322 confess "Unknown table $table" unless $table_obj;
3323 $table_obj->columns;
3326 =item pvf FIELD_NAME
3328 Returns the FS::part_virtual_field object corresponding to a field in the
3329 record (specified by FIELD_NAME).
3334 my ($self, $name) = (shift, shift);
3336 if(grep /^$name$/, $self->virtual_fields) {
3338 my $concat = [ "'cf_'", "name" ];
3339 return qsearchs({ table => 'part_virtual_field',
3340 hashref => { dbtable => $self->table,
3343 select => 'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name',
3349 =item _quote VALUE, TABLE, COLUMN
3351 This is an internal function used to construct SQL statements. It returns
3352 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3353 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3358 my($value, $table, $column) = @_;
3359 my $column_obj = dbdef->table($table)->column($column);
3360 my $column_type = $column_obj->type;
3361 my $nullable = $column_obj->null;
3363 utf8::upgrade($value);
3365 warn " $table.$column: $value ($column_type".
3366 ( $nullable ? ' NULL' : ' NOT NULL' ).
3367 ")\n" if $DEBUG > 2;
3369 if ( $value eq '' && $nullable ) {
3371 } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3372 cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3375 } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3376 ! $column_type =~ /(char|binary|text)$/i ) {
3378 } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3379 && driver_name eq 'Pg'
3383 # dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right
3384 # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\,
3385 # single-quote the whole mess, and put an "E" in front.
3386 return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'");
3394 This is deprecated. Don't use it.
3396 It returns a hash-type list with the fields of this record's table set true.
3401 carp "warning: hfields is deprecated";
3404 foreach (fields($table)) {
3413 "$_: ". $self->getfield($_). "|"
3414 } (fields($self->table)) );
3417 sub DESTROY { return; }
3421 # #use Carp qw(cluck);
3422 # #cluck "DESTROYING $self";
3423 # warn "DESTROYING $self";
3427 # return ! eval { join('',@_), kill 0; 1; };
3430 =item str2time_sql [ DRIVER_NAME ]
3432 Returns a function to convert to unix time based on database type, such as
3433 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql. See
3434 the str2time_sql_closing method to return a closing string rather than just
3435 using a closing parenthesis as previously suggested.
3437 You can pass an optional driver name such as "Pg", "mysql" or
3438 $dbh->{Driver}->{Name} to return a function for that database instead of
3439 the current database.
3444 my $driver = shift || driver_name;
3446 return 'UNIX_TIMESTAMP(' if $driver =~ /^mysql/i;
3447 return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3449 warn "warning: unknown database type $driver; guessing how to convert ".
3450 "dates to UNIX timestamps";
3451 return 'EXTRACT(EPOCH FROM ';
3455 =item str2time_sql_closing [ DRIVER_NAME ]
3457 Returns the closing suffix of a function to convert to unix time based on
3458 database type, such as ")::integer" for Pg or ")" for mysql.
3460 You can pass an optional driver name such as "Pg", "mysql" or
3461 $dbh->{Driver}->{Name} to return a function for that database instead of
3462 the current database.
3466 sub str2time_sql_closing {
3467 my $driver = shift || driver_name;
3469 return ' )::INTEGER ' if $driver =~ /^Pg/i;
3473 =item regexp_sql [ DRIVER_NAME ]
3475 Returns the operator to do a regular expression comparison based on database
3476 type, such as '~' for Pg or 'REGEXP' for mysql.
3478 You can pass an optional driver name such as "Pg", "mysql" or
3479 $dbh->{Driver}->{Name} to return a function for that database instead of
3480 the current database.
3485 my $driver = shift || driver_name;
3487 return '~' if $driver =~ /^Pg/i;
3488 return 'REGEXP' if $driver =~ /^mysql/i;
3490 die "don't know how to use regular expressions in ". driver_name." databases";
3494 =item not_regexp_sql [ DRIVER_NAME ]
3496 Returns the operator to do a regular expression negation based on database
3497 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3499 You can pass an optional driver name such as "Pg", "mysql" or
3500 $dbh->{Driver}->{Name} to return a function for that database instead of
3501 the current database.
3505 sub not_regexp_sql {
3506 my $driver = shift || driver_name;
3508 return '!~' if $driver =~ /^Pg/i;
3509 return 'NOT REGEXP' if $driver =~ /^mysql/i;
3511 die "don't know how to use regular expressions in ". driver_name." databases";
3515 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3517 Returns the items concatenated based on database type, using "CONCAT()" for
3518 mysql and " || " for Pg and other databases.
3520 You can pass an optional driver name such as "Pg", "mysql" or
3521 $dbh->{Driver}->{Name} to return a function for that database instead of
3522 the current database.
3527 my $driver = ref($_[0]) ? driver_name : shift;
3530 if ( $driver =~ /^mysql/i ) {
3531 'CONCAT('. join(',', @$items). ')';
3533 join('||', @$items);
3538 =item midnight_sql DATE
3540 Returns an SQL expression to convert DATE (a unix timestamp) to midnight
3541 on that day in the system timezone, using the default driver name.
3546 my $driver = driver_name;
3548 if ( $driver =~ /^mysql/i ) {
3549 "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))";
3552 "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )";
3560 This module should probably be renamed, since much of the functionality is
3561 of general use. It is not completely unlike Adapter::DBI (see below).
3563 Exported qsearch and qsearchs should be deprecated in favor of method calls
3564 (against an FS::Record object like the old search and searchs that qsearch
3565 and qsearchs were on top of.)
3567 The whole fields / hfields mess should be removed.
3569 The various WHERE clauses should be subroutined.
3571 table string should be deprecated in favor of DBIx::DBSchema::Table.
3573 No doubt we could benefit from a Tied hash. Documenting how exists / defined
3574 true maps to the database (and WHERE clauses) would also help.
3576 The ut_ methods should ask the dbdef for a default length.
3578 ut_sqltype (like ut_varchar) should all be defined
3580 A fallback check method should be provided which uses the dbdef.
3582 The ut_money method assumes money has two decimal digits.
3584 The Pg money kludge in the new method only strips `$'.
3586 The ut_phonen method only checks US-style phone numbers.
3588 The _quote function should probably use ut_float instead of a regex.
3590 All the subroutines probably should be methods, here or elsewhere.
3592 Probably should borrow/use some dbdef methods where appropriate (like sub
3595 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3596 or allow it to be set. Working around it is ugly any way around - DBI should
3597 be fixed. (only affects RDBMS which return uppercase column names)
3599 ut_zip should take an optional country like ut_phone.
3603 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3605 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.