4 use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG
5 $conf $conf_encryption $me
7 $nowarn_identical $nowarn_classload
8 $no_update_diff $no_check_foreign
12 use Carp qw(carp cluck croak confess);
13 use Scalar::Util qw( blessed );
14 use File::CounterFile;
17 use File::Slurp qw( slurp );
18 use DBI qw(:sql_types);
19 use DBIx::DBSchema 0.38;
20 use FS::UID qw(dbh getotaker datasrc driver_name);
22 use FS::Schema qw(dbdef);
24 use FS::Msgcat qw(gettext);
25 use NetAddr::IP; # for validation
26 #use FS::Conf; #dependency loop bs, in install_callback below instead
28 use FS::part_virtual_field;
34 @encrypt_payby = qw( CARD DCRD CHEK DCHK );
36 #export dbdef for now... everything else expects to find it here
38 dbh fields hfields qsearch qsearchs dbdef jsearch
39 str2time_sql str2time_sql_closing regexp_sql not_regexp_sql concat_sql
45 $nowarn_identical = 0;
46 $nowarn_classload = 0;
48 $no_check_foreign = 0;
56 $conf_encryption = '';
57 FS::UID->install_callback( sub {
60 $conf = FS::Conf->new;
61 $conf_encryption = $conf->exists('encryption');
62 $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
63 if ( driver_name eq 'Pg' ) {
64 eval "use DBD::Pg ':pg_types'";
67 eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }";
73 FS::Record - Database record objects
78 use FS::Record qw(dbh fields qsearch qsearchs);
80 $record = new FS::Record 'table', \%hash;
81 $record = new FS::Record 'table', { 'column' => 'value', ... };
83 $record = qsearchs FS::Record 'table', \%hash;
84 $record = qsearchs FS::Record 'table', { 'column' => 'value', ... };
85 @records = qsearch FS::Record 'table', \%hash;
86 @records = qsearch FS::Record 'table', { 'column' => 'value', ... };
88 $table = $record->table;
89 $dbdef_table = $record->dbdef_table;
91 $value = $record->get('column');
92 $value = $record->getfield('column');
93 $value = $record->column;
95 $record->set( 'column' => 'value' );
96 $record->setfield( 'column' => 'value' );
97 $record->column('value');
99 %hash = $record->hash;
101 $hashref = $record->hashref;
103 $error = $record->insert;
105 $error = $record->delete;
107 $error = $new_record->replace($old_record);
109 # external use deprecated - handled by the database (at least for Pg, mysql)
110 $value = $record->unique('column');
112 $error = $record->ut_float('column');
113 $error = $record->ut_floatn('column');
114 $error = $record->ut_number('column');
115 $error = $record->ut_numbern('column');
116 $error = $record->ut_snumber('column');
117 $error = $record->ut_snumbern('column');
118 $error = $record->ut_money('column');
119 $error = $record->ut_text('column');
120 $error = $record->ut_textn('column');
121 $error = $record->ut_alpha('column');
122 $error = $record->ut_alphan('column');
123 $error = $record->ut_phonen('column');
124 $error = $record->ut_anything('column');
125 $error = $record->ut_name('column');
127 $quoted_value = _quote($value,'table','field');
130 $fields = hfields('table');
131 if ( $fields->{Field} ) { # etc.
133 @fields = fields 'table'; #as a subroutine
134 @fields = $record->fields; #as a method call
139 (Mostly) object-oriented interface to database records. Records are currently
140 implemented on top of DBI. FS::Record is intended as a base class for
141 table-specific classes to inherit from, i.e. FS::cust_main.
147 =item new [ TABLE, ] HASHREF
149 Creates a new record. It doesn't store it in the database, though. See
150 L<"insert"> for that.
152 Note that the object stores this hash reference, not a distinct copy of the
153 hash it points to. You can ask the object for a copy with the I<hash>
156 TABLE can only be omitted when a dervived class overrides the table method.
162 my $class = ref($proto) || $proto;
164 bless ($self, $class);
166 unless ( defined ( $self->table ) ) {
167 $self->{'Table'} = shift;
168 carp "warning: FS::Record::new called with table name ". $self->{'Table'}
169 unless $nowarn_classload;
172 $self->{'Hash'} = shift;
174 foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
175 $self->{'Hash'}{$field}='';
178 $self->_rebless if $self->can('_rebless');
180 $self->{'modified'} = 0;
182 $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
189 my $class = ref($proto) || $proto;
191 bless ($self, $class);
193 $self->{'Table'} = shift unless defined ( $self->table );
195 my $hashref = $self->{'Hash'} = shift;
197 if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
198 my $obj = $cache->cache->{$hashref->{$cache->key}};
199 $obj->_cache($hashref, $cache) if $obj->can('_cache');
202 $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
209 my $class = ref($proto) || $proto;
211 bless ($self, $class);
212 if ( defined $self->table ) {
213 cluck "create constructor is deprecated, use new!";
216 croak "FS::Record::create called (not from a subclass)!";
220 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
222 Searches the database for all records matching (at least) the key/value pairs
223 in HASHREF. Returns all the records found as `FS::TABLE' objects if that
224 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
227 The preferred usage is to pass a hash reference of named parameters:
229 @records = qsearch( {
230 'table' => 'table_name',
231 'hashref' => { 'field' => 'value'
232 'field' => { 'op' => '<',
237 #these are optional...
239 'extra_sql' => 'AND field = ? AND intfield = ?',
240 'extra_param' => [ 'value', [ 5, 'int' ] ],
241 'order_by' => 'ORDER BY something',
242 #'cache_obj' => '', #optional
243 'addl_from' => 'LEFT JOIN othtable USING ( field )',
248 Much code still uses old-style positional parameters, this is also probably
249 fine in the common case where there are only two parameters:
251 my @records = qsearch( 'table', { 'field' => 'value' } );
253 Also possible is an experimental LISTREF of PARAMS_HASHREFs for a UNION of
254 the individual PARAMS_HASHREF queries
256 ###oops, argh, FS::Record::new only lets us create database fields.
257 #Normal behaviour if SELECT is not specified is `*', as in
258 #C<SELECT * FROM table WHERE ...>. However, there is an experimental new
259 #feature where you can specify SELECT - remember, the objects returned,
260 #although blessed into the appropriate `FS::TABLE' package, will only have the
261 #fields you specify. This might have unwanted results if you then go calling
262 #regular FS::TABLE methods
267 my %TYPE = (); #for debugging
270 my($type, $value) = @_;
272 my $bind_type = { TYPE => SQL_VARCHAR };
274 if ( $type =~ /(big)?(int|serial)/i && $value =~ /^\d+(\.\d+)?$/ ) {
276 $bind_type = { TYPE => SQL_INTEGER };
278 } elsif ( $type =~ /^bytea$/i || $type =~ /(blob|varbinary)/i ) {
280 if ( driver_name eq 'Pg' ) {
282 $bind_type = { pg_type => PG_BYTEA };
284 # $bind_type = ? #SQL_VARCHAR could be fine?
287 #DBD::Pg 1.49: Cannot bind ... unknown sql_type 6 with SQL_FLOAT
288 #fixed by DBD::Pg 2.11.8
289 #can change back to SQL_FLOAT in early-mid 2010, once everyone's upgraded
290 #(make a Tron test first)
291 } elsif ( _is_fs_float( $type, $value ) ) {
293 $bind_type = { TYPE => SQL_DECIMAL };
302 my($type, $value) = @_;
303 if ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/ ) ||
304 ( $type =~ /(real|float4)/i && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/)
312 my( @stable, @record, @cache );
313 my( @select, @extra_sql, @extra_param, @order_by, @addl_from );
315 my %union_options = ();
316 if ( ref($_[0]) eq 'ARRAY' ) {
319 foreach my $href ( @$optlist ) {
320 push @stable, ( $href->{'table'} or die "table name is required" );
321 push @record, ( $href->{'hashref'} || {} );
322 push @select, ( $href->{'select'} || '*' );
323 push @extra_sql, ( $href->{'extra_sql'} || '' );
324 push @extra_param, ( $href->{'extra_param'} || [] );
325 push @order_by, ( $href->{'order_by'} || '' );
326 push @cache, ( $href->{'cache_obj'} || '' );
327 push @addl_from, ( $href->{'addl_from'} || '' );
328 push @debug, ( $href->{'debug'} || '' );
330 die "at least one hashref is required" unless scalar(@stable);
331 } elsif ( ref($_[0]) eq 'HASH' ) {
333 $stable[0] = $opt->{'table'} or die "table name is required";
334 $record[0] = $opt->{'hashref'} || {};
335 $select[0] = $opt->{'select'} || '*';
336 $extra_sql[0] = $opt->{'extra_sql'} || '';
337 $extra_param[0] = $opt->{'extra_param'} || [];
338 $order_by[0] = $opt->{'order_by'} || '';
339 $cache[0] = $opt->{'cache_obj'} || '';
340 $addl_from[0] = $opt->{'addl_from'} || '';
341 $debug[0] = $opt->{'debug'} || '';
352 my $cache = $cache[0];
358 foreach my $stable ( @stable ) {
359 #stop altering the caller's hashref
360 my $record = { %{ shift(@record) || {} } };#and be liberal in receipt
361 my $select = shift @select;
362 my $extra_sql = shift @extra_sql;
363 my $extra_param = shift @extra_param;
364 my $order_by = shift @order_by;
365 my $cache = shift @cache;
366 my $addl_from = shift @addl_from;
367 my $debug = shift @debug;
369 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
371 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
374 my $table = $cache ? $cache->table : $stable;
375 my $dbdef_table = dbdef->table($table)
376 or die "No schema for table $table found - ".
377 "do you need to run freeside-upgrade?";
378 my $pkey = $dbdef_table->primary_key;
380 my @real_fields = grep exists($record->{$_}), real_fields($table);
382 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
383 @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
385 cluck "warning: FS::$table not loaded; virtual fields not searchable"
386 unless $nowarn_classload;
387 @virtual_fields = ();
390 my $statement .= "SELECT $select FROM $stable";
391 $statement .= " $addl_from" if $addl_from;
392 if ( @real_fields or @virtual_fields ) {
393 $statement .= ' WHERE '. join(' AND ',
394 get_real_fields($table, $record, \@real_fields) ,
395 get_virtual_fields($table, $pkey, $record, \@virtual_fields),
399 $statement .= " $extra_sql" if defined($extra_sql);
400 $statement .= " $order_by" if defined($order_by);
402 push @statement, $statement;
404 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
408 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
411 my $value = $record->{$field};
412 my $op = (ref($value) && $value->{op}) ? $value->{op} : '=';
413 $value = $value->{'value'} if ref($value);
414 my $type = dbdef->table($table)->column($field)->type;
416 my $bind_type = _bind_type($type, $value);
420 # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
422 # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
426 push @bind_type, $bind_type;
430 foreach my $param ( @$extra_param ) {
431 my $bind_type = { TYPE => SQL_VARCHAR };
434 $value = $param->[0];
435 my $type = $param->[1];
436 $bind_type = _bind_type($type, $value);
439 push @bind_type, $bind_type;
443 my $statement = join( ' ) UNION ( ', @statement );
444 $statement = "( $statement )" if scalar(@statement) > 1;
445 $statement .= " $union_options{order_by}" if $union_options{order_by};
447 my $sth = $dbh->prepare($statement)
448 or croak "$dbh->errstr doing $statement";
451 foreach my $value ( @value ) {
452 my $bind_type = shift @bind_type;
453 $sth->bind_param($bind++, $value, $bind_type );
456 # $sth->execute( map $record->{$_},
457 # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
458 # ) or croak "Error executing \"$statement\": ". $sth->errstr;
460 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
462 # virtual fields and blessings are nonsense in a heterogeneous UNION, right?
463 my $table = $stable[0];
465 $table = '' if grep { $_ ne $table } @stable;
466 $pkey = dbdef->table($table)->primary_key if $table;
468 my @virtual_fields = ();
469 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
470 @virtual_fields = "FS::$table"->virtual_fields;
472 cluck "warning: FS::$table not loaded; virtual fields not returned either"
473 unless $nowarn_classload;
474 @virtual_fields = ();
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;
488 if ( keys(%result) and @virtual_fields ) {
490 "SELECT virtual_field.recnum, part_virtual_field.name, ".
491 "virtual_field.value ".
492 "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ".
493 "WHERE part_virtual_field.dbtable = '$table' AND ".
494 "virtual_field.recnum IN (".
495 join(',', keys(%result)). ") AND part_virtual_field.name IN ('".
496 join(q!', '!, @virtual_fields) . "')";
497 warn "[debug]$me $statement\n" if $DEBUG > 1;
498 $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement";
499 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
501 foreach (@{ $sth->fetchall_arrayref({}) }) {
502 my $recnum = $_->{recnum};
503 my $name = $_->{name};
504 my $value = $_->{value};
505 if (exists($result{$recnum})) {
506 $result{$recnum}->{$name} = $value;
511 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
512 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
513 #derivied class didn't override new method, so this optimization is safe
516 new_or_cached( "FS::$table", { %{$_} }, $cache )
520 new( "FS::$table", { %{$_} } )
524 #okay, its been tested
525 # warn "untested code (class FS::$table uses custom new method)";
527 eval 'FS::'. $table. '->new( { %{$_} } )';
531 # Check for encrypted fields and decrypt them.
532 ## only in the local copy, not the cached object
533 if ( $conf_encryption
534 && eval 'defined(@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, { %{$_} } );
557 ## makes this easier to read
559 sub get_virtual_fields {
563 my $virtual_fields = shift;
569 if ( ref($record->{$_}) ) {
570 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
571 if ( uc($op) eq 'ILIKE' ) {
573 $record->{$_}{'value'} = lc($record->{$_}{'value'});
574 $column = "LOWER($_)";
576 $record->{$_} = $record->{$_}{'value'};
579 # ... EXISTS ( SELECT name, value FROM part_virtual_field
581 # ON part_virtual_field.vfieldpart = virtual_field.vfieldpart
582 # WHERE recnum = svc_acct.svcnum
583 # AND (name, value) = ('egad', 'brain') )
585 my $value = $record->{$_};
589 $subq = ($value ? 'EXISTS ' : 'NOT EXISTS ') .
590 "( SELECT part_virtual_field.name, virtual_field.value ".
591 "FROM part_virtual_field JOIN virtual_field ".
592 "ON part_virtual_field.vfieldpart = virtual_field.vfieldpart ".
593 "WHERE virtual_field.recnum = ${table}.${pkey} ".
594 "AND part_virtual_field.name = '${column}'".
596 " AND virtual_field.value ${op} '${value}'"
600 } @{ $virtual_fields } ) ;
603 sub get_real_fields {
606 my $real_fields = shift;
608 ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability
614 my $type = dbdef->table($table)->column($column)->type;
615 my $value = $record->{$column};
616 $value = $value->{'value'} if ref($value);
617 if ( ref($record->{$_}) ) {
618 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
619 #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
620 if ( uc($op) eq 'ILIKE' ) {
622 $record->{$_}{'value'} = lc($record->{$_}{'value'});
623 $column = "LOWER($_)";
625 $record->{$_} = $record->{$_}{'value'}
628 if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
630 if ( driver_name eq 'Pg' ) {
631 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
632 qq-( $column IS NULL )-;
634 qq-( $column IS NULL OR $column = '' )-;
637 qq-( $column IS NULL OR $column = "" )-;
639 } elsif ( $op eq '!=' ) {
640 if ( driver_name eq 'Pg' ) {
641 if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) {
642 qq-( $column IS NOT NULL )-;
644 qq-( $column IS NOT NULL AND $column != '' )-;
647 qq-( $column IS NOT NULL AND $column != "" )-;
650 if ( driver_name eq 'Pg' ) {
651 qq-( $column $op '' )-;
653 qq-( $column $op "" )-;
656 #if this needs to be re-enabled, it needs to use a custom op like
657 #"APPROX=" or something (better name?, not '=', to avoid affecting other
659 #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) {
660 # ( "$column <= ?", "$column >= ?" );
664 } @{ $real_fields } );
667 =item by_key PRIMARY_KEY_VALUE
669 This is a class method that returns the record with the given primary key
670 value. This method is only useful in FS::Record subclasses. For example:
672 my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
676 my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
681 my ($class, $pkey_value) = @_;
683 my $table = $class->table
684 or croak "No table for $class found";
686 my $dbdef_table = dbdef->table($table)
687 or die "No schema for table $table found - ".
688 "do you need to create it or run dbdef-create?";
689 my $pkey = $dbdef_table->primary_key
690 or die "No primary key for table $table";
692 return qsearchs($table, { $pkey => $pkey_value });
695 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
697 Experimental JOINed search method. Using this method, you can execute a
698 single SELECT spanning multiple tables, and cache the results for subsequent
699 method calls. Interface will almost definately change in an incompatible
707 my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
708 my $cache = FS::SearchCache->new( $ptable, $pkey );
711 grep { !$saw{$_->getfield($pkey)}++ }
712 qsearch($table, $record, $select, $extra_sql, $cache )
716 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
718 Same as qsearch, except that if more than one record matches, it B<carp>s but
719 returns the first. If this happens, you either made a logic error in asking
720 for a single item, or your data is corrupted.
724 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
726 my(@result) = qsearch(@_);
727 cluck "warning: Multiple records in scalar search ($table)"
728 if scalar(@result) > 1;
729 #should warn more vehemently if the search was on a primary key?
730 scalar(@result) ? ($result[0]) : ();
741 Returns the table name.
746 # cluck "warning: FS::Record::table deprecated; supply one in subclass!";
753 Returns the DBIx::DBSchema::Table object for the table.
759 my($table)=$self->table;
760 dbdef->table($table);
765 Returns the primary key for the table.
771 my $pkey = $self->dbdef_table->primary_key;
774 =item get, getfield COLUMN
776 Returns the value of the column/field/key COLUMN.
781 my($self,$field) = @_;
782 # to avoid "Use of unitialized value" errors
783 if ( defined ( $self->{Hash}->{$field} ) ) {
784 $self->{Hash}->{$field};
794 =item set, setfield COLUMN, VALUE
796 Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE.
801 my($self,$field,$value) = @_;
802 $self->{'modified'} = 1;
803 $self->{'Hash'}->{$field} = $value;
812 Returns true if the column/field/key COLUMN exists.
817 my($self,$field) = @_;
818 exists($self->{Hash}->{$field});
821 =item AUTLOADED METHODS
823 $record->column is a synonym for $record->get('column');
825 $record->column('value') is a synonym for $record->set('column','value');
832 my($field)=$AUTOLOAD;
834 if ( defined($value) ) {
835 confess "errant AUTOLOAD $field for $self (arg $value)"
836 unless blessed($self) && $self->can('setfield');
837 $self->setfield($field,$value);
839 confess "errant AUTOLOAD $field for $self (no args)"
840 unless blessed($self) && $self->can('getfield');
841 $self->getfield($field);
847 # my $field = $AUTOLOAD;
849 # if ( defined($_[1]) ) {
850 # $_[0]->setfield($field, $_[1]);
852 # $_[0]->getfield($field);
858 Returns a list of the column/value pairs, usually for assigning to a new hash.
860 To make a distinct duplicate of an FS::Record object, you can do:
862 $new = new FS::Record ( $old->table, { $old->hash } );
868 confess $self. ' -> hash: Hash attribute is undefined'
869 unless defined($self->{'Hash'});
870 %{ $self->{'Hash'} };
875 Returns a reference to the column/value hash. This may be deprecated in the
876 future; if there's a reason you can't just use the autoloaded or get/set
888 Returns true if any of this object's values have been modified with set (or via
889 an autoloaded method). Doesn't yet recognize when you retreive a hashref and
899 =item select_for_update
901 Selects this record with the SQL "FOR UPDATE" command. This can be useful as
906 sub select_for_update {
908 my $primary_key = $self->primary_key;
911 'table' => $self->table,
912 'hashref' => { $primary_key => $self->$primary_key() },
913 'extra_sql' => 'FOR UPDATE',
919 Locks this table with a database-driver specific lock method. This is used
920 as a mutex in order to do a duplicate search.
922 For PostgreSQL, does "LOCK TABLE tablename IN SHARE ROW EXCLUSIVE MODE".
924 For MySQL, does a SELECT FOR UPDATE on the duplicate_lock table.
926 Errors are fatal; no useful return value.
928 Note: To use this method for new tables other than svc_acct and svc_phone,
929 edit freeside-upgrade and add those tables to the duplicate_lock list.
935 my $table = $self->table;
937 warn "$me locking $table table\n" if $DEBUG;
939 if ( driver_name =~ /^Pg/i ) {
941 dbh->do("LOCK TABLE $table IN SHARE ROW EXCLUSIVE MODE")
944 } elsif ( driver_name =~ /^mysql/i ) {
946 dbh->do("SELECT * FROM duplicate_lock
947 WHERE lockname = '$table'
949 ) or die dbh->errstr;
953 die "unknown database ". driver_name. "; don't know how to lock table";
957 warn "$me acquired $table table lock\n" if $DEBUG;
963 Inserts this record to the database. If there is an error, returns the error,
964 otherwise returns false.
972 warn "$self -> insert" if $DEBUG;
974 my $error = $self->check;
975 return $error if $error;
977 #single-field unique keys are given a value if false
978 #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
979 foreach ( $self->dbdef_table->unique_singles) {
980 $self->unique($_) unless $self->getfield($_);
983 #and also the primary key, if the database isn't going to
984 my $primary_key = $self->dbdef_table->primary_key;
986 if ( $primary_key ) {
987 my $col = $self->dbdef_table->column($primary_key);
990 uc($col->type) =~ /^(BIG)?SERIAL\d?/
991 || ( driver_name eq 'Pg'
992 && defined($col->default)
993 && $col->quoted_default =~ /^nextval\(/i
995 || ( driver_name eq 'mysql'
996 && defined($col->local)
997 && $col->local =~ /AUTO_INCREMENT/i
999 $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
1002 my $table = $self->table;
1004 # Encrypt before the database
1005 if ( defined(eval '@FS::'. $table . '::encrypted_fields')
1006 && scalar( eval '@FS::'. $table . '::encrypted_fields')
1007 && $conf->exists('encryption')
1009 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
1010 next if $field eq 'payinfo'
1011 && ($self->isa('FS::payinfo_transaction_Mixin')
1012 || $self->isa('FS::payinfo_Mixin') )
1014 && !grep { $self->payby eq $_ } @encrypt_payby;
1015 $self->{'saved'} = $self->getfield($field);
1016 $self->setfield($field, $self->encrypt($self->getfield($field)));
1020 #false laziness w/delete
1022 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1025 my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
1028 my $statement = "INSERT INTO $table ";
1029 if ( @real_fields ) {
1032 join( ', ', @real_fields ).
1034 join( ', ', @values ).
1038 $statement .= 'DEFAULT VALUES';
1040 warn "[debug]$me $statement\n" if $DEBUG > 1;
1041 my $sth = dbh->prepare($statement) or return dbh->errstr;
1043 local $SIG{HUP} = 'IGNORE';
1044 local $SIG{INT} = 'IGNORE';
1045 local $SIG{QUIT} = 'IGNORE';
1046 local $SIG{TERM} = 'IGNORE';
1047 local $SIG{TSTP} = 'IGNORE';
1048 local $SIG{PIPE} = 'IGNORE';
1050 $sth->execute or return $sth->errstr;
1052 # get inserted id from the database, if applicable & needed
1053 if ( $db_seq && ! $self->getfield($primary_key) ) {
1054 warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
1058 if ( driver_name eq 'Pg' ) {
1060 #my $oid = $sth->{'pg_oid_status'};
1061 #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
1063 my $default = $self->dbdef_table->column($primary_key)->quoted_default;
1064 unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
1065 dbh->rollback if $FS::UID::AutoCommit;
1066 return "can't parse $table.$primary_key default value".
1067 " for sequence name: $default";
1071 my $i_sql = "SELECT currval('$sequence')";
1072 my $i_sth = dbh->prepare($i_sql) or do {
1073 dbh->rollback if $FS::UID::AutoCommit;
1076 $i_sth->execute() or do { #$i_sth->execute($oid)
1077 dbh->rollback if $FS::UID::AutoCommit;
1078 return $i_sth->errstr;
1080 $insertid = $i_sth->fetchrow_arrayref->[0];
1082 } elsif ( driver_name eq 'mysql' ) {
1084 $insertid = dbh->{'mysql_insertid'};
1085 # work around mysql_insertid being null some of the time, ala RT :/
1086 unless ( $insertid ) {
1087 warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
1088 "using SELECT LAST_INSERT_ID();";
1089 my $i_sql = "SELECT LAST_INSERT_ID()";
1090 my $i_sth = dbh->prepare($i_sql) or do {
1091 dbh->rollback if $FS::UID::AutoCommit;
1094 $i_sth->execute or do {
1095 dbh->rollback if $FS::UID::AutoCommit;
1096 return $i_sth->errstr;
1098 $insertid = $i_sth->fetchrow_arrayref->[0];
1103 dbh->rollback if $FS::UID::AutoCommit;
1104 return "don't know how to retreive inserted ids from ". driver_name.
1105 ", try using counterfiles (maybe run dbdef-create?)";
1109 $self->setfield($primary_key, $insertid);
1113 my @virtual_fields =
1114 grep defined($self->getfield($_)) && $self->getfield($_) ne "",
1115 $self->virtual_fields;
1116 if (@virtual_fields) {
1117 my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
1119 my $vfieldpart = $self->vfieldpart_hashref;
1121 my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
1124 my $v_sth = dbh->prepare($v_statement) or do {
1125 dbh->rollback if $FS::UID::AutoCommit;
1129 foreach (keys(%v_values)) {
1130 $v_sth->execute($self->getfield($primary_key),
1134 dbh->rollback if $FS::UID::AutoCommit;
1135 return $v_sth->errstr;
1142 if ( defined dbdef->table('h_'. $table) ) {
1143 my $h_statement = $self->_h_statement('insert');
1144 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1145 $h_sth = dbh->prepare($h_statement) or do {
1146 dbh->rollback if $FS::UID::AutoCommit;
1152 $h_sth->execute or return $h_sth->errstr if $h_sth;
1154 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1156 # Now that it has been saved, reset the encrypted fields so that $new
1157 # can still be used.
1158 foreach my $field (keys %{$saved}) {
1159 $self->setfield($field, $saved->{$field});
1167 Depriciated (use insert instead).
1172 cluck "warning: FS::Record::add deprecated!";
1173 insert @_; #call method in this scope
1178 Delete this record from the database. If there is an error, returns the error,
1179 otherwise returns false.
1186 my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
1188 $self->getfield($_) eq ''
1189 #? "( $_ IS NULL OR $_ = \"\" )"
1190 ? ( driver_name eq 'Pg'
1192 : "( $_ IS NULL OR $_ = \"\" )"
1194 : "$_ = ". _quote($self->getfield($_),$self->table,$_)
1195 } ( $self->dbdef_table->primary_key )
1196 ? ( $self->dbdef_table->primary_key)
1197 : real_fields($self->table)
1199 warn "[debug]$me $statement\n" if $DEBUG > 1;
1200 my $sth = dbh->prepare($statement) or return dbh->errstr;
1203 if ( defined dbdef->table('h_'. $self->table) ) {
1204 my $h_statement = $self->_h_statement('delete');
1205 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1206 $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1211 my $primary_key = $self->dbdef_table->primary_key;
1214 my $vfp = $self->vfieldpart_hashref;
1215 foreach($self->virtual_fields) {
1216 next if $self->getfield($_) eq '';
1217 unless(@del_vfields) {
1218 my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
1219 $v_sth = dbh->prepare($st) or return dbh->errstr;
1221 push @del_vfields, $_;
1224 local $SIG{HUP} = 'IGNORE';
1225 local $SIG{INT} = 'IGNORE';
1226 local $SIG{QUIT} = 'IGNORE';
1227 local $SIG{TERM} = 'IGNORE';
1228 local $SIG{TSTP} = 'IGNORE';
1229 local $SIG{PIPE} = 'IGNORE';
1231 my $rc = $sth->execute or return $sth->errstr;
1232 #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1233 $h_sth->execute or return $h_sth->errstr if $h_sth;
1234 $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
1235 or return $v_sth->errstr
1236 foreach (@del_vfields);
1238 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1240 #no need to needlessly destoy the data either (causes problems actually)
1241 #undef $self; #no need to keep object!
1248 Depriciated (use delete instead).
1253 cluck "warning: FS::Record::del deprecated!";
1254 &delete(@_); #call method in this scope
1257 =item replace OLD_RECORD
1259 Replace the OLD_RECORD with this one in the database. If there is an error,
1260 returns the error, otherwise returns false.
1265 my ($new, $old) = (shift, shift);
1267 $old = $new->replace_old unless defined($old);
1269 warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1271 if ( $new->can('replace_check') ) {
1272 my $error = $new->replace_check($old);
1273 return $error if $error;
1276 return "Records not in same table!" unless $new->table eq $old->table;
1278 my $primary_key = $old->dbdef_table->primary_key;
1279 return "Can't change primary key $primary_key ".
1280 'from '. $old->getfield($primary_key).
1281 ' to ' . $new->getfield($primary_key)
1283 && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1285 my $error = $new->check;
1286 return $error if $error;
1288 # Encrypt for replace
1290 if ( $conf->exists('encryption')
1291 && defined(eval '@FS::'. $new->table . '::encrypted_fields')
1292 && scalar( eval '@FS::'. $new->table . '::encrypted_fields')
1294 foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1295 next if $field eq 'payinfo'
1296 && ($new->isa('FS::payinfo_transaction_Mixin')
1297 || $new->isa('FS::payinfo_Mixin') )
1299 && !grep { $new->payby eq $_ } @encrypt_payby;
1300 $saved->{$field} = $new->getfield($field);
1301 $new->setfield($field, $new->encrypt($new->getfield($field)));
1305 #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1306 my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1307 ? ($_, $new->getfield($_)) : () } $old->fields;
1309 unless (keys(%diff) || $no_update_diff ) {
1310 carp "[warning]$me $new -> replace $old: records identical"
1311 unless $nowarn_identical;
1315 my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1317 "$_ = ". _quote($new->getfield($_),$old->table,$_)
1318 } real_fields($old->table)
1323 if ( $old->getfield($_) eq '' ) {
1325 #false laziness w/qsearch
1326 if ( driver_name eq 'Pg' ) {
1327 my $type = $old->dbdef_table->column($_)->type;
1328 if ( $type =~ /(int|(big)?serial)/i ) {
1331 qq-( $_ IS NULL OR $_ = '' )-;
1334 qq-( $_ IS NULL OR $_ = "" )-;
1338 "$_ = ". _quote($old->getfield($_),$old->table,$_);
1341 } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1344 warn "[debug]$me $statement\n" if $DEBUG > 1;
1345 my $sth = dbh->prepare($statement) or return dbh->errstr;
1348 if ( defined dbdef->table('h_'. $old->table) ) {
1349 my $h_old_statement = $old->_h_statement('replace_old');
1350 warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1351 $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1357 if ( defined dbdef->table('h_'. $new->table) ) {
1358 my $h_new_statement = $new->_h_statement('replace_new');
1359 warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1360 $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1365 # For virtual fields we have three cases with different SQL
1366 # statements: add, replace, delete
1370 my (@add_vfields, @rep_vfields, @del_vfields);
1371 my $vfp = $old->vfieldpart_hashref;
1372 foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
1373 if($diff{$_} eq '') {
1375 unless(@del_vfields) {
1376 my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
1377 "AND vfieldpart = ?";
1378 warn "[debug]$me $st\n" if $DEBUG > 2;
1379 $v_del_sth = dbh->prepare($st) or return dbh->errstr;
1381 push @del_vfields, $_;
1382 } elsif($old->getfield($_) eq '') {
1384 unless(@add_vfields) {
1385 my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
1387 warn "[debug]$me $st\n" if $DEBUG > 2;
1388 $v_add_sth = dbh->prepare($st) or return dbh->errstr;
1390 push @add_vfields, $_;
1393 unless(@rep_vfields) {
1394 my $st = "UPDATE virtual_field SET value = ? ".
1395 "WHERE recnum = ? AND vfieldpart = ?";
1396 warn "[debug]$me $st\n" if $DEBUG > 2;
1397 $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
1399 push @rep_vfields, $_;
1403 local $SIG{HUP} = 'IGNORE';
1404 local $SIG{INT} = 'IGNORE';
1405 local $SIG{QUIT} = 'IGNORE';
1406 local $SIG{TERM} = 'IGNORE';
1407 local $SIG{TSTP} = 'IGNORE';
1408 local $SIG{PIPE} = 'IGNORE';
1410 my $rc = $sth->execute or return $sth->errstr;
1411 #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1412 $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1413 $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1415 $v_del_sth->execute($old->getfield($primary_key),
1417 or return $v_del_sth->errstr
1418 foreach(@del_vfields);
1420 $v_add_sth->execute($new->getfield($_),
1421 $old->getfield($primary_key),
1423 or return $v_add_sth->errstr
1424 foreach(@add_vfields);
1426 $v_rep_sth->execute($new->getfield($_),
1427 $old->getfield($primary_key),
1429 or return $v_rep_sth->errstr
1430 foreach(@rep_vfields);
1432 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1434 # Now that it has been saved, reset the encrypted fields so that $new
1435 # can still be used.
1436 foreach my $field (keys %{$saved}) {
1437 $new->setfield($field, $saved->{$field});
1445 my( $self ) = shift;
1446 warn "[$me] replace called with no arguments; autoloading old record\n"
1449 my $primary_key = $self->dbdef_table->primary_key;
1450 if ( $primary_key ) {
1451 $self->by_key( $self->$primary_key() ) #this is what's returned
1452 or croak "can't find ". $self->table. ".$primary_key ".
1453 $self->$primary_key();
1455 croak $self->table. " has no primary key; pass old record as argument";
1462 Depriciated (use replace instead).
1467 cluck "warning: FS::Record::rep deprecated!";
1468 replace @_; #call method in this scope
1473 Checks virtual fields (using check_blocks). Subclasses should still provide
1474 a check method to validate real fields, foreign keys, etc., and call this
1475 method via $self->SUPER::check.
1477 (FIXME: Should this method try to make sure that it I<is> being called from
1478 a subclass's check method, to keep the current semantics as far as possible?)
1483 #confess "FS::Record::check not implemented; supply one in subclass!";
1486 foreach my $field ($self->virtual_fields) {
1487 for ($self->getfield($field)) {
1488 # See notes on check_block in FS::part_virtual_field.
1489 eval $self->pvf($field)->check_block;
1491 #this is bad, probably want to follow the stack backtrace up and see
1493 my $err = "Fatal error checking $field for $self";
1495 return "$err (see log for backtrace): $@";
1498 $self->setfield($field, $_);
1504 =item process_batch_import JOB OPTIONS_HASHREF PARAMS
1506 Processes a batch import as a queued JSRPC job
1508 JOB is an FS::queue entry.
1510 OPTIONS_HASHREF can have the following keys:
1516 Table name (required).
1520 Listref of field names for static fields. They will be given values from the
1521 PARAMS hashref and passed as a "params" hashref to batch_import.
1525 Formats hashref. Keys are field names, values are listrefs that define the
1528 Each listref value can be a column name or a code reference. Coderefs are run
1529 with the row object, data and a FS::Conf object as the three parameters.
1530 For example, this coderef does the same thing as using the "columnname" string:
1533 my( $record, $data, $conf ) = @_;
1534 $record->columnname( $data );
1537 Coderefs are run after all "column name" fields are assigned.
1541 Optional format hashref of types. Keys are field names, values are "csv",
1542 "xls" or "fixedlength". Overrides automatic determination of file type
1545 =item format_headers
1547 Optional format hashref of header lines. Keys are field names, values are 0
1548 for no header, 1 to ignore the first line, or to higher numbers to ignore that
1551 =item format_sep_chars
1553 Optional format hashref of CSV sep_chars. Keys are field names, values are the
1554 CSV separation character.
1556 =item format_fixedlenth_formats
1558 Optional format hashref of fixed length format defintiions. Keys are field
1559 names, values Parse::FixedLength listrefs of field definitions.
1563 Set true to default to CSV file type if the filename does not contain a
1564 recognizable ".csv" or ".xls" extension (and type is not pre-specified by
1569 PARAMS is a base64-encoded Storable string containing the POSTed data as
1570 a hash ref. It normally contains at least one field, "uploaded files",
1571 generated by /elements/file-upload.html and containing the list of uploaded
1572 files. Currently only supports a single file named "file".
1576 use Storable qw(thaw);
1579 sub process_batch_import {
1580 my($job, $opt) = ( shift, shift );
1582 my $table = $opt->{table};
1583 my @pass_params = $opt->{params} ? @{ $opt->{params} } : ();
1584 my %formats = %{ $opt->{formats} };
1586 my $param = thaw(decode_base64(shift));
1587 warn Dumper($param) if $DEBUG;
1589 my $files = $param->{'uploaded_files'}
1590 or die "No files provided.\n";
1592 my (%files) = map { /^(\w+):([\.\w]+)$/ ? ($1,$2):() } split /,/, $files;
1594 my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/';
1595 my $file = $dir. $files{'file'};
1600 formats => \%formats,
1601 format_types => $opt->{format_types},
1602 format_headers => $opt->{format_headers},
1603 format_sep_chars => $opt->{format_sep_chars},
1604 format_fixedlength_formats => $opt->{format_fixedlength_formats},
1605 format_xml_formats => $opt->{format_xml_formats},
1606 format_row_callbacks => $opt->{format_row_callbacks},
1611 format => $param->{format},
1612 params => { map { $_ => $param->{$_} } @pass_params },
1614 default_csv => $opt->{default_csv},
1615 postinsert_callback => $opt->{postinsert_callback},
1618 if ( $opt->{'batch_namecol'} ) {
1619 $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} };
1620 $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol );
1623 my $error = FS::Record::batch_import( \%iopt );
1627 die "$error\n" if $error;
1630 =item batch_import PARAM_HASHREF
1632 Class method for batch imports. Available params:
1638 =item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes
1644 =item format_headers
1646 =item format_sep_chars
1648 =item format_fixedlength_formats
1650 =item format_row_callbacks
1652 =item fields - Alternate way to specify import, specifying import fields directly as a listref
1654 =item preinsert_callback
1656 =item postinsert_callback
1662 FS::queue object, will be updated with progress
1668 csv, xls, fixedlength, xml
1679 warn "$me batch_import call with params: \n". Dumper($param)
1682 my $table = $param->{table};
1684 my $job = $param->{job};
1685 my $file = $param->{file};
1686 my $params = $param->{params} || {};
1688 my( $type, $header, $sep_char, $fixedlength_format,
1689 $xml_format, $row_callback, @fields );
1691 my $postinsert_callback = '';
1692 $postinsert_callback = $param->{'postinsert_callback'}
1693 if $param->{'postinsert_callback'};
1694 my $preinsert_callback = '';
1695 $preinsert_callback = $param->{'preinsert_callback'}
1696 if $param->{'preinsert_callback'};
1698 if ( $param->{'format'} ) {
1700 my $format = $param->{'format'};
1701 my $formats = $param->{formats};
1702 die "unknown format $format" unless exists $formats->{ $format };
1704 $type = $param->{'format_types'}
1705 ? $param->{'format_types'}{ $format }
1706 : $param->{type} || 'csv';
1709 $header = $param->{'format_headers'}
1710 ? $param->{'format_headers'}{ $param->{'format'} }
1713 $sep_char = $param->{'format_sep_chars'}
1714 ? $param->{'format_sep_chars'}{ $param->{'format'} }
1717 $fixedlength_format =
1718 $param->{'format_fixedlength_formats'}
1719 ? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
1723 $param->{'format_xml_formats'}
1724 ? $param->{'format_xml_formats'}{ $param->{'format'} }
1728 $param->{'format_row_callbacks'}
1729 ? $param->{'format_row_callbacks'}{ $param->{'format'} }
1732 @fields = @{ $formats->{ $format } };
1734 } elsif ( $param->{'fields'} ) {
1736 $type = ''; #infer from filename
1739 $fixedlength_format = '';
1741 @fields = @{ $param->{'fields'} };
1744 die "neither format nor fields specified";
1747 #my $file = $param->{file};
1750 if ( $file =~ /\.(\w+)$/i ) {
1754 warn "can't parse file type from filename $file; defaulting to CSV";
1758 if $param->{'default_csv'} && $type ne 'xls';
1766 if ( $type eq 'csv' || $type eq 'fixedlength' ) {
1768 if ( $type eq 'csv' ) {
1771 $attr{sep_char} = $sep_char if $sep_char;
1772 $parser = new Text::CSV_XS \%attr;
1774 } elsif ( $type eq 'fixedlength' ) {
1776 eval "use Parse::FixedLength;";
1778 $parser = Parse::FixedLength->new($fixedlength_format);
1782 die "Unknown file type $type\n";
1785 @buffer = split(/\r?\n/, slurp($file) );
1786 splice(@buffer, 0, ($header || 0) );
1787 $count = scalar(@buffer);
1789 } elsif ( $type eq 'xls' ) {
1791 eval "use Spreadsheet::ParseExcel;";
1794 eval "use DateTime::Format::Excel;";
1795 #for now, just let the error be thrown if it is used, since only CDR
1796 # formats bill_west and troop use it, not other excel-parsing things
1799 my $excel = Spreadsheet::ParseExcel::Workbook->new->Parse($file);
1801 $parser = $excel->{Worksheet}[0]; #first sheet
1803 $count = $parser->{MaxRow} || $parser->{MinRow};
1806 $row = $header || 0;
1807 } elsif ( $type eq 'xml' ) {
1809 eval "use XML::Simple;";
1811 my $xmlrow = $xml_format->{'xmlrow'};
1812 $parser = $xml_format->{'xmlkeys'};
1813 die 'no xmlkeys specified' unless ref $parser eq 'ARRAY';
1814 my $data = XML::Simple::XMLin(
1816 'SuppressEmpty' => '', #sets empty values to ''
1820 $rows = $rows->{$_} foreach @$xmlrow;
1821 $rows = [ $rows ] if ref($rows) ne 'ARRAY';
1822 $count = @buffer = @$rows;
1824 die "Unknown file type $type\n";
1829 local $SIG{HUP} = 'IGNORE';
1830 local $SIG{INT} = 'IGNORE';
1831 local $SIG{QUIT} = 'IGNORE';
1832 local $SIG{TERM} = 'IGNORE';
1833 local $SIG{TSTP} = 'IGNORE';
1834 local $SIG{PIPE} = 'IGNORE';
1836 my $oldAutoCommit = $FS::UID::AutoCommit;
1837 local $FS::UID::AutoCommit = 0;
1840 #my $params = $param->{params} || {};
1841 if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) {
1842 my $batch_col = $param->{'batch_keycol'};
1844 my $batch_class = 'FS::'. $param->{'batch_table'};
1845 my $batch = $batch_class->new({
1846 $param->{'batch_namecol'} => $param->{'batch_namevalue'}
1848 my $error = $batch->insert;
1850 $dbh->rollback if $oldAutoCommit;
1851 return "can't insert batch record: $error";
1853 #primary key via dbdef? (so the column names don't have to match)
1854 my $batch_value = $batch->get( $param->{'batch_keycol'} );
1856 $params->{ $batch_col } = $batch_value;
1859 #my $job = $param->{job};
1862 my( $last, $min_sec ) = ( time, 5 ); #progressbar foo
1866 if ( $type eq 'csv' ) {
1868 last unless scalar(@buffer);
1869 $line = shift(@buffer);
1871 next if $line =~ /^\s*$/; #skip empty lines
1873 $line = &{$row_callback}($line) if $row_callback;
1875 next if $line =~ /^\s*$/; #skip empty lines
1877 $parser->parse($line) or do {
1878 $dbh->rollback if $oldAutoCommit;
1879 return "can't parse: ". $parser->error_input() . " " . $parser->error_diag;
1881 @columns = $parser->fields();
1883 } elsif ( $type eq 'fixedlength' ) {
1885 last unless scalar(@buffer);
1886 $line = shift(@buffer);
1888 @columns = $parser->parse($line);
1890 } elsif ( $type eq 'xls' ) {
1892 last if $row > ($parser->{MaxRow} || $parser->{MinRow})
1893 || ! $parser->{Cells}[$row];
1895 my @row = @{ $parser->{Cells}[$row] };
1896 @columns = map $_->{Val}, @row;
1899 #warn $z++. ": $_\n" for @columns;
1901 } elsif ( $type eq 'xml' ) {
1902 # $parser = [ 'Column0Key', 'Column1Key' ... ]
1903 last unless scalar(@buffer);
1904 my $row = shift @buffer;
1905 @columns = @{ $row }{ @$parser };
1907 die "Unknown file type $type\n";
1911 my %hash = %$params;
1913 foreach my $field ( @fields ) {
1915 my $value = shift @columns;
1917 if ( ref($field) eq 'CODE' ) {
1918 #&{$field}(\%hash, $value);
1919 push @later, $field, $value;
1921 #??? $hash{$field} = $value if length($value);
1922 $hash{$field} = $value if defined($value) && length($value);
1927 #my $table = $param->{table};
1928 my $class = "FS::$table";
1930 my $record = $class->new( \%hash );
1933 while ( scalar(@later) ) {
1934 my $sub = shift @later;
1935 my $data = shift @later;
1937 &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf)
1940 $dbh->rollback if $oldAutoCommit;
1941 return "can't insert record". ( $line ? " for $line" : '' ). ": $@";
1943 last if exists( $param->{skiprow} );
1945 next if exists( $param->{skiprow} );
1947 if ( $preinsert_callback ) {
1948 my $error = &{$preinsert_callback}($record, $param);
1950 $dbh->rollback if $oldAutoCommit;
1951 return "preinsert_callback error". ( $line ? " for $line" : '' ).
1954 next if exists $param->{skiprow} && $param->{skiprow};
1957 my $error = $record->insert;
1960 $dbh->rollback if $oldAutoCommit;
1961 return "can't insert record". ( $line ? " for $line" : '' ). ": $error";
1967 if ( $postinsert_callback ) {
1968 my $error = &{$postinsert_callback}($record, $param);
1970 $dbh->rollback if $oldAutoCommit;
1971 return "postinsert_callback error". ( $line ? " for $line" : '' ).
1976 if ( $job && time - $min_sec > $last ) { #progress bar
1977 $job->update_statustext( int(100 * $imported / $count) );
1983 unless ( $imported || $param->{empty_ok} ) {
1984 $dbh->rollback if $oldAutoCommit;
1985 return "Empty file!";
1988 $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
1995 my( $self, $action, $time ) = @_;
1999 my %nohistory = map { $_=>1 } $self->nohistory_fields;
2002 grep { defined($self->get($_)) && $self->get($_) ne "" && ! $nohistory{$_} }
2003 real_fields($self->table);
2006 # If we're encrypting then don't store the payinfo in the history
2007 if ( $conf && $conf->exists('encryption') ) {
2008 @fields = grep { $_ ne 'payinfo' } @fields;
2011 my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
2013 "INSERT INTO h_". $self->table. " ( ".
2014 join(', ', qw(history_date history_user history_action), @fields ).
2016 join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
2023 B<Warning>: External use is B<deprecated>.
2025 Replaces COLUMN in record with a unique number, using counters in the
2026 filesystem. Used by the B<insert> method on single-field unique columns
2027 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
2028 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
2030 Returns the new value.
2035 my($self,$field) = @_;
2036 my($table)=$self->table;
2038 croak "Unique called on field $field, but it is ",
2039 $self->getfield($field),
2041 if $self->getfield($field);
2043 #warn "table $table is tainted" if is_tainted($table);
2044 #warn "field $field is tainted" if is_tainted($field);
2046 my($counter) = new File::CounterFile "$table.$field",0;
2048 # getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
2050 # my($counter) = new File::CounterFile "$user/$table.$field",0;
2053 my $index = $counter->inc;
2054 $index = $counter->inc while qsearchs($table, { $field=>$index } );
2056 $index =~ /^(\d*)$/;
2059 $self->setfield($field,$index);
2063 =item ut_float COLUMN
2065 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be
2066 null. If there is an error, returns the error, otherwise returns false.
2071 my($self,$field)=@_ ;
2072 ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
2073 $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
2074 $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
2075 $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
2076 or return "Illegal or empty (float) $field: ". $self->getfield($field);
2077 $self->setfield($field,$1);
2080 =item ut_floatn COLUMN
2082 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
2083 null. If there is an error, returns the error, otherwise returns false.
2087 #false laziness w/ut_ipn
2089 my( $self, $field ) = @_;
2090 if ( $self->getfield($field) =~ /^()$/ ) {
2091 $self->setfield($field,'');
2094 $self->ut_float($field);
2098 =item ut_sfloat COLUMN
2100 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
2101 May not be null. If there is an error, returns the error, otherwise returns
2107 my($self,$field)=@_ ;
2108 ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
2109 $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
2110 $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
2111 $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
2112 or return "Illegal or empty (float) $field: ". $self->getfield($field);
2113 $self->setfield($field,$1);
2116 =item ut_sfloatn COLUMN
2118 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
2119 null. If there is an error, returns the error, otherwise returns false.
2124 my( $self, $field ) = @_;
2125 if ( $self->getfield($field) =~ /^()$/ ) {
2126 $self->setfield($field,'');
2129 $self->ut_sfloat($field);
2133 =item ut_snumber COLUMN
2135 Check/untaint signed numeric data (whole numbers). If there is an error,
2136 returns the error, otherwise returns false.
2141 my($self, $field) = @_;
2142 $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
2143 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2144 $self->setfield($field, "$1$2");
2148 =item ut_snumbern COLUMN
2150 Check/untaint signed numeric data (whole numbers). If there is an error,
2151 returns the error, otherwise returns false.
2156 my($self, $field) = @_;
2157 $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
2158 or return "Illegal (numeric) $field: ". $self->getfield($field);
2160 return "Illegal (numeric) $field: ". $self->getfield($field)
2163 $self->setfield($field, "$1$2");
2167 =item ut_number COLUMN
2169 Check/untaint simple numeric data (whole numbers). May not be null. If there
2170 is an error, returns the error, otherwise returns false.
2175 my($self,$field)=@_;
2176 $self->getfield($field) =~ /^\s*(\d+)\s*$/
2177 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
2178 $self->setfield($field,$1);
2182 =item ut_numbern COLUMN
2184 Check/untaint simple numeric data (whole numbers). May be null. If there is
2185 an error, returns the error, otherwise returns false.
2190 my($self,$field)=@_;
2191 $self->getfield($field) =~ /^\s*(\d*)\s*$/
2192 or return "Illegal (numeric) $field: ". $self->getfield($field);
2193 $self->setfield($field,$1);
2197 =item ut_money COLUMN
2199 Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
2200 is an error, returns the error, otherwise returns false.
2205 my($self,$field)=@_;
2206 $self->setfield($field, 0) if $self->getfield($field) eq '';
2207 $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/
2208 or return "Illegal (money) $field: ". $self->getfield($field);
2209 #$self->setfield($field, "$1$2$3" || 0);
2210 $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
2214 =item ut_moneyn COLUMN
2216 Check/untaint monetary numbers. May be negative. If there
2217 is an error, returns the error, otherwise returns false.
2222 my($self,$field)=@_;
2223 if ($self->getfield($field) eq '') {
2224 $self->setfield($field, '');
2227 $self->ut_money($field);
2230 =item ut_text COLUMN
2232 Check/untaint text. Alphanumerics, spaces, and the following punctuation
2233 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < >
2234 May not be null. If there is an error, returns the error, otherwise returns
2240 my($self,$field)=@_;
2241 #warn "msgcat ". \&msgcat. "\n";
2242 #warn "notexist ". \¬exist. "\n";
2243 #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
2244 $self->getfield($field)
2245 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>]+)$/
2246 or return gettext('illegal_or_empty_text'). " $field: ".
2247 $self->getfield($field);
2248 $self->setfield($field,$1);
2252 =item ut_textn COLUMN
2254 Check/untaint text. Alphanumerics, spaces, and the following punctuation
2255 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
2256 May be null. If there is an error, returns the error, otherwise returns false.
2261 my($self,$field)=@_;
2262 return $self->setfield($field, '') if $self->getfield($field) =~ /^$/;
2263 $self->ut_text($field);
2266 =item ut_alpha COLUMN
2268 Check/untaint alphanumeric strings (no spaces). May not be null. If there is
2269 an error, returns the error, otherwise returns false.
2274 my($self,$field)=@_;
2275 $self->getfield($field) =~ /^(\w+)$/
2276 or return "Illegal or empty (alphanumeric) $field: ".
2277 $self->getfield($field);
2278 $self->setfield($field,$1);
2282 =item ut_alphan COLUMN
2284 Check/untaint alphanumeric strings (no spaces). May be null. If there is an
2285 error, returns the error, otherwise returns false.
2290 my($self,$field)=@_;
2291 $self->getfield($field) =~ /^(\w*)$/
2292 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2293 $self->setfield($field,$1);
2297 =item ut_alphasn COLUMN
2299 Check/untaint alphanumeric strings, spaces allowed. May be null. If there is
2300 an error, returns the error, otherwise returns false.
2305 my($self,$field)=@_;
2306 $self->getfield($field) =~ /^([\w ]*)$/
2307 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
2308 $self->setfield($field,$1);
2313 =item ut_alpha_lower COLUMN
2315 Check/untaint lowercase alphanumeric strings (no spaces). May not be null. If
2316 there is an error, returns the error, otherwise returns false.
2320 sub ut_alpha_lower {
2321 my($self,$field)=@_;
2322 $self->getfield($field) =~ /[[:upper:]]/
2323 and return "Uppercase characters are not permitted in $field";
2324 $self->ut_alpha($field);
2327 =item ut_phonen COLUMN [ COUNTRY ]
2329 Check/untaint phone numbers. May be null. If there is an error, returns
2330 the error, otherwise returns false.
2332 Takes an optional two-letter ISO country code; without it or with unsupported
2333 countries, ut_phonen simply calls ut_alphan.
2338 my( $self, $field, $country ) = @_;
2339 return $self->ut_alphan($field) unless defined $country;
2340 my $phonen = $self->getfield($field);
2341 if ( $phonen eq '' ) {
2342 $self->setfield($field,'');
2343 } elsif ( $country eq 'US' || $country eq 'CA' ) {
2345 $phonen = $conf->config('cust_main-default_areacode').$phonen
2346 if length($phonen)==7 && $conf->config('cust_main-default_areacode');
2347 $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
2348 or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
2349 $phonen = "$1-$2-$3";
2350 $phonen .= " x$4" if $4;
2351 $self->setfield($field,$phonen);
2353 warn "warning: don't know how to check phone numbers for country $country";
2354 return $self->ut_textn($field);
2361 Check/untaint hexadecimal values.
2366 my($self, $field) = @_;
2367 $self->getfield($field) =~ /^([\da-fA-F]+)$/
2368 or return "Illegal (hex) $field: ". $self->getfield($field);
2369 $self->setfield($field, uc($1));
2373 =item ut_hexn COLUMN
2375 Check/untaint hexadecimal values. May be null.
2380 my($self, $field) = @_;
2381 $self->getfield($field) =~ /^([\da-fA-F]*)$/
2382 or return "Illegal (hex) $field: ". $self->getfield($field);
2383 $self->setfield($field, uc($1));
2388 Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
2394 my( $self, $field ) = @_;
2395 $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1';
2396 $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
2397 or return "Illegal (IP address) $field: ". $self->getfield($field);
2398 for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
2399 $self->setfield($field, "$1.$2.$3.$4");
2405 Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated
2406 to 127.0.0.1. May be null.
2411 my( $self, $field ) = @_;
2412 if ( $self->getfield($field) =~ /^()$/ ) {
2413 $self->setfield($field,'');
2416 $self->ut_ip($field);
2420 =item ut_ip46 COLUMN
2422 Check/untaint IPv4 or IPv6 address.
2427 my( $self, $field ) = @_;
2428 my $ip = NetAddr::IP->new($self->getfield($field))
2429 or return "Illegal (IP address) $field: ".$self->getfield($field);
2430 $self->setfield($field, lc($ip->addr));
2436 Check/untaint IPv6 or IPv6 address. May be null.
2441 my( $self, $field ) = @_;
2442 if ( $self->getfield($field) =~ /^$/ ) {
2443 $self->setfield($field, '');
2446 $self->ut_ip46($field);
2449 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
2451 Check/untaint coordinates.
2452 Accepts the following forms:
2462 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
2463 The latter form (that is, the MMM are thousands of minutes) is
2464 assumed if the "MMM" is exactly three digits or two digits > 59.
2466 To be safe, just use the DDD.DDDDD form.
2468 If LOWER or UPPER are specified, then the coordinate is checked
2469 for lower and upper bounds, respectively.
2475 my ($self, $field) = (shift, shift);
2477 my $lower = shift if scalar(@_);
2478 my $upper = shift if scalar(@_);
2479 my $coord = $self->getfield($field);
2480 my $neg = $coord =~ s/^(-)//;
2482 my ($d, $m, $s) = (0, 0, 0);
2485 (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
2486 (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
2487 (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
2489 $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
2492 return "Invalid (coordinate with minutes > 59) $field: "
2493 . $self->getfield($field);
2496 $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
2498 if (defined($lower) and ($coord < $lower)) {
2499 return "Invalid (coordinate < $lower) $field: "
2500 . $self->getfield($field);;
2503 if (defined($upper) and ($coord > $upper)) {
2504 return "Invalid (coordinate > $upper) $field: "
2505 . $self->getfield($field);;
2508 $self->setfield($field, $coord);
2512 return "Invalid (coordinate) $field: " . $self->getfield($field);
2516 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
2518 Same as ut_coord, except optionally null.
2524 my ($self, $field) = (shift, shift);
2526 if ($self->getfield($field) =~ /^$/) {
2529 return $self->ut_coord($field, @_);
2535 =item ut_domain COLUMN
2537 Check/untaint host and domain names.
2542 my( $self, $field ) = @_;
2543 #$self->getfield($field) =~/^(\w+\.)*\w+$/
2544 $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
2545 or return "Illegal (domain) $field: ". $self->getfield($field);
2546 $self->setfield($field,$1);
2550 =item ut_name COLUMN
2552 Check/untaint proper names; allows alphanumerics, spaces and the following
2553 punctuation: , . - '
2560 my( $self, $field ) = @_;
2561 # warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
2562 $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
2563 or return gettext('illegal_name'). " $field: ". $self->getfield($field);
2564 $self->setfield($field,$1);
2570 Check/untaint zip codes.
2574 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
2577 my( $self, $field, $country ) = @_;
2579 if ( $country eq 'US' ) {
2581 $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
2582 or return gettext('illegal_zip'). " $field for country $country: ".
2583 $self->getfield($field);
2584 $self->setfield($field, $1);
2586 } elsif ( $country eq 'CA' ) {
2588 $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
2589 or return gettext('illegal_zip'). " $field for country $country: ".
2590 $self->getfield($field);
2591 $self->setfield($field, "$1 $2");
2595 if ( $self->getfield($field) =~ /^\s*$/
2596 && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
2599 $self->setfield($field,'');
2601 $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
2602 or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
2603 $self->setfield($field,$1);
2611 =item ut_country COLUMN
2613 Check/untaint country codes. Country names are changed to codes, if possible -
2614 see L<Locale::Country>.
2619 my( $self, $field ) = @_;
2620 unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
2621 if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
2622 && country2code($1) ) {
2623 $self->setfield($field,uc(country2code($1)));
2626 $self->getfield($field) =~ /^(\w\w)$/
2627 or return "Illegal (country) $field: ". $self->getfield($field);
2628 $self->setfield($field,uc($1));
2632 =item ut_anything COLUMN
2634 Untaints arbitrary data. Be careful.
2639 my( $self, $field ) = @_;
2640 $self->getfield($field) =~ /^(.*)$/s
2641 or return "Illegal $field: ". $self->getfield($field);
2642 $self->setfield($field,$1);
2646 =item ut_enum COLUMN CHOICES_ARRAYREF
2648 Check/untaint a column, supplying all possible choices, like the "enum" type.
2653 my( $self, $field, $choices ) = @_;
2654 foreach my $choice ( @$choices ) {
2655 if ( $self->getfield($field) eq $choice ) {
2656 $self->setfield($field, $choice);
2660 return "Illegal (enum) field $field: ". $self->getfield($field);
2663 =item ut_enumn COLUMN CHOICES_ARRAYREF
2665 Like ut_enum, except the null value is also allowed.
2670 my( $self, $field, $choices ) = @_;
2671 $self->getfield($field)
2672 ? $self->ut_enum($field, $choices)
2677 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2679 Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
2680 on the column first.
2684 sub ut_foreign_key {
2685 my( $self, $field, $table, $foreign ) = @_;
2686 return '' if $no_check_foreign;
2687 qsearchs($table, { $foreign => $self->getfield($field) })
2688 or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
2689 " in $table.$foreign";
2693 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
2695 Like ut_foreign_key, except the null value is also allowed.
2699 sub ut_foreign_keyn {
2700 my( $self, $field, $table, $foreign ) = @_;
2701 $self->getfield($field)
2702 ? $self->ut_foreign_key($field, $table, $foreign)
2706 =item ut_agentnum_acl COLUMN [ NULL_RIGHT | NULL_RIGHT_LISTREF ]
2708 Checks this column as an agentnum, taking into account the current users's
2709 ACLs. NULL_RIGHT or NULL_RIGHT_LISTREF, if specified, indicates the access
2710 right or rights allowing no agentnum.
2714 sub ut_agentnum_acl {
2715 my( $self, $field ) = (shift, shift);
2716 my $null_acl = scalar(@_) ? shift : [];
2717 $null_acl = [ $null_acl ] unless ref($null_acl);
2719 my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
2720 return "Illegal agentnum: $error" if $error;
2722 my $curuser = $FS::CurrentUser::CurrentUser;
2724 if ( $self->$field() ) {
2726 return "Access denied"
2727 unless $curuser->agentnum($self->$field());
2731 return "Access denied"
2732 unless grep $curuser->access_right($_), @$null_acl;
2740 =item virtual_fields [ TABLE ]
2742 Returns a list of virtual fields defined for the table. This should not
2743 be exported, and should only be called as an instance or class method.
2747 sub virtual_fields {
2750 $table = $self->table or confess "virtual_fields called on non-table";
2752 confess "Unknown table $table" unless dbdef->table($table);
2754 return () unless dbdef->table('part_virtual_field');
2756 unless ( $virtual_fields_cache{$table} ) {
2757 my $query = 'SELECT name from part_virtual_field ' .
2758 "WHERE dbtable = '$table'";
2760 my $result = $dbh->selectcol_arrayref($query);
2761 confess "Error executing virtual fields query: $query: ". $dbh->errstr
2763 $virtual_fields_cache{$table} = $result;
2766 @{$virtual_fields_cache{$table}};
2771 =item fields [ TABLE ]
2773 This is a wrapper for real_fields and virtual_fields. Code that called
2774 fields before should probably continue to call fields.
2779 my $something = shift;
2781 if($something->isa('FS::Record')) {
2782 $table = $something->table;
2784 $table = $something;
2785 $something = "FS::$table";
2787 return (real_fields($table), $something->virtual_fields());
2790 =item pvf FIELD_NAME
2792 Returns the FS::part_virtual_field object corresponding to a field in the
2793 record (specified by FIELD_NAME).
2798 my ($self, $name) = (shift, shift);
2800 if(grep /^$name$/, $self->virtual_fields) {
2801 return qsearchs('part_virtual_field', { dbtable => $self->table,
2807 =item vfieldpart_hashref TABLE
2809 Returns a hashref of virtual field names and vfieldparts applicable to the given
2814 sub vfieldpart_hashref {
2816 my $table = $self->table;
2818 return {} unless dbdef->table('part_virtual_field');
2821 my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
2822 "dbtable = '$table'";
2823 my $sth = $dbh->prepare($statement);
2824 $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
2825 return { map { $_->{name}, $_->{vfieldpart} }
2826 @{$sth->fetchall_arrayref({})} };
2830 =item encrypt($value)
2832 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2834 Returns the encrypted string.
2836 You should generally not have to worry about calling this, as the system handles this for you.
2841 my ($self, $value) = @_;
2844 if ($conf->exists('encryption')) {
2845 if ($self->is_encrypted($value)) {
2846 # Return the original value if it isn't plaintext.
2847 $encrypted = $value;
2850 if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2851 # RSA doesn't like the empty string so let's pack it up
2852 # The database doesn't like the RSA data so uuencode it
2853 my $length = length($value)+1;
2854 $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2856 die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2863 =item is_encrypted($value)
2865 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2871 my ($self, $value) = @_;
2872 # Possible Bug - Some work may be required here....
2874 if ($value =~ /^M/ && length($value) > 80) {
2881 =item decrypt($value)
2883 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2885 You should generally not have to worry about calling this, as the system handles this for you.
2890 my ($self,$value) = @_;
2891 my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2892 if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2894 if (ref($rsa_decrypt) =~ /::RSA/) {
2895 my $encrypted = unpack ("u*", $value);
2896 $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2897 if ($@) {warn "Decryption Failed"};
2905 #Initialize the Module
2906 $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2908 if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
2909 $rsa_module = $conf->config('encryptionmodule');
2913 eval ("require $rsa_module"); # No need to import the namespace
2916 # Initialize Encryption
2917 if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
2918 my $public_key = join("\n",$conf->config('encryptionpublickey'));
2919 $rsa_encrypt = $rsa_module->new_public_key($public_key);
2922 # Intitalize Decryption
2923 if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
2924 my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2925 $rsa_decrypt = $rsa_module->new_private_key($private_key);
2929 =item h_search ACTION
2931 Given an ACTION, either "insert", or "delete", returns the appropriate history
2932 record corresponding to this record, if any.
2937 my( $self, $action ) = @_;
2939 my $table = $self->table;
2942 my $primary_key = dbdef->table($table)->primary_key;
2945 'table' => "h_$table",
2946 'hashref' => { $primary_key => $self->$primary_key(),
2947 'history_action' => $action,
2955 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2956 appropriate history record corresponding to this record, if any.
2961 my($self, $action) = @_;
2962 my $h = $self->h_search($action);
2963 $h ? $h->history_date : '';
2966 =item scalar_sql SQL [ PLACEHOLDER, ... ]
2968 A class or object method. Executes the sql statement represented by SQL and
2969 returns a scalar representing the result: the first column of the first row.
2971 Dies on bogus SQL. Returns an empty string if no row is returned.
2973 Typically used for statments which return a single value such as "SELECT
2974 COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?"
2979 my($self, $sql) = (shift, shift);
2980 my $sth = dbh->prepare($sql) or die dbh->errstr;
2982 or die "Unexpected error executing statement $sql: ". $sth->errstr;
2983 my $row = $sth->fetchrow_arrayref or return '';
2984 my $scalar = $row->[0];
2985 defined($scalar) ? $scalar : '';
2994 =item real_fields [ TABLE ]
2996 Returns a list of the real columns in the specified table. Called only by
2997 fields() and other subroutines elsewhere in FS::Record.
3004 my($table_obj) = dbdef->table($table);
3005 confess "Unknown table $table" unless $table_obj;
3006 $table_obj->columns;
3009 =item _quote VALUE, TABLE, COLUMN
3011 This is an internal function used to construct SQL statements. It returns
3012 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
3013 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
3018 my($value, $table, $column) = @_;
3019 my $column_obj = dbdef->table($table)->column($column);
3020 my $column_type = $column_obj->type;
3021 my $nullable = $column_obj->null;
3023 warn " $table.$column: $value ($column_type".
3024 ( $nullable ? ' NULL' : ' NOT NULL' ).
3025 ")\n" if $DEBUG > 2;
3027 if ( $value eq '' && $nullable ) {
3029 } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
3030 cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
3033 } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
3034 ! $column_type =~ /(char|binary|text)$/i ) {
3036 } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i )
3037 && driver_name eq 'Pg'
3041 # dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right
3042 # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\,
3043 # single-quote the whole mess, and put an "E" in front.
3044 return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'");
3052 This is deprecated. Don't use it.
3054 It returns a hash-type list with the fields of this record's table set true.
3059 carp "warning: hfields is deprecated";
3062 foreach (fields($table)) {
3071 "$_: ". $self->getfield($_). "|"
3072 } (fields($self->table)) );
3075 sub DESTROY { return; }
3079 # #use Carp qw(cluck);
3080 # #cluck "DESTROYING $self";
3081 # warn "DESTROYING $self";
3085 # return ! eval { join('',@_), kill 0; 1; };
3088 =item str2time_sql [ DRIVER_NAME ]
3090 Returns a function to convert to unix time based on database type, such as
3091 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql. See
3092 the str2time_sql_closing method to return a closing string rather than just
3093 using a closing parenthesis as previously suggested.
3095 You can pass an optional driver name such as "Pg", "mysql" or
3096 $dbh->{Driver}->{Name} to return a function for that database instead of
3097 the current database.
3102 my $driver = shift || driver_name;
3104 return 'UNIX_TIMESTAMP(' if $driver =~ /^mysql/i;
3105 return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
3107 warn "warning: unknown database type $driver; guessing how to convert ".
3108 "dates to UNIX timestamps";
3109 return 'EXTRACT(EPOCH FROM ';
3113 =item str2time_sql_closing [ DRIVER_NAME ]
3115 Returns the closing suffix of a function to convert to unix time based on
3116 database type, such as ")::integer" for Pg or ")" for mysql.
3118 You can pass an optional driver name such as "Pg", "mysql" or
3119 $dbh->{Driver}->{Name} to return a function for that database instead of
3120 the current database.
3124 sub str2time_sql_closing {
3125 my $driver = shift || driver_name;
3127 return ' )::INTEGER ' if $driver =~ /^Pg/i;
3131 =item regexp_sql [ DRIVER_NAME ]
3133 Returns the operator to do a regular expression comparison based on database
3134 type, such as '~' for Pg or 'REGEXP' for mysql.
3136 You can pass an optional driver name such as "Pg", "mysql" or
3137 $dbh->{Driver}->{Name} to return a function for that database instead of
3138 the current database.
3143 my $driver = shift || driver_name;
3145 return '~' if $driver =~ /^Pg/i;
3146 return 'REGEXP' if $driver =~ /^mysql/i;
3148 die "don't know how to use regular expressions in ". driver_name." databases";
3152 =item not_regexp_sql [ DRIVER_NAME ]
3154 Returns the operator to do a regular expression negation based on database
3155 type, such as '!~' for Pg or 'NOT REGEXP' for mysql.
3157 You can pass an optional driver name such as "Pg", "mysql" or
3158 $dbh->{Driver}->{Name} to return a function for that database instead of
3159 the current database.
3163 sub not_regexp_sql {
3164 my $driver = shift || driver_name;
3166 return '!~' if $driver =~ /^Pg/i;
3167 return 'NOT REGEXP' if $driver =~ /^mysql/i;
3169 die "don't know how to use regular expressions in ". driver_name." databases";
3173 =item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF
3175 Returns the items concatendated based on database type, using "CONCAT()" for
3176 mysql and " || " for Pg and other databases.
3178 You can pass an optional driver name such as "Pg", "mysql" or
3179 $dbh->{Driver}->{Name} to return a function for that database instead of
3180 the current database.
3185 my $driver = ref($_[0]) ? driver_name : shift;
3188 if ( $driver =~ /^mysql/i ) {
3189 'CONCAT('. join(',', @$items). ')';
3191 join('||', @$items);
3200 This module should probably be renamed, since much of the functionality is
3201 of general use. It is not completely unlike Adapter::DBI (see below).
3203 Exported qsearch and qsearchs should be deprecated in favor of method calls
3204 (against an FS::Record object like the old search and searchs that qsearch
3205 and qsearchs were on top of.)
3207 The whole fields / hfields mess should be removed.
3209 The various WHERE clauses should be subroutined.
3211 table string should be deprecated in favor of DBIx::DBSchema::Table.
3213 No doubt we could benefit from a Tied hash. Documenting how exists / defined
3214 true maps to the database (and WHERE clauses) would also help.
3216 The ut_ methods should ask the dbdef for a default length.
3218 ut_sqltype (like ut_varchar) should all be defined
3220 A fallback check method should be provided which uses the dbdef.
3222 The ut_money method assumes money has two decimal digits.
3224 The Pg money kludge in the new method only strips `$'.
3226 The ut_phonen method only checks US-style phone numbers.
3228 The _quote function should probably use ut_float instead of a regex.
3230 All the subroutines probably should be methods, here or elsewhere.
3232 Probably should borrow/use some dbdef methods where appropriate (like sub
3235 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
3236 or allow it to be set. Working around it is ugly any way around - DBI should
3237 be fixed. (only affects RDBMS which return uppercase column names)
3239 ut_zip should take an optional country like ut_phone.
3243 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
3245 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.