4 use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG
6 %virtual_fields_cache $nowarn_identical $no_update_diff );
8 use Carp qw(carp cluck croak confess);
9 use Scalar::Util qw( blessed );
10 use File::CounterFile;
12 use DBI qw(:sql_types);
13 use DBIx::DBSchema 0.33;
14 use FS::UID qw(dbh getotaker datasrc driver_name);
16 use FS::Schema qw(dbdef);
18 use FS::Msgcat qw(gettext);
19 #use FS::Conf; #dependency loop bs, in install_callback below instead
21 use FS::part_virtual_field;
27 #export dbdef for now... everything else expects to find it here
28 @EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch
29 str2time_sql str2time_sql_closing );
34 $nowarn_identical = 0;
42 FS::UID->install_callback( sub {
45 $conf = FS::Conf->new;
46 $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
52 FS::Record - Database record objects
57 use FS::Record qw(dbh fields qsearch qsearchs);
59 $record = new FS::Record 'table', \%hash;
60 $record = new FS::Record 'table', { 'column' => 'value', ... };
62 $record = qsearchs FS::Record 'table', \%hash;
63 $record = qsearchs FS::Record 'table', { 'column' => 'value', ... };
64 @records = qsearch FS::Record 'table', \%hash;
65 @records = qsearch FS::Record 'table', { 'column' => 'value', ... };
67 $table = $record->table;
68 $dbdef_table = $record->dbdef_table;
70 $value = $record->get('column');
71 $value = $record->getfield('column');
72 $value = $record->column;
74 $record->set( 'column' => 'value' );
75 $record->setfield( 'column' => 'value' );
76 $record->column('value');
78 %hash = $record->hash;
80 $hashref = $record->hashref;
82 $error = $record->insert;
84 $error = $record->delete;
86 $error = $new_record->replace($old_record);
88 # external use deprecated - handled by the database (at least for Pg, mysql)
89 $value = $record->unique('column');
91 $error = $record->ut_float('column');
92 $error = $record->ut_floatn('column');
93 $error = $record->ut_number('column');
94 $error = $record->ut_numbern('column');
95 $error = $record->ut_snumber('column');
96 $error = $record->ut_snumbern('column');
97 $error = $record->ut_money('column');
98 $error = $record->ut_text('column');
99 $error = $record->ut_textn('column');
100 $error = $record->ut_alpha('column');
101 $error = $record->ut_alphan('column');
102 $error = $record->ut_phonen('column');
103 $error = $record->ut_anything('column');
104 $error = $record->ut_name('column');
106 $quoted_value = _quote($value,'table','field');
109 $fields = hfields('table');
110 if ( $fields->{Field} ) { # etc.
112 @fields = fields 'table'; #as a subroutine
113 @fields = $record->fields; #as a method call
118 (Mostly) object-oriented interface to database records. Records are currently
119 implemented on top of DBI. FS::Record is intended as a base class for
120 table-specific classes to inherit from, i.e. FS::cust_main.
126 =item new [ TABLE, ] HASHREF
128 Creates a new record. It doesn't store it in the database, though. See
129 L<"insert"> for that.
131 Note that the object stores this hash reference, not a distinct copy of the
132 hash it points to. You can ask the object for a copy with the I<hash>
135 TABLE can only be omitted when a dervived class overrides the table method.
141 my $class = ref($proto) || $proto;
143 bless ($self, $class);
145 unless ( defined ( $self->table ) ) {
146 $self->{'Table'} = shift;
147 carp "warning: FS::Record::new called with table name ". $self->{'Table'};
150 $self->{'Hash'} = shift;
152 foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
153 $self->{'Hash'}{$field}='';
156 $self->_rebless if $self->can('_rebless');
158 $self->{'modified'} = 0;
160 $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
167 my $class = ref($proto) || $proto;
169 bless ($self, $class);
171 $self->{'Table'} = shift unless defined ( $self->table );
173 my $hashref = $self->{'Hash'} = shift;
175 if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
176 my $obj = $cache->cache->{$hashref->{$cache->key}};
177 $obj->_cache($hashref, $cache) if $obj->can('_cache');
180 $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
187 my $class = ref($proto) || $proto;
189 bless ($self, $class);
190 if ( defined $self->table ) {
191 cluck "create constructor is deprecated, use new!";
194 croak "FS::Record::create called (not from a subclass)!";
198 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
200 Searches the database for all records matching (at least) the key/value pairs
201 in HASHREF. Returns all the records found as `FS::TABLE' objects if that
202 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
205 The preferred usage is to pass a hash reference of named parameters:
207 my @records = qsearch( {
208 'table' => 'table_name',
209 'hashref' => { 'field' => 'value'
210 'field' => { 'op' => '<',
215 #these are optional...
217 'extra_sql' => 'AND field ',
218 'order_by' => 'ORDER BY something',
219 #'cache_obj' => '', #optional
220 'addl_from' => 'LEFT JOIN othtable USING ( field )',
225 Much code still uses old-style positional parameters, this is also probably
226 fine in the common case where there are only two parameters:
228 my @records = qsearch( 'table', { 'field' => 'value' } );
230 ###oops, argh, FS::Record::new only lets us create database fields.
231 #Normal behaviour if SELECT is not specified is `*', as in
232 #C<SELECT * FROM table WHERE ...>. However, there is an experimental new
233 #feature where you can specify SELECT - remember, the objects returned,
234 #although blessed into the appropriate `FS::TABLE' package, will only have the
235 #fields you specify. This might have unwanted results if you then go calling
236 #regular FS::TABLE methods
241 my %TYPE = (); #for debugging
244 my($stable, $record, $select, $extra_sql, $order_by, $cache, $addl_from );
246 if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too
248 $stable = $opt->{'table'} or die "table name is required";
249 $record = $opt->{'hashref'} || {};
250 $select = $opt->{'select'} || '*';
251 $extra_sql = $opt->{'extra_sql'} || '';
252 $order_by = $opt->{'order_by'} || '';
253 $cache = $opt->{'cache_obj'} || '';
254 $addl_from = $opt->{'addl_from'} || '';
255 $debug = $opt->{'debug'} || '';
257 ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_;
261 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
263 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
267 my $table = $cache ? $cache->table : $stable;
268 my $dbdef_table = dbdef->table($table)
269 or die "No schema for table $table found - ".
270 "do you need to run freeside-upgrade?";
271 my $pkey = $dbdef_table->primary_key;
273 my @real_fields = grep exists($record->{$_}), real_fields($table);
275 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
276 @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
278 cluck "warning: FS::$table not loaded; virtual fields not searchable";
279 @virtual_fields = ();
282 my $statement = "SELECT $select FROM $stable";
283 $statement .= " $addl_from" if $addl_from;
284 if ( @real_fields or @virtual_fields ) {
285 $statement .= ' WHERE '. join(' AND ',
286 get_real_fields($table, $record, \@real_fields) ,
287 get_virtual_fields($table, $pkey, $record, \@virtual_fields),
291 $statement .= " $extra_sql" if defined($extra_sql);
292 $statement .= " $order_by" if defined($order_by);
294 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
295 my $sth = $dbh->prepare($statement)
296 or croak "$dbh->errstr doing $statement";
301 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
304 my $value = $record->{$field};
305 $value = $value->{'value'} if ref($value);
306 my $type = dbdef->table($table)->column($field)->type;
308 my $TYPE = SQL_VARCHAR;
309 if ( $type =~ /(int|(big)?serial)/i && $value =~ /^\d+(\.\d+)?$/ ) {
311 } elsif ( ( $type =~ /(numeric)/i && $value =~ /^[+-]?\d+(\.\d+)?$/)
312 || ( $type =~ /(real|float4)/i
313 && $value =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/
321 %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} }
323 warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n";
326 $sth->bind_param($bind++, $value, { TYPE => $TYPE } );
330 # $sth->execute( map $record->{$_},
331 # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
332 # ) or croak "Error executing \"$statement\": ". $sth->errstr;
334 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
336 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
337 @virtual_fields = "FS::$table"->virtual_fields;
339 cluck "warning: FS::$table not loaded; virtual fields not returned either";
340 @virtual_fields = ();
344 tie %result, "Tie::IxHash";
345 my @stuff = @{ $sth->fetchall_arrayref( {} ) };
346 if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
347 %result = map { $_->{$pkey}, $_ } @stuff;
349 @result{@stuff} = @stuff;
354 if ( keys(%result) and @virtual_fields ) {
356 "SELECT virtual_field.recnum, part_virtual_field.name, ".
357 "virtual_field.value ".
358 "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ".
359 "WHERE part_virtual_field.dbtable = '$table' AND ".
360 "virtual_field.recnum IN (".
361 join(',', keys(%result)). ") AND part_virtual_field.name IN ('".
362 join(q!', '!, @virtual_fields) . "')";
363 warn "[debug]$me $statement\n" if $DEBUG > 1;
364 $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement";
365 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
367 foreach (@{ $sth->fetchall_arrayref({}) }) {
368 my $recnum = $_->{recnum};
369 my $name = $_->{name};
370 my $value = $_->{value};
371 if (exists($result{$recnum})) {
372 $result{$recnum}->{$name} = $value;
377 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
378 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
379 #derivied class didn't override new method, so this optimization is safe
382 new_or_cached( "FS::$table", { %{$_} }, $cache )
386 new( "FS::$table", { %{$_} } )
390 #okay, its been tested
391 # warn "untested code (class FS::$table uses custom new method)";
393 eval 'FS::'. $table. '->new( { %{$_} } )';
397 # Check for encrypted fields and decrypt them.
398 ## only in the local copy, not the cached object
399 if ( $conf && $conf->exists('encryption') # $conf doesn't exist when doing
400 # the initial search for
402 && eval 'defined(@FS::'. $table . '::encrypted_fields)') {
403 foreach my $record (@return) {
404 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
405 # Set it directly... This may cause a problem in the future...
406 $record->setfield($field, $record->decrypt($record->getfield($field)));
411 cluck "warning: FS::$table not loaded; returning FS::Record objects";
413 FS::Record->new( $table, { %{$_} } );
419 ## makes this easier to read
421 sub get_virtual_fields {
425 my $virtual_fields = shift;
431 if ( ref($record->{$_}) ) {
432 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
433 if ( uc($op) eq 'ILIKE' ) {
435 $record->{$_}{'value'} = lc($record->{$_}{'value'});
436 $column = "LOWER($_)";
438 $record->{$_} = $record->{$_}{'value'};
441 # ... EXISTS ( SELECT name, value FROM part_virtual_field
443 # ON part_virtual_field.vfieldpart = virtual_field.vfieldpart
444 # WHERE recnum = svc_acct.svcnum
445 # AND (name, value) = ('egad', 'brain') )
447 my $value = $record->{$_};
451 $subq = ($value ? 'EXISTS ' : 'NOT EXISTS ') .
452 "( SELECT part_virtual_field.name, virtual_field.value ".
453 "FROM part_virtual_field JOIN virtual_field ".
454 "ON part_virtual_field.vfieldpart = virtual_field.vfieldpart ".
455 "WHERE virtual_field.recnum = ${table}.${pkey} ".
456 "AND part_virtual_field.name = '${column}'".
458 " AND virtual_field.value ${op} '${value}'"
462 } @{ $virtual_fields } ) ;
465 sub get_real_fields {
468 my $real_fields = shift;
470 ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability
476 if ( ref($record->{$_}) ) {
477 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
478 #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
479 if ( uc($op) eq 'ILIKE' ) {
481 $record->{$_}{'value'} = lc($record->{$_}{'value'});
482 $column = "LOWER($_)";
484 $record->{$_} = $record->{$_}{'value'}
487 if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
489 if ( driver_name eq 'Pg' ) {
490 my $type = dbdef->table($table)->column($column)->type;
491 if ( $type =~ /(int|(big)?serial)/i ) {
492 qq-( $column IS NULL )-;
494 qq-( $column IS NULL OR $column = '' )-;
497 qq-( $column IS NULL OR $column = "" )-;
499 } elsif ( $op eq '!=' ) {
500 if ( driver_name eq 'Pg' ) {
501 my $type = dbdef->table($table)->column($column)->type;
502 if ( $type =~ /(int|(big)?serial)/i ) {
503 qq-( $column IS NOT NULL )-;
505 qq-( $column IS NOT NULL AND $column != '' )-;
508 qq-( $column IS NOT NULL AND $column != "" )-;
511 if ( driver_name eq 'Pg' ) {
512 qq-( $column $op '' )-;
514 qq-( $column $op "" )-;
520 } @{ $real_fields } );
523 =item by_key PRIMARY_KEY_VALUE
525 This is a class method that returns the record with the given primary key
526 value. This method is only useful in FS::Record subclasses. For example:
528 my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
532 my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
537 my ($class, $pkey_value) = @_;
539 my $table = $class->table
540 or croak "No table for $class found";
542 my $dbdef_table = dbdef->table($table)
543 or die "No schema for table $table found - ".
544 "do you need to create it or run dbdef-create?";
545 my $pkey = $dbdef_table->primary_key
546 or die "No primary key for table $table";
548 return qsearchs($table, { $pkey => $pkey_value });
551 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
553 Experimental JOINed search method. Using this method, you can execute a
554 single SELECT spanning multiple tables, and cache the results for subsequent
555 method calls. Interface will almost definately change in an incompatible
563 my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
564 my $cache = FS::SearchCache->new( $ptable, $pkey );
567 grep { !$saw{$_->getfield($pkey)}++ }
568 qsearch($table, $record, $select, $extra_sql, $cache )
572 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
574 Same as qsearch, except that if more than one record matches, it B<carp>s but
575 returns the first. If this happens, you either made a logic error in asking
576 for a single item, or your data is corrupted.
580 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
582 my(@result) = qsearch(@_);
583 cluck "warning: Multiple records in scalar search ($table)"
584 if scalar(@result) > 1;
585 #should warn more vehemently if the search was on a primary key?
586 scalar(@result) ? ($result[0]) : ();
597 Returns the table name.
602 # cluck "warning: FS::Record::table deprecated; supply one in subclass!";
609 Returns the DBIx::DBSchema::Table object for the table.
615 my($table)=$self->table;
616 dbdef->table($table);
621 Returns the primary key for the table.
627 my $pkey = $self->dbdef_table->primary_key;
630 =item get, getfield COLUMN
632 Returns the value of the column/field/key COLUMN.
637 my($self,$field) = @_;
638 # to avoid "Use of unitialized value" errors
639 if ( defined ( $self->{Hash}->{$field} ) ) {
640 $self->{Hash}->{$field};
650 =item set, setfield COLUMN, VALUE
652 Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE.
657 my($self,$field,$value) = @_;
658 $self->{'modified'} = 1;
659 $self->{'Hash'}->{$field} = $value;
666 =item AUTLOADED METHODS
668 $record->column is a synonym for $record->get('column');
670 $record->column('value') is a synonym for $record->set('column','value');
677 my($field)=$AUTOLOAD;
679 if ( defined($value) ) {
680 confess "errant AUTOLOAD $field for $self (arg $value)"
681 unless blessed($self) && $self->can('setfield');
682 $self->setfield($field,$value);
684 confess "errant AUTOLOAD $field for $self (no args)"
685 unless blessed($self) && $self->can('getfield');
686 $self->getfield($field);
692 # my $field = $AUTOLOAD;
694 # if ( defined($_[1]) ) {
695 # $_[0]->setfield($field, $_[1]);
697 # $_[0]->getfield($field);
703 Returns a list of the column/value pairs, usually for assigning to a new hash.
705 To make a distinct duplicate of an FS::Record object, you can do:
707 $new = new FS::Record ( $old->table, { $old->hash } );
713 confess $self. ' -> hash: Hash attribute is undefined'
714 unless defined($self->{'Hash'});
715 %{ $self->{'Hash'} };
720 Returns a reference to the column/value hash. This may be deprecated in the
721 future; if there's a reason you can't just use the autoloaded or get/set
733 Returns true if any of this object's values have been modified with set (or via
734 an autoloaded method). Doesn't yet recognize when you retreive a hashref and
744 =item select_for_update
746 Selects this record with the SQL "FOR UPDATE" command. This can be useful as
751 sub select_for_update {
753 my $primary_key = $self->primary_key;
756 'table' => $self->table,
757 'hashref' => { $primary_key => $self->$primary_key() },
758 'extra_sql' => 'FOR UPDATE',
764 Inserts this record to the database. If there is an error, returns the error,
765 otherwise returns false.
773 warn "$self -> insert" if $DEBUG;
775 my $error = $self->check;
776 return $error if $error;
778 #single-field unique keys are given a value if false
779 #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
780 foreach ( $self->dbdef_table->unique_singles) {
781 $self->unique($_) unless $self->getfield($_);
784 #and also the primary key, if the database isn't going to
785 my $primary_key = $self->dbdef_table->primary_key;
787 if ( $primary_key ) {
788 my $col = $self->dbdef_table->column($primary_key);
791 uc($col->type) =~ /^(BIG)?SERIAL\d?/
792 || ( driver_name eq 'Pg'
793 && defined($col->default)
794 && $col->default =~ /^nextval\(/i
796 || ( driver_name eq 'mysql'
797 && defined($col->local)
798 && $col->local =~ /AUTO_INCREMENT/i
800 $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
803 my $table = $self->table;
806 # Encrypt before the database
807 if ($conf->exists('encryption') && defined(eval '@FS::'. $table . '::encrypted_fields')) {
808 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
809 $self->{'saved'} = $self->getfield($field);
810 $self->setfield($field, $self->encrypt($self->getfield($field)));
815 #false laziness w/delete
817 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
820 my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
823 my $statement = "INSERT INTO $table ";
824 if ( @real_fields ) {
827 join( ', ', @real_fields ).
829 join( ', ', @values ).
833 $statement .= 'DEFAULT VALUES';
835 warn "[debug]$me $statement\n" if $DEBUG > 1;
836 my $sth = dbh->prepare($statement) or return dbh->errstr;
838 local $SIG{HUP} = 'IGNORE';
839 local $SIG{INT} = 'IGNORE';
840 local $SIG{QUIT} = 'IGNORE';
841 local $SIG{TERM} = 'IGNORE';
842 local $SIG{TSTP} = 'IGNORE';
843 local $SIG{PIPE} = 'IGNORE';
845 $sth->execute or return $sth->errstr;
847 # get inserted id from the database, if applicable & needed
848 if ( $db_seq && ! $self->getfield($primary_key) ) {
849 warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
853 if ( driver_name eq 'Pg' ) {
855 #my $oid = $sth->{'pg_oid_status'};
856 #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
858 my $default = $self->dbdef_table->column($primary_key)->default;
859 unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
860 dbh->rollback if $FS::UID::AutoCommit;
861 return "can't parse $table.$primary_key default value".
862 " for sequence name: $default";
866 my $i_sql = "SELECT currval('$sequence')";
867 my $i_sth = dbh->prepare($i_sql) or do {
868 dbh->rollback if $FS::UID::AutoCommit;
871 $i_sth->execute() or do { #$i_sth->execute($oid)
872 dbh->rollback if $FS::UID::AutoCommit;
873 return $i_sth->errstr;
875 $insertid = $i_sth->fetchrow_arrayref->[0];
877 } elsif ( driver_name eq 'mysql' ) {
879 $insertid = dbh->{'mysql_insertid'};
880 # work around mysql_insertid being null some of the time, ala RT :/
881 unless ( $insertid ) {
882 warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
883 "using SELECT LAST_INSERT_ID();";
884 my $i_sql = "SELECT LAST_INSERT_ID()";
885 my $i_sth = dbh->prepare($i_sql) or do {
886 dbh->rollback if $FS::UID::AutoCommit;
889 $i_sth->execute or do {
890 dbh->rollback if $FS::UID::AutoCommit;
891 return $i_sth->errstr;
893 $insertid = $i_sth->fetchrow_arrayref->[0];
898 dbh->rollback if $FS::UID::AutoCommit;
899 return "don't know how to retreive inserted ids from ". driver_name.
900 ", try using counterfiles (maybe run dbdef-create?)";
904 $self->setfield($primary_key, $insertid);
909 grep defined($self->getfield($_)) && $self->getfield($_) ne "",
910 $self->virtual_fields;
911 if (@virtual_fields) {
912 my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
914 my $vfieldpart = $self->vfieldpart_hashref;
916 my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
919 my $v_sth = dbh->prepare($v_statement) or do {
920 dbh->rollback if $FS::UID::AutoCommit;
924 foreach (keys(%v_values)) {
925 $v_sth->execute($self->getfield($primary_key),
929 dbh->rollback if $FS::UID::AutoCommit;
930 return $v_sth->errstr;
937 if ( defined dbdef->table('h_'. $table) ) {
938 my $h_statement = $self->_h_statement('insert');
939 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
940 $h_sth = dbh->prepare($h_statement) or do {
941 dbh->rollback if $FS::UID::AutoCommit;
947 $h_sth->execute or return $h_sth->errstr if $h_sth;
949 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
951 # Now that it has been saved, reset the encrypted fields so that $new
953 foreach my $field (keys %{$saved}) {
954 $self->setfield($field, $saved->{$field});
962 Depriciated (use insert instead).
967 cluck "warning: FS::Record::add deprecated!";
968 insert @_; #call method in this scope
973 Delete this record from the database. If there is an error, returns the error,
974 otherwise returns false.
981 my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
983 $self->getfield($_) eq ''
984 #? "( $_ IS NULL OR $_ = \"\" )"
985 ? ( driver_name eq 'Pg'
987 : "( $_ IS NULL OR $_ = \"\" )"
989 : "$_ = ". _quote($self->getfield($_),$self->table,$_)
990 } ( $self->dbdef_table->primary_key )
991 ? ( $self->dbdef_table->primary_key)
992 : real_fields($self->table)
994 warn "[debug]$me $statement\n" if $DEBUG > 1;
995 my $sth = dbh->prepare($statement) or return dbh->errstr;
998 if ( defined dbdef->table('h_'. $self->table) ) {
999 my $h_statement = $self->_h_statement('delete');
1000 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
1001 $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
1006 my $primary_key = $self->dbdef_table->primary_key;
1009 my $vfp = $self->vfieldpart_hashref;
1010 foreach($self->virtual_fields) {
1011 next if $self->getfield($_) eq '';
1012 unless(@del_vfields) {
1013 my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
1014 $v_sth = dbh->prepare($st) or return dbh->errstr;
1016 push @del_vfields, $_;
1019 local $SIG{HUP} = 'IGNORE';
1020 local $SIG{INT} = 'IGNORE';
1021 local $SIG{QUIT} = 'IGNORE';
1022 local $SIG{TERM} = 'IGNORE';
1023 local $SIG{TSTP} = 'IGNORE';
1024 local $SIG{PIPE} = 'IGNORE';
1026 my $rc = $sth->execute or return $sth->errstr;
1027 #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1028 $h_sth->execute or return $h_sth->errstr if $h_sth;
1029 $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
1030 or return $v_sth->errstr
1031 foreach (@del_vfields);
1033 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1035 #no need to needlessly destoy the data either (causes problems actually)
1036 #undef $self; #no need to keep object!
1043 Depriciated (use delete instead).
1048 cluck "warning: FS::Record::del deprecated!";
1049 &delete(@_); #call method in this scope
1052 =item replace OLD_RECORD
1054 Replace the OLD_RECORD with this one in the database. If there is an error,
1055 returns the error, otherwise returns false.
1060 my ($new, $old) = (shift, shift);
1062 $old = $new->replace_old unless defined($old);
1064 warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1066 if ( $new->can('replace_check') ) {
1067 my $error = $new->replace_check($old);
1068 return $error if $error;
1071 return "Records not in same table!" unless $new->table eq $old->table;
1073 my $primary_key = $old->dbdef_table->primary_key;
1074 return "Can't change primary key $primary_key ".
1075 'from '. $old->getfield($primary_key).
1076 ' to ' . $new->getfield($primary_key)
1078 && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1080 my $error = $new->check;
1081 return $error if $error;
1083 # Encrypt for replace
1085 if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) {
1086 foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1087 $saved->{$field} = $new->getfield($field);
1088 $new->setfield($field, $new->encrypt($new->getfield($field)));
1092 #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1093 my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1094 ? ($_, $new->getfield($_)) : () } $old->fields;
1096 unless (keys(%diff) || $no_update_diff ) {
1097 carp "[warning]$me $new -> replace $old: records identical"
1098 unless $nowarn_identical;
1102 my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1104 "$_ = ". _quote($new->getfield($_),$old->table,$_)
1105 } real_fields($old->table)
1110 if ( $old->getfield($_) eq '' ) {
1112 #false laziness w/qsearch
1113 if ( driver_name eq 'Pg' ) {
1114 my $type = $old->dbdef_table->column($_)->type;
1115 if ( $type =~ /(int|(big)?serial)/i ) {
1118 qq-( $_ IS NULL OR $_ = '' )-;
1121 qq-( $_ IS NULL OR $_ = "" )-;
1125 "$_ = ". _quote($old->getfield($_),$old->table,$_);
1128 } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1131 warn "[debug]$me $statement\n" if $DEBUG > 1;
1132 my $sth = dbh->prepare($statement) or return dbh->errstr;
1135 if ( defined dbdef->table('h_'. $old->table) ) {
1136 my $h_old_statement = $old->_h_statement('replace_old');
1137 warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1138 $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1144 if ( defined dbdef->table('h_'. $new->table) ) {
1145 my $h_new_statement = $new->_h_statement('replace_new');
1146 warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1147 $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1152 # For virtual fields we have three cases with different SQL
1153 # statements: add, replace, delete
1157 my (@add_vfields, @rep_vfields, @del_vfields);
1158 my $vfp = $old->vfieldpart_hashref;
1159 foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
1160 if($diff{$_} eq '') {
1162 unless(@del_vfields) {
1163 my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
1164 "AND vfieldpart = ?";
1165 warn "[debug]$me $st\n" if $DEBUG > 2;
1166 $v_del_sth = dbh->prepare($st) or return dbh->errstr;
1168 push @del_vfields, $_;
1169 } elsif($old->getfield($_) eq '') {
1171 unless(@add_vfields) {
1172 my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
1174 warn "[debug]$me $st\n" if $DEBUG > 2;
1175 $v_add_sth = dbh->prepare($st) or return dbh->errstr;
1177 push @add_vfields, $_;
1180 unless(@rep_vfields) {
1181 my $st = "UPDATE virtual_field SET value = ? ".
1182 "WHERE recnum = ? AND vfieldpart = ?";
1183 warn "[debug]$me $st\n" if $DEBUG > 2;
1184 $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
1186 push @rep_vfields, $_;
1190 local $SIG{HUP} = 'IGNORE';
1191 local $SIG{INT} = 'IGNORE';
1192 local $SIG{QUIT} = 'IGNORE';
1193 local $SIG{TERM} = 'IGNORE';
1194 local $SIG{TSTP} = 'IGNORE';
1195 local $SIG{PIPE} = 'IGNORE';
1197 my $rc = $sth->execute or return $sth->errstr;
1198 #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1199 $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1200 $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1202 $v_del_sth->execute($old->getfield($primary_key),
1204 or return $v_del_sth->errstr
1205 foreach(@del_vfields);
1207 $v_add_sth->execute($new->getfield($_),
1208 $old->getfield($primary_key),
1210 or return $v_add_sth->errstr
1211 foreach(@add_vfields);
1213 $v_rep_sth->execute($new->getfield($_),
1214 $old->getfield($primary_key),
1216 or return $v_rep_sth->errstr
1217 foreach(@rep_vfields);
1219 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1221 # Now that it has been saved, reset the encrypted fields so that $new
1222 # can still be used.
1223 foreach my $field (keys %{$saved}) {
1224 $new->setfield($field, $saved->{$field});
1232 my( $self ) = shift;
1233 warn "[$me] replace called with no arguments; autoloading old record\n"
1236 my $primary_key = $self->dbdef_table->primary_key;
1237 if ( $primary_key ) {
1238 $self->by_key( $self->$primary_key() ) #this is what's returned
1239 or croak "can't find ". $self->table. ".$primary_key ".
1240 $self->$primary_key();
1242 croak $self->table. " has no primary key; pass old record as argument";
1249 Depriciated (use replace instead).
1254 cluck "warning: FS::Record::rep deprecated!";
1255 replace @_; #call method in this scope
1260 Checks virtual fields (using check_blocks). Subclasses should still provide
1261 a check method to validate real fields, foreign keys, etc., and call this
1262 method via $self->SUPER::check.
1264 (FIXME: Should this method try to make sure that it I<is> being called from
1265 a subclass's check method, to keep the current semantics as far as possible?)
1270 #confess "FS::Record::check not implemented; supply one in subclass!";
1273 foreach my $field ($self->virtual_fields) {
1274 for ($self->getfield($field)) {
1275 # See notes on check_block in FS::part_virtual_field.
1276 eval $self->pvf($field)->check_block;
1278 #this is bad, probably want to follow the stack backtrace up and see
1280 my $err = "Fatal error checking $field for $self";
1282 return "$err (see log for backtrace): $@";
1285 $self->setfield($field, $_);
1292 my( $self, $action, $time ) = @_;
1297 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1298 real_fields($self->table);
1301 # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1302 # You can see if it changed by the paymask...
1303 if ($conf->exists('encryption') ) {
1304 @fields = grep $_ ne 'payinfo' && $_ ne 'cvv2', @fields;
1306 my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1308 "INSERT INTO h_". $self->table. " ( ".
1309 join(', ', qw(history_date history_user history_action), @fields ).
1311 join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1318 B<Warning>: External use is B<deprecated>.
1320 Replaces COLUMN in record with a unique number, using counters in the
1321 filesystem. Used by the B<insert> method on single-field unique columns
1322 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1323 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1325 Returns the new value.
1330 my($self,$field) = @_;
1331 my($table)=$self->table;
1333 croak "Unique called on field $field, but it is ",
1334 $self->getfield($field),
1336 if $self->getfield($field);
1338 #warn "table $table is tainted" if is_tainted($table);
1339 #warn "field $field is tainted" if is_tainted($field);
1341 my($counter) = new File::CounterFile "$table.$field",0;
1343 # getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1345 # my($counter) = new File::CounterFile "$user/$table.$field",0;
1348 my $index = $counter->inc;
1349 $index = $counter->inc while qsearchs($table, { $field=>$index } );
1351 $index =~ /^(\d*)$/;
1354 $self->setfield($field,$index);
1358 =item ut_float COLUMN
1360 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be
1361 null. If there is an error, returns the error, otherwise returns false.
1366 my($self,$field)=@_ ;
1367 ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
1368 $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
1369 $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
1370 $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
1371 or return "Illegal or empty (float) $field: ". $self->getfield($field);
1372 $self->setfield($field,$1);
1375 =item ut_floatn COLUMN
1377 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
1378 null. If there is an error, returns the error, otherwise returns false.
1382 #false laziness w/ut_ipn
1384 my( $self, $field ) = @_;
1385 if ( $self->getfield($field) =~ /^()$/ ) {
1386 $self->setfield($field,'');
1389 $self->ut_float($field);
1393 =item ut_sfloat COLUMN
1395 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1396 May not be null. If there is an error, returns the error, otherwise returns
1402 my($self,$field)=@_ ;
1403 ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
1404 $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
1405 $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
1406 $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
1407 or return "Illegal or empty (float) $field: ". $self->getfield($field);
1408 $self->setfield($field,$1);
1411 =item ut_sfloatn COLUMN
1413 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
1414 null. If there is an error, returns the error, otherwise returns false.
1419 my( $self, $field ) = @_;
1420 if ( $self->getfield($field) =~ /^()$/ ) {
1421 $self->setfield($field,'');
1424 $self->ut_sfloat($field);
1428 =item ut_snumber COLUMN
1430 Check/untaint signed numeric data (whole numbers). If there is an error,
1431 returns the error, otherwise returns false.
1436 my($self, $field) = @_;
1437 $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
1438 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1439 $self->setfield($field, "$1$2");
1443 =item ut_snumbern COLUMN
1445 Check/untaint signed numeric data (whole numbers). If there is an error,
1446 returns the error, otherwise returns false.
1451 my($self, $field) = @_;
1452 $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
1453 or return "Illegal (numeric) $field: ". $self->getfield($field);
1455 return "Illegal (numeric) $field: ". $self->getfield($field)
1458 $self->setfield($field, "$1$2");
1462 =item ut_number COLUMN
1464 Check/untaint simple numeric data (whole numbers). May not be null. If there
1465 is an error, returns the error, otherwise returns false.
1470 my($self,$field)=@_;
1471 $self->getfield($field) =~ /^\s*(\d+)\s*$/
1472 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1473 $self->setfield($field,$1);
1477 =item ut_numbern COLUMN
1479 Check/untaint simple numeric data (whole numbers). May be null. If there is
1480 an error, returns the error, otherwise returns false.
1485 my($self,$field)=@_;
1486 $self->getfield($field) =~ /^\s*(\d*)\s*$/
1487 or return "Illegal (numeric) $field: ". $self->getfield($field);
1488 $self->setfield($field,$1);
1492 =item ut_money COLUMN
1494 Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
1495 is an error, returns the error, otherwise returns false.
1500 my($self,$field)=@_;
1501 $self->setfield($field, 0) if $self->getfield($field) eq '';
1502 $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/
1503 or return "Illegal (money) $field: ". $self->getfield($field);
1504 #$self->setfield($field, "$1$2$3" || 0);
1505 $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
1509 =item ut_text COLUMN
1511 Check/untaint text. Alphanumerics, spaces, and the following punctuation
1512 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ]
1513 May not be null. If there is an error, returns the error, otherwise returns
1519 my($self,$field)=@_;
1520 #warn "msgcat ". \&msgcat. "\n";
1521 #warn "notexist ". \¬exist. "\n";
1522 #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
1523 $self->getfield($field)
1524 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/
1525 or return gettext('illegal_or_empty_text'). " $field: ".
1526 $self->getfield($field);
1527 $self->setfield($field,$1);
1531 =item ut_textn COLUMN
1533 Check/untaint text. Alphanumerics, spaces, and the following punctuation
1534 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
1535 May be null. If there is an error, returns the error, otherwise returns false.
1540 my($self,$field)=@_;
1541 $self->getfield($field)
1542 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/
1543 or return gettext('illegal_text'). " $field: ". $self->getfield($field);
1544 $self->setfield($field,$1);
1548 =item ut_alpha COLUMN
1550 Check/untaint alphanumeric strings (no spaces). May not be null. If there is
1551 an error, returns the error, otherwise returns false.
1556 my($self,$field)=@_;
1557 $self->getfield($field) =~ /^(\w+)$/
1558 or return "Illegal or empty (alphanumeric) $field: ".
1559 $self->getfield($field);
1560 $self->setfield($field,$1);
1564 =item ut_alpha COLUMN
1566 Check/untaint alphanumeric strings (no spaces). May be null. If there is an
1567 error, returns the error, otherwise returns false.
1572 my($self,$field)=@_;
1573 $self->getfield($field) =~ /^(\w*)$/
1574 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
1575 $self->setfield($field,$1);
1579 =item ut_alpha_lower COLUMN
1581 Check/untaint lowercase alphanumeric strings (no spaces). May not be null. If
1582 there is an error, returns the error, otherwise returns false.
1586 sub ut_alpha_lower {
1587 my($self,$field)=@_;
1588 $self->getfield($field) =~ /[[:upper:]]/
1589 and return "Uppercase characters are not permitted in $field";
1590 $self->ut_alpha($field);
1593 =item ut_phonen COLUMN [ COUNTRY ]
1595 Check/untaint phone numbers. May be null. If there is an error, returns
1596 the error, otherwise returns false.
1598 Takes an optional two-letter ISO country code; without it or with unsupported
1599 countries, ut_phonen simply calls ut_alphan.
1604 my( $self, $field, $country ) = @_;
1605 return $self->ut_alphan($field) unless defined $country;
1606 my $phonen = $self->getfield($field);
1607 if ( $phonen eq '' ) {
1608 $self->setfield($field,'');
1609 } elsif ( $country eq 'US' || $country eq 'CA' ) {
1611 $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
1612 or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
1613 $phonen = "$1-$2-$3";
1614 $phonen .= " x$4" if $4;
1615 $self->setfield($field,$phonen);
1617 warn "warning: don't know how to check phone numbers for country $country";
1618 return $self->ut_textn($field);
1625 Check/untaint hexadecimal values.
1630 my($self, $field) = @_;
1631 $self->getfield($field) =~ /^([\da-fA-F]+)$/
1632 or return "Illegal (hex) $field: ". $self->getfield($field);
1633 $self->setfield($field, uc($1));
1637 =item ut_hexn COLUMN
1639 Check/untaint hexadecimal values. May be null.
1644 my($self, $field) = @_;
1645 $self->getfield($field) =~ /^([\da-fA-F]*)$/
1646 or return "Illegal (hex) $field: ". $self->getfield($field);
1647 $self->setfield($field, uc($1));
1652 Check/untaint ip addresses. IPv4 only for now.
1657 my( $self, $field ) = @_;
1658 $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
1659 or return "Illegal (IP address) $field: ". $self->getfield($field);
1660 for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
1661 $self->setfield($field, "$1.$2.$3.$4");
1667 Check/untaint ip addresses. IPv4 only for now. May be null.
1672 my( $self, $field ) = @_;
1673 if ( $self->getfield($field) =~ /^()$/ ) {
1674 $self->setfield($field,'');
1677 $self->ut_ip($field);
1681 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
1683 Check/untaint coordinates.
1684 Accepts the following forms:
1694 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
1695 The latter form (that is, the MMM are thousands of minutes) is
1696 assumed if the "MMM" is exactly three digits or two digits > 59.
1698 To be safe, just use the DDD.DDDDD form.
1700 If LOWER or UPPER are specified, then the coordinate is checked
1701 for lower and upper bounds, respectively.
1707 my ($self, $field) = (shift, shift);
1709 my $lower = shift if scalar(@_);
1710 my $upper = shift if scalar(@_);
1711 my $coord = $self->getfield($field);
1712 my $neg = $coord =~ s/^(-)//;
1714 my ($d, $m, $s) = (0, 0, 0);
1717 (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
1718 (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
1719 (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
1721 $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
1724 return "Invalid (coordinate with minutes > 59) $field: "
1725 . $self->getfield($field);
1728 $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
1730 if (defined($lower) and ($coord < $lower)) {
1731 return "Invalid (coordinate < $lower) $field: "
1732 . $self->getfield($field);;
1735 if (defined($upper) and ($coord > $upper)) {
1736 return "Invalid (coordinate > $upper) $field: "
1737 . $self->getfield($field);;
1740 $self->setfield($field, $coord);
1744 return "Invalid (coordinate) $field: " . $self->getfield($field);
1748 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
1750 Same as ut_coord, except optionally null.
1756 my ($self, $field) = (shift, shift);
1758 if ($self->getfield($field) =~ /^$/) {
1761 return $self->ut_coord($field, @_);
1767 =item ut_domain COLUMN
1769 Check/untaint host and domain names.
1774 my( $self, $field ) = @_;
1775 #$self->getfield($field) =~/^(\w+\.)*\w+$/
1776 $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
1777 or return "Illegal (domain) $field: ". $self->getfield($field);
1778 $self->setfield($field,$1);
1782 =item ut_name COLUMN
1784 Check/untaint proper names; allows alphanumerics, spaces and the following
1785 punctuation: , . - '
1792 my( $self, $field ) = @_;
1793 $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
1794 or return gettext('illegal_name'). " $field: ". $self->getfield($field);
1795 $self->setfield($field,$1);
1801 Check/untaint zip codes.
1805 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
1808 my( $self, $field, $country ) = @_;
1810 if ( $country eq 'US' ) {
1812 $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
1813 or return gettext('illegal_zip'). " $field for country $country: ".
1814 $self->getfield($field);
1815 $self->setfield($field, $1);
1817 } elsif ( $country eq 'CA' ) {
1819 $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
1820 or return gettext('illegal_zip'). " $field for country $country: ".
1821 $self->getfield($field);
1822 $self->setfield($field, "$1 $2");
1826 if ( $self->getfield($field) =~ /^\s*$/
1827 && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
1830 $self->setfield($field,'');
1832 $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
1833 or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
1834 $self->setfield($field,$1);
1842 =item ut_country COLUMN
1844 Check/untaint country codes. Country names are changed to codes, if possible -
1845 see L<Locale::Country>.
1850 my( $self, $field ) = @_;
1851 unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
1852 if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
1853 && country2code($1) ) {
1854 $self->setfield($field,uc(country2code($1)));
1857 $self->getfield($field) =~ /^(\w\w)$/
1858 or return "Illegal (country) $field: ". $self->getfield($field);
1859 $self->setfield($field,uc($1));
1863 =item ut_anything COLUMN
1865 Untaints arbitrary data. Be careful.
1870 my( $self, $field ) = @_;
1871 $self->getfield($field) =~ /^(.*)$/s
1872 or return "Illegal $field: ". $self->getfield($field);
1873 $self->setfield($field,$1);
1877 =item ut_enum COLUMN CHOICES_ARRAYREF
1879 Check/untaint a column, supplying all possible choices, like the "enum" type.
1884 my( $self, $field, $choices ) = @_;
1885 foreach my $choice ( @$choices ) {
1886 if ( $self->getfield($field) eq $choice ) {
1887 $self->setfield($choice);
1891 return "Illegal (enum) field $field: ". $self->getfield($field);
1894 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
1896 Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
1897 on the column first.
1901 sub ut_foreign_key {
1902 my( $self, $field, $table, $foreign ) = @_;
1903 qsearchs($table, { $foreign => $self->getfield($field) })
1904 or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
1905 " in $table.$foreign";
1909 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
1911 Like ut_foreign_key, except the null value is also allowed.
1915 sub ut_foreign_keyn {
1916 my( $self, $field, $table, $foreign ) = @_;
1917 $self->getfield($field)
1918 ? $self->ut_foreign_key($field, $table, $foreign)
1922 =item ut_agentnum_acl
1924 Checks this column as an agentnum, taking into account the current users's
1929 sub ut_agentnum_acl {
1930 my( $self, $field, $null_acl ) = @_;
1932 my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
1933 return "Illegal agentnum: $error" if $error;
1935 my $curuser = $FS::CurrentUser::CurrentUser;
1937 if ( $self->$field() ) {
1939 return "Access denied"
1940 unless $curuser->agentnum($self->$field());
1944 return "Access denied"
1945 unless $curuser->access_right($null_acl);
1953 =item virtual_fields [ TABLE ]
1955 Returns a list of virtual fields defined for the table. This should not
1956 be exported, and should only be called as an instance or class method.
1960 sub virtual_fields {
1963 $table = $self->table or confess "virtual_fields called on non-table";
1965 confess "Unknown table $table" unless dbdef->table($table);
1967 return () unless dbdef->table('part_virtual_field');
1969 unless ( $virtual_fields_cache{$table} ) {
1970 my $query = 'SELECT name from part_virtual_field ' .
1971 "WHERE dbtable = '$table'";
1973 my $result = $dbh->selectcol_arrayref($query);
1974 confess "Error executing virtual fields query: $query: ". $dbh->errstr
1976 $virtual_fields_cache{$table} = $result;
1979 @{$virtual_fields_cache{$table}};
1984 =item fields [ TABLE ]
1986 This is a wrapper for real_fields and virtual_fields. Code that called
1987 fields before should probably continue to call fields.
1992 my $something = shift;
1994 if($something->isa('FS::Record')) {
1995 $table = $something->table;
1997 $table = $something;
1998 $something = "FS::$table";
2000 return (real_fields($table), $something->virtual_fields());
2003 =item pvf FIELD_NAME
2005 Returns the FS::part_virtual_field object corresponding to a field in the
2006 record (specified by FIELD_NAME).
2011 my ($self, $name) = (shift, shift);
2013 if(grep /^$name$/, $self->virtual_fields) {
2014 return qsearchs('part_virtual_field', { dbtable => $self->table,
2020 =item vfieldpart_hashref TABLE
2022 Returns a hashref of virtual field names and vfieldparts applicable to the given
2027 sub vfieldpart_hashref {
2029 my $table = $self->table;
2031 return {} unless dbdef->table('part_virtual_field');
2034 my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
2035 "dbtable = '$table'";
2036 my $sth = $dbh->prepare($statement);
2037 $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
2038 return { map { $_->{name}, $_->{vfieldpart} }
2039 @{$sth->fetchall_arrayref({})} };
2043 =item encrypt($value)
2045 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2047 Returns the encrypted string.
2049 You should generally not have to worry about calling this, as the system handles this for you.
2054 my ($self, $value) = @_;
2057 if ($conf->exists('encryption')) {
2058 if ($self->is_encrypted($value)) {
2059 # Return the original value if it isn't plaintext.
2060 $encrypted = $value;
2063 if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2064 # RSA doesn't like the empty string so let's pack it up
2065 # The database doesn't like the RSA data so uuencode it
2066 my $length = length($value)+1;
2067 $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2069 die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2076 =item is_encrypted($value)
2078 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2084 my ($self, $value) = @_;
2085 # Possible Bug - Some work may be required here....
2087 if ($value =~ /^M/ && length($value) > 80) {
2094 =item decrypt($value)
2096 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2098 You should generally not have to worry about calling this, as the system handles this for you.
2103 my ($self,$value) = @_;
2104 my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2105 if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2107 if (ref($rsa_decrypt) =~ /::RSA/) {
2108 my $encrypted = unpack ("u*", $value);
2109 $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2110 if ($@) {warn "Decryption Failed"};
2118 #Initialize the Module
2119 $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2121 if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') {
2122 $rsa_module = $conf->config('encryptionmodule');
2126 eval ("require $rsa_module"); # No need to import the namespace
2129 # Initialize Encryption
2130 if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') {
2131 my $public_key = join("\n",$conf->config('encryptionpublickey'));
2132 $rsa_encrypt = $rsa_module->new_public_key($public_key);
2135 # Intitalize Decryption
2136 if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') {
2137 my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2138 $rsa_decrypt = $rsa_module->new_private_key($private_key);
2142 =item h_search ACTION
2144 Given an ACTION, either "insert", or "delete", returns the appropriate history
2145 record corresponding to this record, if any.
2150 my( $self, $action ) = @_;
2152 my $table = $self->table;
2155 my $primary_key = dbdef->table($table)->primary_key;
2158 'table' => "h_$table",
2159 'hashref' => { $primary_key => $self->$primary_key(),
2160 'history_action' => $action,
2168 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2169 appropriate history record corresponding to this record, if any.
2174 my($self, $action) = @_;
2175 my $h = $self->h_search($action);
2176 $h ? $h->history_date : '';
2185 =item real_fields [ TABLE ]
2187 Returns a list of the real columns in the specified table. Called only by
2188 fields() and other subroutines elsewhere in FS::Record.
2195 my($table_obj) = dbdef->table($table);
2196 confess "Unknown table $table" unless $table_obj;
2197 $table_obj->columns;
2200 =item _quote VALUE, TABLE, COLUMN
2202 This is an internal function used to construct SQL statements. It returns
2203 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2204 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2209 my($value, $table, $column) = @_;
2210 my $column_obj = dbdef->table($table)->column($column);
2211 my $column_type = $column_obj->type;
2212 my $nullable = $column_obj->null;
2214 warn " $table.$column: $value ($column_type".
2215 ( $nullable ? ' NULL' : ' NOT NULL' ).
2216 ")\n" if $DEBUG > 2;
2218 if ( $value eq '' && $nullable ) {
2220 } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2221 cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2224 } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2225 ! $column_type =~ /(char|binary|text)$/i ) {
2234 This is deprecated. Don't use it.
2236 It returns a hash-type list with the fields of this record's table set true.
2241 carp "warning: hfields is deprecated";
2244 foreach (fields($table)) {
2253 "$_: ". $self->getfield($_). "|"
2254 } (fields($self->table)) );
2257 sub DESTROY { return; }
2261 # #use Carp qw(cluck);
2262 # #cluck "DESTROYING $self";
2263 # warn "DESTROYING $self";
2267 # return ! eval { join('',@_), kill 0; 1; };
2270 =item str2time_sql [ DRIVER_NAME ]
2272 Returns a function to convert to unix time based on database type, such as
2273 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql. See
2274 the str2time_sql_closing method to return a closing string rather than just
2275 using a closing parenthesis as previously suggested.
2277 You can pass an optional driver name such as "Pg", "mysql" or
2278 $dbh->{Driver}->{Name} to return a function for that database instead of
2279 the current database.
2284 my $driver = shift || driver_name;
2286 return 'UNIX_TIMESTAMP(' if $driver =~ /^mysql/i;
2287 return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
2289 warn "warning: unknown database type $driver; guessing how to convert ".
2290 "dates to UNIX timestamps";
2291 return 'EXTRACT(EPOCH FROM ';
2295 =item str2time_sql_closing [ DRIVER_NAME ]
2297 Returns the closing suffix of a function to convert to unix time based on
2298 database type, such as ")::integer" for Pg or ")" for mysql.
2300 You can pass an optional driver name such as "Pg", "mysql" or
2301 $dbh->{Driver}->{Name} to return a function for that database instead of
2302 the current database.
2306 sub str2time_sql_closing {
2307 my $driver = shift || driver_name;
2309 return ' )::INTEGER ' if $driver =~ /^Pg/i;
2317 This module should probably be renamed, since much of the functionality is
2318 of general use. It is not completely unlike Adapter::DBI (see below).
2320 Exported qsearch and qsearchs should be deprecated in favor of method calls
2321 (against an FS::Record object like the old search and searchs that qsearch
2322 and qsearchs were on top of.)
2324 The whole fields / hfields mess should be removed.
2326 The various WHERE clauses should be subroutined.
2328 table string should be deprecated in favor of DBIx::DBSchema::Table.
2330 No doubt we could benefit from a Tied hash. Documenting how exists / defined
2331 true maps to the database (and WHERE clauses) would also help.
2333 The ut_ methods should ask the dbdef for a default length.
2335 ut_sqltype (like ut_varchar) should all be defined
2337 A fallback check method should be provided which uses the dbdef.
2339 The ut_money method assumes money has two decimal digits.
2341 The Pg money kludge in the new method only strips `$'.
2343 The ut_phonen method only checks US-style phone numbers.
2345 The _quote function should probably use ut_float instead of a regex.
2347 All the subroutines probably should be methods, here or elsewhere.
2349 Probably should borrow/use some dbdef methods where appropriate (like sub
2352 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
2353 or allow it to be set. Working around it is ugly any way around - DBI should
2354 be fixed. (only affects RDBMS which return uppercase column names)
2356 ut_zip should take an optional country like ut_phone.
2360 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
2362 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.