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);
11 use DBI qw(:sql_types);
12 use DBIx::DBSchema 0.33;
13 use FS::UID qw(dbh getotaker datasrc driver_name);
15 use FS::Schema qw(dbdef);
17 use FS::Msgcat qw(gettext);
20 use FS::part_virtual_field;
26 #export dbdef for now... everything else expects to find it here
27 @EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch str2time_sql);
32 $nowarn_identical = 0;
40 FS::UID->install_callback( sub {
42 $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc;
48 FS::Record - Database record objects
53 use FS::Record qw(dbh fields qsearch qsearchs);
55 $record = new FS::Record 'table', \%hash;
56 $record = new FS::Record 'table', { 'column' => 'value', ... };
58 $record = qsearchs FS::Record 'table', \%hash;
59 $record = qsearchs FS::Record 'table', { 'column' => 'value', ... };
60 @records = qsearch FS::Record 'table', \%hash;
61 @records = qsearch FS::Record 'table', { 'column' => 'value', ... };
63 $table = $record->table;
64 $dbdef_table = $record->dbdef_table;
66 $value = $record->get('column');
67 $value = $record->getfield('column');
68 $value = $record->column;
70 $record->set( 'column' => 'value' );
71 $record->setfield( 'column' => 'value' );
72 $record->column('value');
74 %hash = $record->hash;
76 $hashref = $record->hashref;
78 $error = $record->insert;
80 $error = $record->delete;
82 $error = $new_record->replace($old_record);
84 # external use deprecated - handled by the database (at least for Pg, mysql)
85 $value = $record->unique('column');
87 $error = $record->ut_float('column');
88 $error = $record->ut_floatn('column');
89 $error = $record->ut_number('column');
90 $error = $record->ut_numbern('column');
91 $error = $record->ut_snumber('column');
92 $error = $record->ut_snumbern('column');
93 $error = $record->ut_money('column');
94 $error = $record->ut_text('column');
95 $error = $record->ut_textn('column');
96 $error = $record->ut_alpha('column');
97 $error = $record->ut_alphan('column');
98 $error = $record->ut_phonen('column');
99 $error = $record->ut_anything('column');
100 $error = $record->ut_name('column');
102 $quoted_value = _quote($value,'table','field');
105 $fields = hfields('table');
106 if ( $fields->{Field} ) { # etc.
108 @fields = fields 'table'; #as a subroutine
109 @fields = $record->fields; #as a method call
114 (Mostly) object-oriented interface to database records. Records are currently
115 implemented on top of DBI. FS::Record is intended as a base class for
116 table-specific classes to inherit from, i.e. FS::cust_main.
122 =item new [ TABLE, ] HASHREF
124 Creates a new record. It doesn't store it in the database, though. See
125 L<"insert"> for that.
127 Note that the object stores this hash reference, not a distinct copy of the
128 hash it points to. You can ask the object for a copy with the I<hash>
131 TABLE can only be omitted when a dervived class overrides the table method.
137 my $class = ref($proto) || $proto;
139 bless ($self, $class);
141 unless ( defined ( $self->table ) ) {
142 $self->{'Table'} = shift;
143 carp "warning: FS::Record::new called with table name ". $self->{'Table'};
146 $self->{'Hash'} = shift;
148 foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
149 $self->{'Hash'}{$field}='';
152 $self->_rebless if $self->can('_rebless');
154 $self->{'modified'} = 0;
156 $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
163 my $class = ref($proto) || $proto;
165 bless ($self, $class);
167 $self->{'Table'} = shift unless defined ( $self->table );
169 my $hashref = $self->{'Hash'} = shift;
171 if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) {
172 my $obj = $cache->cache->{$hashref->{$cache->key}};
173 $obj->_cache($hashref, $cache) if $obj->can('_cache');
176 $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache);
183 my $class = ref($proto) || $proto;
185 bless ($self, $class);
186 if ( defined $self->table ) {
187 cluck "create constructor is deprecated, use new!";
190 croak "FS::Record::create called (not from a subclass)!";
194 =item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
196 Searches the database for all records matching (at least) the key/value pairs
197 in HASHREF. Returns all the records found as `FS::TABLE' objects if that
198 module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
201 The preferred usage is to pass a hash reference of named parameters:
203 my @records = qsearch( {
204 'table' => 'table_name',
205 'hashref' => { 'field' => 'value'
206 'field' => { 'op' => '<',
211 #these are optional...
213 'extra_sql' => 'AND field ',
214 'order_by' => 'ORDER BY something',
215 #'cache_obj' => '', #optional
216 'addl_from' => 'LEFT JOIN othtable USING ( field )',
221 Much code still uses old-style positional parameters, this is also probably
222 fine in the common case where there are only two parameters:
224 my @records = qsearch( 'table', { 'field' => 'value' } );
226 ###oops, argh, FS::Record::new only lets us create database fields.
227 #Normal behaviour if SELECT is not specified is `*', as in
228 #C<SELECT * FROM table WHERE ...>. However, there is an experimental new
229 #feature where you can specify SELECT - remember, the objects returned,
230 #although blessed into the appropriate `FS::TABLE' package, will only have the
231 #fields you specify. This might have unwanted results if you then go calling
232 #regular FS::TABLE methods
238 my($stable, $record, $select, $extra_sql, $order_by, $cache, $addl_from );
240 if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too
242 $stable = $opt->{'table'} or die "table name is required";
243 $record = $opt->{'hashref'} || {};
244 $select = $opt->{'select'} || '*';
245 $extra_sql = $opt->{'extra_sql'} || '';
246 $order_by = $opt->{'order_by'} || '';
247 $cache = $opt->{'cache_obj'} || '';
248 $addl_from = $opt->{'addl_from'} || '';
249 $debug = $opt->{'debug'} || '';
251 ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_;
255 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
257 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
261 my $table = $cache ? $cache->table : $stable;
262 my $dbdef_table = dbdef->table($table)
263 or die "No schema for table $table found - ".
264 "do you need to run freeside-upgrade?";
265 my $pkey = $dbdef_table->primary_key;
267 my @real_fields = grep exists($record->{$_}), real_fields($table);
269 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
270 @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
272 cluck "warning: FS::$table not loaded; virtual fields not searchable";
273 @virtual_fields = ();
276 my $statement = "SELECT $select FROM $stable";
277 $statement .= " $addl_from" if $addl_from;
278 if ( @real_fields or @virtual_fields ) {
279 $statement .= ' WHERE '. join(' AND ',
280 get_real_fields($table, $record, \@real_fields) ,
281 get_virtual_fields($table, $pkey, $record, \@virtual_fields),
285 $statement .= " $extra_sql" if defined($extra_sql);
286 $statement .= " $order_by" if defined($order_by);
288 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
289 my $sth = $dbh->prepare($statement)
290 or croak "$dbh->errstr doing $statement";
295 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
297 if ( $record->{$field} =~ /^\d+(\.\d+)?$/
298 && dbdef->table($table)->column($field)->type =~ /(int|(big)?serial)/i
300 $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } );
301 }elsif ( $record->{$field} =~ /^[+-]?\d+(\.\d+)?$/
302 && dbdef->table($table)->column($field)->type =~ /(numeric)/i
304 $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_FLOAT } );
305 }elsif ( $record->{$field} =~ /[-+]?\d*\.?\d+([eE][-+]?\d+)?/
306 && dbdef->table($table)->column($field)->type =~ /(float4)/i
308 $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_FLOAT } );
310 $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_VARCHAR } );
314 # $sth->execute( map $record->{$_},
315 # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
316 # ) or croak "Error executing \"$statement\": ". $sth->errstr;
318 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
320 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
321 @virtual_fields = "FS::$table"->virtual_fields;
323 cluck "warning: FS::$table not loaded; virtual fields not returned either";
324 @virtual_fields = ();
328 tie %result, "Tie::IxHash";
329 my @stuff = @{ $sth->fetchall_arrayref( {} ) };
330 if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
331 %result = map { $_->{$pkey}, $_ } @stuff;
333 @result{@stuff} = @stuff;
338 if ( keys(%result) and @virtual_fields ) {
340 "SELECT virtual_field.recnum, part_virtual_field.name, ".
341 "virtual_field.value ".
342 "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ".
343 "WHERE part_virtual_field.dbtable = '$table' AND ".
344 "virtual_field.recnum IN (".
345 join(',', keys(%result)). ") AND part_virtual_field.name IN ('".
346 join(q!', '!, @virtual_fields) . "')";
347 warn "[debug]$me $statement\n" if $DEBUG > 1;
348 $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement";
349 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
351 foreach (@{ $sth->fetchall_arrayref({}) }) {
352 my $recnum = $_->{recnum};
353 my $name = $_->{name};
354 my $value = $_->{value};
355 if (exists($result{$recnum})) {
356 $result{$recnum}->{$name} = $value;
361 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
362 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
363 #derivied class didn't override new method, so this optimization is safe
366 new_or_cached( "FS::$table", { %{$_} }, $cache )
370 new( "FS::$table", { %{$_} } )
374 #okay, its been tested
375 # warn "untested code (class FS::$table uses custom new method)";
377 eval 'FS::'. $table. '->new( { %{$_} } )';
381 # Check for encrypted fields and decrypt them.
382 ## only in the local copy, not the cached object
383 if ( $conf && $conf->exists('encryption') # $conf doesn't exist when doing
384 # the initial search for
386 && eval 'defined(@FS::'. $table . '::encrypted_fields)') {
387 foreach my $record (@return) {
388 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
389 # Set it directly... This may cause a problem in the future...
390 $record->setfield($field, $record->decrypt($record->getfield($field)));
395 cluck "warning: FS::$table not loaded; returning FS::Record objects";
397 FS::Record->new( $table, { %{$_} } );
403 ## makes this easier to read
405 sub get_virtual_fields {
409 my $virtual_fields = shift;
415 if ( ref($record->{$_}) ) {
416 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
417 if ( uc($op) eq 'ILIKE' ) {
419 $record->{$_}{'value'} = lc($record->{$_}{'value'});
420 $column = "LOWER($_)";
422 $record->{$_} = $record->{$_}{'value'};
425 # ... EXISTS ( SELECT name, value FROM part_virtual_field
427 # ON part_virtual_field.vfieldpart = virtual_field.vfieldpart
428 # WHERE recnum = svc_acct.svcnum
429 # AND (name, value) = ('egad', 'brain') )
431 my $value = $record->{$_};
435 $subq = ($value ? 'EXISTS ' : 'NOT EXISTS ') .
436 "( SELECT part_virtual_field.name, virtual_field.value ".
437 "FROM part_virtual_field JOIN virtual_field ".
438 "ON part_virtual_field.vfieldpart = virtual_field.vfieldpart ".
439 "WHERE virtual_field.recnum = ${table}.${pkey} ".
440 "AND part_virtual_field.name = '${column}'".
442 " AND virtual_field.value ${op} '${value}'"
446 } @{ $virtual_fields } ) ;
449 sub get_real_fields {
452 my $real_fields = shift;
454 ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability
460 if ( ref($record->{$_}) ) {
461 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
462 #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
463 if ( uc($op) eq 'ILIKE' ) {
465 $record->{$_}{'value'} = lc($record->{$_}{'value'});
466 $column = "LOWER($_)";
468 $record->{$_} = $record->{$_}{'value'}
471 if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
473 if ( driver_name eq 'Pg' ) {
474 my $type = dbdef->table($table)->column($column)->type;
475 if ( $type =~ /(int|(big)?serial)/i ) {
476 qq-( $column IS NULL )-;
478 qq-( $column IS NULL OR $column = '' )-;
481 qq-( $column IS NULL OR $column = "" )-;
483 } elsif ( $op eq '!=' ) {
484 if ( driver_name eq 'Pg' ) {
485 my $type = dbdef->table($table)->column($column)->type;
486 if ( $type =~ /(int|(big)?serial)/i ) {
487 qq-( $column IS NOT NULL )-;
489 qq-( $column IS NOT NULL AND $column != '' )-;
492 qq-( $column IS NOT NULL AND $column != "" )-;
495 if ( driver_name eq 'Pg' ) {
496 qq-( $column $op '' )-;
498 qq-( $column $op "" )-;
504 } @{ $real_fields } );
507 =item by_key PRIMARY_KEY_VALUE
509 This is a class method that returns the record with the given primary key
510 value. This method is only useful in FS::Record subclasses. For example:
512 my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
516 my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
521 my ($class, $pkey_value) = @_;
523 my $table = $class->table
524 or croak "No table for $class found";
526 my $dbdef_table = dbdef->table($table)
527 or die "No schema for table $table found - ".
528 "do you need to create it or run dbdef-create?";
529 my $pkey = $dbdef_table->primary_key
530 or die "No primary key for table $table";
532 return qsearchs($table, { $pkey => $pkey_value });
535 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
537 Experimental JOINed search method. Using this method, you can execute a
538 single SELECT spanning multiple tables, and cache the results for subsequent
539 method calls. Interface will almost definately change in an incompatible
547 my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
548 my $cache = FS::SearchCache->new( $ptable, $pkey );
551 grep { !$saw{$_->getfield($pkey)}++ }
552 qsearch($table, $record, $select, $extra_sql, $cache )
556 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
558 Same as qsearch, except that if more than one record matches, it B<carp>s but
559 returns the first. If this happens, you either made a logic error in asking
560 for a single item, or your data is corrupted.
564 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
566 my(@result) = qsearch(@_);
567 cluck "warning: Multiple records in scalar search ($table)"
568 if scalar(@result) > 1;
569 #should warn more vehemently if the search was on a primary key?
570 scalar(@result) ? ($result[0]) : ();
581 Returns the table name.
586 # cluck "warning: FS::Record::table deprecated; supply one in subclass!";
593 Returns the DBIx::DBSchema::Table object for the table.
599 my($table)=$self->table;
600 dbdef->table($table);
605 Returns the primary key for the table.
611 my $pkey = $self->dbdef_table->primary_key;
614 =item get, getfield COLUMN
616 Returns the value of the column/field/key COLUMN.
621 my($self,$field) = @_;
622 # to avoid "Use of unitialized value" errors
623 if ( defined ( $self->{Hash}->{$field} ) ) {
624 $self->{Hash}->{$field};
634 =item set, setfield COLUMN, VALUE
636 Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE.
641 my($self,$field,$value) = @_;
642 $self->{'modified'} = 1;
643 $self->{'Hash'}->{$field} = $value;
650 =item AUTLOADED METHODS
652 $record->column is a synonym for $record->get('column');
654 $record->column('value') is a synonym for $record->set('column','value');
661 my($field)=$AUTOLOAD;
663 if ( defined($value) ) {
664 confess "errant AUTOLOAD $field for $self (arg $value)"
665 unless ref($self) && $self->can('setfield');
666 $self->setfield($field,$value);
668 confess "errant AUTOLOAD $field for $self (no args)"
669 unless ref($self) && $self->can('getfield');
670 $self->getfield($field);
676 # my $field = $AUTOLOAD;
678 # if ( defined($_[1]) ) {
679 # $_[0]->setfield($field, $_[1]);
681 # $_[0]->getfield($field);
687 Returns a list of the column/value pairs, usually for assigning to a new hash.
689 To make a distinct duplicate of an FS::Record object, you can do:
691 $new = new FS::Record ( $old->table, { $old->hash } );
697 confess $self. ' -> hash: Hash attribute is undefined'
698 unless defined($self->{'Hash'});
699 %{ $self->{'Hash'} };
704 Returns a reference to the column/value hash. This may be deprecated in the
705 future; if there's a reason you can't just use the autoloaded or get/set
717 Returns true if any of this object's values have been modified with set (or via
718 an autoloaded method). Doesn't yet recognize when you retreive a hashref and
728 =item select_for_update
730 Selects this record with the SQL "FOR UPDATE" command. This can be useful as
735 sub select_for_update {
737 my $primary_key = $self->primary_key;
740 'table' => $self->table,
741 'hashref' => { $primary_key => $self->$primary_key() },
742 'extra_sql' => 'FOR UPDATE',
748 Inserts this record to the database. If there is an error, returns the error,
749 otherwise returns false.
757 warn "$self -> insert" if $DEBUG;
759 my $error = $self->check;
760 return $error if $error;
762 #single-field unique keys are given a value if false
763 #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
764 foreach ( $self->dbdef_table->unique_singles) {
765 $self->unique($_) unless $self->getfield($_);
768 #and also the primary key, if the database isn't going to
769 my $primary_key = $self->dbdef_table->primary_key;
771 if ( $primary_key ) {
772 my $col = $self->dbdef_table->column($primary_key);
775 uc($col->type) =~ /^(BIG)?SERIAL\d?/
776 || ( driver_name eq 'Pg'
777 && defined($col->default)
778 && $col->default =~ /^nextval\(/i
780 || ( driver_name eq 'mysql'
781 && defined($col->local)
782 && $col->local =~ /AUTO_INCREMENT/i
784 $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
787 my $table = $self->table;
790 # Encrypt before the database
791 my $conf = new FS::Conf;
792 if ($conf->exists('encryption') && defined(eval '@FS::'. $table . '::encrypted_fields')) {
793 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
794 $self->{'saved'} = $self->getfield($field);
795 $self->setfield($field, $self->encrypt($self->getfield($field)));
800 #false laziness w/delete
802 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
805 my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
808 my $statement = "INSERT INTO $table ";
809 if ( @real_fields ) {
812 join( ', ', @real_fields ).
814 join( ', ', @values ).
818 $statement .= 'DEFAULT VALUES';
820 warn "[debug]$me $statement\n" if $DEBUG > 1;
821 my $sth = dbh->prepare($statement) or return dbh->errstr;
823 local $SIG{HUP} = 'IGNORE';
824 local $SIG{INT} = 'IGNORE';
825 local $SIG{QUIT} = 'IGNORE';
826 local $SIG{TERM} = 'IGNORE';
827 local $SIG{TSTP} = 'IGNORE';
828 local $SIG{PIPE} = 'IGNORE';
830 $sth->execute or return $sth->errstr;
832 # get inserted id from the database, if applicable & needed
833 if ( $db_seq && ! $self->getfield($primary_key) ) {
834 warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
838 if ( driver_name eq 'Pg' ) {
840 #my $oid = $sth->{'pg_oid_status'};
841 #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
843 my $default = $self->dbdef_table->column($primary_key)->default;
844 unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
845 dbh->rollback if $FS::UID::AutoCommit;
846 return "can't parse $table.$primary_key default value".
847 " for sequence name: $default";
851 my $i_sql = "SELECT currval('$sequence')";
852 my $i_sth = dbh->prepare($i_sql) or do {
853 dbh->rollback if $FS::UID::AutoCommit;
856 $i_sth->execute() or do { #$i_sth->execute($oid)
857 dbh->rollback if $FS::UID::AutoCommit;
858 return $i_sth->errstr;
860 $insertid = $i_sth->fetchrow_arrayref->[0];
862 } elsif ( driver_name eq 'mysql' ) {
864 $insertid = dbh->{'mysql_insertid'};
865 # work around mysql_insertid being null some of the time, ala RT :/
866 unless ( $insertid ) {
867 warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
868 "using SELECT LAST_INSERT_ID();";
869 my $i_sql = "SELECT LAST_INSERT_ID()";
870 my $i_sth = dbh->prepare($i_sql) or do {
871 dbh->rollback if $FS::UID::AutoCommit;
874 $i_sth->execute or do {
875 dbh->rollback if $FS::UID::AutoCommit;
876 return $i_sth->errstr;
878 $insertid = $i_sth->fetchrow_arrayref->[0];
883 dbh->rollback if $FS::UID::AutoCommit;
884 return "don't know how to retreive inserted ids from ". driver_name.
885 ", try using counterfiles (maybe run dbdef-create?)";
889 $self->setfield($primary_key, $insertid);
894 grep defined($self->getfield($_)) && $self->getfield($_) ne "",
895 $self->virtual_fields;
896 if (@virtual_fields) {
897 my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
899 my $vfieldpart = $self->vfieldpart_hashref;
901 my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
904 my $v_sth = dbh->prepare($v_statement) or do {
905 dbh->rollback if $FS::UID::AutoCommit;
909 foreach (keys(%v_values)) {
910 $v_sth->execute($self->getfield($primary_key),
914 dbh->rollback if $FS::UID::AutoCommit;
915 return $v_sth->errstr;
922 if ( defined dbdef->table('h_'. $table) ) {
923 my $h_statement = $self->_h_statement('insert');
924 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
925 $h_sth = dbh->prepare($h_statement) or do {
926 dbh->rollback if $FS::UID::AutoCommit;
932 $h_sth->execute or return $h_sth->errstr if $h_sth;
934 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
936 # Now that it has been saved, reset the encrypted fields so that $new
938 foreach my $field (keys %{$saved}) {
939 $self->setfield($field, $saved->{$field});
947 Depriciated (use insert instead).
952 cluck "warning: FS::Record::add deprecated!";
953 insert @_; #call method in this scope
958 Delete this record from the database. If there is an error, returns the error,
959 otherwise returns false.
966 my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
968 $self->getfield($_) eq ''
969 #? "( $_ IS NULL OR $_ = \"\" )"
970 ? ( driver_name eq 'Pg'
972 : "( $_ IS NULL OR $_ = \"\" )"
974 : "$_ = ". _quote($self->getfield($_),$self->table,$_)
975 } ( $self->dbdef_table->primary_key )
976 ? ( $self->dbdef_table->primary_key)
977 : real_fields($self->table)
979 warn "[debug]$me $statement\n" if $DEBUG > 1;
980 my $sth = dbh->prepare($statement) or return dbh->errstr;
983 if ( defined dbdef->table('h_'. $self->table) ) {
984 my $h_statement = $self->_h_statement('delete');
985 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
986 $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
991 my $primary_key = $self->dbdef_table->primary_key;
994 my $vfp = $self->vfieldpart_hashref;
995 foreach($self->virtual_fields) {
996 next if $self->getfield($_) eq '';
997 unless(@del_vfields) {
998 my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
999 $v_sth = dbh->prepare($st) or return dbh->errstr;
1001 push @del_vfields, $_;
1004 local $SIG{HUP} = 'IGNORE';
1005 local $SIG{INT} = 'IGNORE';
1006 local $SIG{QUIT} = 'IGNORE';
1007 local $SIG{TERM} = 'IGNORE';
1008 local $SIG{TSTP} = 'IGNORE';
1009 local $SIG{PIPE} = 'IGNORE';
1011 my $rc = $sth->execute or return $sth->errstr;
1012 #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1013 $h_sth->execute or return $h_sth->errstr if $h_sth;
1014 $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
1015 or return $v_sth->errstr
1016 foreach (@del_vfields);
1018 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1020 #no need to needlessly destoy the data either (causes problems actually)
1021 #undef $self; #no need to keep object!
1028 Depriciated (use delete instead).
1033 cluck "warning: FS::Record::del deprecated!";
1034 &delete(@_); #call method in this scope
1037 =item replace OLD_RECORD
1039 Replace the OLD_RECORD with this one in the database. If there is an error,
1040 returns the error, otherwise returns false.
1045 my ($new, $old) = (shift, shift);
1047 $old = $new->replace_old unless defined($old);
1049 warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1051 if ( $new->can('replace_check') ) {
1052 my $error = $new->replace_check($old);
1053 return $error if $error;
1056 return "Records not in same table!" unless $new->table eq $old->table;
1058 my $primary_key = $old->dbdef_table->primary_key;
1059 return "Can't change primary key $primary_key ".
1060 'from '. $old->getfield($primary_key).
1061 ' to ' . $new->getfield($primary_key)
1063 && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1065 my $error = $new->check;
1066 return $error if $error;
1068 # Encrypt for replace
1069 my $conf = new FS::Conf;
1071 if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) {
1072 foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1073 $saved->{$field} = $new->getfield($field);
1074 $new->setfield($field, $new->encrypt($new->getfield($field)));
1078 #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1079 my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1080 ? ($_, $new->getfield($_)) : () } $old->fields;
1082 unless (keys(%diff) || $no_update_diff ) {
1083 carp "[warning]$me $new -> replace $old: records identical"
1084 unless $nowarn_identical;
1088 my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1090 "$_ = ". _quote($new->getfield($_),$old->table,$_)
1091 } real_fields($old->table)
1096 if ( $old->getfield($_) eq '' ) {
1098 #false laziness w/qsearch
1099 if ( driver_name eq 'Pg' ) {
1100 my $type = $old->dbdef_table->column($_)->type;
1101 if ( $type =~ /(int|(big)?serial)/i ) {
1104 qq-( $_ IS NULL OR $_ = '' )-;
1107 qq-( $_ IS NULL OR $_ = "" )-;
1111 "$_ = ". _quote($old->getfield($_),$old->table,$_);
1114 } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1117 warn "[debug]$me $statement\n" if $DEBUG > 1;
1118 my $sth = dbh->prepare($statement) or return dbh->errstr;
1121 if ( defined dbdef->table('h_'. $old->table) ) {
1122 my $h_old_statement = $old->_h_statement('replace_old');
1123 warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1124 $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1130 if ( defined dbdef->table('h_'. $new->table) ) {
1131 my $h_new_statement = $new->_h_statement('replace_new');
1132 warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1133 $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1138 # For virtual fields we have three cases with different SQL
1139 # statements: add, replace, delete
1143 my (@add_vfields, @rep_vfields, @del_vfields);
1144 my $vfp = $old->vfieldpart_hashref;
1145 foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
1146 if($diff{$_} eq '') {
1148 unless(@del_vfields) {
1149 my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
1150 "AND vfieldpart = ?";
1151 warn "[debug]$me $st\n" if $DEBUG > 2;
1152 $v_del_sth = dbh->prepare($st) or return dbh->errstr;
1154 push @del_vfields, $_;
1155 } elsif($old->getfield($_) eq '') {
1157 unless(@add_vfields) {
1158 my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
1160 warn "[debug]$me $st\n" if $DEBUG > 2;
1161 $v_add_sth = dbh->prepare($st) or return dbh->errstr;
1163 push @add_vfields, $_;
1166 unless(@rep_vfields) {
1167 my $st = "UPDATE virtual_field SET value = ? ".
1168 "WHERE recnum = ? AND vfieldpart = ?";
1169 warn "[debug]$me $st\n" if $DEBUG > 2;
1170 $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
1172 push @rep_vfields, $_;
1176 local $SIG{HUP} = 'IGNORE';
1177 local $SIG{INT} = 'IGNORE';
1178 local $SIG{QUIT} = 'IGNORE';
1179 local $SIG{TERM} = 'IGNORE';
1180 local $SIG{TSTP} = 'IGNORE';
1181 local $SIG{PIPE} = 'IGNORE';
1183 my $rc = $sth->execute or return $sth->errstr;
1184 #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1185 $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1186 $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1188 $v_del_sth->execute($old->getfield($primary_key),
1190 or return $v_del_sth->errstr
1191 foreach(@del_vfields);
1193 $v_add_sth->execute($new->getfield($_),
1194 $old->getfield($primary_key),
1196 or return $v_add_sth->errstr
1197 foreach(@add_vfields);
1199 $v_rep_sth->execute($new->getfield($_),
1200 $old->getfield($primary_key),
1202 or return $v_rep_sth->errstr
1203 foreach(@rep_vfields);
1205 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1207 # Now that it has been saved, reset the encrypted fields so that $new
1208 # can still be used.
1209 foreach my $field (keys %{$saved}) {
1210 $new->setfield($field, $saved->{$field});
1218 my( $self ) = shift;
1219 warn "[$me] replace called with no arguments; autoloading old record\n"
1222 my $primary_key = $self->dbdef_table->primary_key;
1223 if ( $primary_key ) {
1224 $self->by_key( $self->$primary_key() ) #this is what's returned
1225 or croak "can't find ". $self->table. ".$primary_key ".
1226 $self->$primary_key();
1228 croak $self->table. " has no primary key; pass old record as argument";
1235 Depriciated (use replace instead).
1240 cluck "warning: FS::Record::rep deprecated!";
1241 replace @_; #call method in this scope
1246 Checks virtual fields (using check_blocks). Subclasses should still provide
1247 a check method to validate real fields, foreign keys, etc., and call this
1248 method via $self->SUPER::check.
1250 (FIXME: Should this method try to make sure that it I<is> being called from
1251 a subclass's check method, to keep the current semantics as far as possible?)
1256 #confess "FS::Record::check not implemented; supply one in subclass!";
1259 foreach my $field ($self->virtual_fields) {
1260 for ($self->getfield($field)) {
1261 # See notes on check_block in FS::part_virtual_field.
1262 eval $self->pvf($field)->check_block;
1264 #this is bad, probably want to follow the stack backtrace up and see
1266 my $err = "Fatal error checking $field for $self";
1268 return "$err (see log for backtrace): $@";
1271 $self->setfield($field, $_);
1278 my( $self, $action, $time ) = @_;
1283 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1284 real_fields($self->table);
1287 # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1288 # You can see if it changed by the paymask...
1289 my $conf = new FS::Conf;
1290 if ($conf->exists('encryption') ) {
1291 @fields = grep $_ ne 'payinfo' && $_ ne 'cvv2', @fields;
1293 my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1295 "INSERT INTO h_". $self->table. " ( ".
1296 join(', ', qw(history_date history_user history_action), @fields ).
1298 join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1305 B<Warning>: External use is B<deprecated>.
1307 Replaces COLUMN in record with a unique number, using counters in the
1308 filesystem. Used by the B<insert> method on single-field unique columns
1309 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1310 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1312 Returns the new value.
1317 my($self,$field) = @_;
1318 my($table)=$self->table;
1320 croak "Unique called on field $field, but it is ",
1321 $self->getfield($field),
1323 if $self->getfield($field);
1325 #warn "table $table is tainted" if is_tainted($table);
1326 #warn "field $field is tainted" if is_tainted($field);
1328 my($counter) = new File::CounterFile "$table.$field",0;
1330 # getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1332 # my($counter) = new File::CounterFile "$user/$table.$field",0;
1335 my $index = $counter->inc;
1336 $index = $counter->inc while qsearchs($table, { $field=>$index } );
1338 $index =~ /^(\d*)$/;
1341 $self->setfield($field,$index);
1345 =item ut_float COLUMN
1347 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be
1348 null. If there is an error, returns the error, otherwise returns false.
1353 my($self,$field)=@_ ;
1354 ($self->getfield($field) =~ /^\s*(\d+\.\d+)\s*$/ ||
1355 $self->getfield($field) =~ /^\s*(\d+)\s*$/ ||
1356 $self->getfield($field) =~ /^\s*(\d+\.\d+e\d+)\s*$/ ||
1357 $self->getfield($field) =~ /^\s*(\d+e\d+)\s*$/)
1358 or return "Illegal or empty (float) $field: ". $self->getfield($field);
1359 $self->setfield($field,$1);
1362 =item ut_floatn COLUMN
1364 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
1365 null. If there is an error, returns the error, otherwise returns false.
1369 #false laziness w/ut_ipn
1371 my( $self, $field ) = @_;
1372 if ( $self->getfield($field) =~ /^()$/ ) {
1373 $self->setfield($field,'');
1376 $self->ut_float($field);
1380 =item ut_sfloat COLUMN
1382 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1383 May not be null. If there is an error, returns the error, otherwise returns
1389 my($self,$field)=@_ ;
1390 ($self->getfield($field) =~ /^\s*(-?\d+\.\d+)\s*$/ ||
1391 $self->getfield($field) =~ /^\s*(-?\d+)\s*$/ ||
1392 $self->getfield($field) =~ /^\s*(-?\d+\.\d+[eE]-?\d+)\s*$/ ||
1393 $self->getfield($field) =~ /^\s*(-?\d+[eE]-?\d+)\s*$/)
1394 or return "Illegal or empty (float) $field: ". $self->getfield($field);
1395 $self->setfield($field,$1);
1398 =item ut_sfloatn COLUMN
1400 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
1401 null. If there is an error, returns the error, otherwise returns false.
1406 my( $self, $field ) = @_;
1407 if ( $self->getfield($field) =~ /^()$/ ) {
1408 $self->setfield($field,'');
1411 $self->ut_sfloat($field);
1415 =item ut_snumber COLUMN
1417 Check/untaint signed numeric data (whole numbers). If there is an error,
1418 returns the error, otherwise returns false.
1423 my($self, $field) = @_;
1424 $self->getfield($field) =~ /^\s*(-?)\s*(\d+)\s*$/
1425 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1426 $self->setfield($field, "$1$2");
1430 =item ut_snumbern COLUMN
1432 Check/untaint signed numeric data (whole numbers). If there is an error,
1433 returns the error, otherwise returns false.
1438 my($self, $field) = @_;
1439 $self->getfield($field) =~ /^\s*(-?)\s*(\d*)\s*$/
1440 or return "Illegal (numeric) $field: ". $self->getfield($field);
1442 return "Illegal (numeric) $field: ". $self->getfield($field)
1445 $self->setfield($field, "$1$2");
1449 =item ut_number COLUMN
1451 Check/untaint simple numeric data (whole numbers). May not be null. If there
1452 is an error, returns the error, otherwise returns false.
1457 my($self,$field)=@_;
1458 $self->getfield($field) =~ /^\s*(\d+)\s*$/
1459 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1460 $self->setfield($field,$1);
1464 =item ut_numbern COLUMN
1466 Check/untaint simple numeric data (whole numbers). May be null. If there is
1467 an error, returns the error, otherwise returns false.
1472 my($self,$field)=@_;
1473 $self->getfield($field) =~ /^\s*(\d*)\s*$/
1474 or return "Illegal (numeric) $field: ". $self->getfield($field);
1475 $self->setfield($field,$1);
1479 =item ut_money COLUMN
1481 Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
1482 is an error, returns the error, otherwise returns false.
1487 my($self,$field)=@_;
1488 $self->setfield($field, 0) if $self->getfield($field) eq '';
1489 $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/
1490 or return "Illegal (money) $field: ". $self->getfield($field);
1491 #$self->setfield($field, "$1$2$3" || 0);
1492 $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
1496 =item ut_text COLUMN
1498 Check/untaint text. Alphanumerics, spaces, and the following punctuation
1499 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ]
1500 May not be null. If there is an error, returns the error, otherwise returns
1506 my($self,$field)=@_;
1507 #warn "msgcat ". \&msgcat. "\n";
1508 #warn "notexist ". \¬exist. "\n";
1509 #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
1510 $self->getfield($field)
1511 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/
1512 or return gettext('illegal_or_empty_text'). " $field: ".
1513 $self->getfield($field);
1514 $self->setfield($field,$1);
1518 =item ut_textn COLUMN
1520 Check/untaint text. Alphanumerics, spaces, and the following punctuation
1521 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
1522 May be null. If there is an error, returns the error, otherwise returns false.
1527 my($self,$field)=@_;
1528 $self->getfield($field)
1529 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/
1530 or return gettext('illegal_text'). " $field: ". $self->getfield($field);
1531 $self->setfield($field,$1);
1535 =item ut_alpha COLUMN
1537 Check/untaint alphanumeric strings (no spaces). May not be null. If there is
1538 an error, returns the error, otherwise returns false.
1543 my($self,$field)=@_;
1544 $self->getfield($field) =~ /^(\w+)$/
1545 or return "Illegal or empty (alphanumeric) $field: ".
1546 $self->getfield($field);
1547 $self->setfield($field,$1);
1551 =item ut_alpha COLUMN
1553 Check/untaint alphanumeric strings (no spaces). May be null. If there is an
1554 error, returns the error, otherwise returns false.
1559 my($self,$field)=@_;
1560 $self->getfield($field) =~ /^(\w*)$/
1561 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
1562 $self->setfield($field,$1);
1566 =item ut_alpha_lower COLUMN
1568 Check/untaint lowercase alphanumeric strings (no spaces). May not be null. If
1569 there is an error, returns the error, otherwise returns false.
1573 sub ut_alpha_lower {
1574 my($self,$field)=@_;
1575 $self->getfield($field) =~ /[[:upper:]]/
1576 and return "Uppercase characters are not permitted in $field";
1577 $self->ut_alpha($field);
1580 =item ut_phonen COLUMN [ COUNTRY ]
1582 Check/untaint phone numbers. May be null. If there is an error, returns
1583 the error, otherwise returns false.
1585 Takes an optional two-letter ISO country code; without it or with unsupported
1586 countries, ut_phonen simply calls ut_alphan.
1591 my( $self, $field, $country ) = @_;
1592 return $self->ut_alphan($field) unless defined $country;
1593 my $phonen = $self->getfield($field);
1594 if ( $phonen eq '' ) {
1595 $self->setfield($field,'');
1596 } elsif ( $country eq 'US' || $country eq 'CA' ) {
1598 $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
1599 or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
1600 $phonen = "$1-$2-$3";
1601 $phonen .= " x$4" if $4;
1602 $self->setfield($field,$phonen);
1604 warn "warning: don't know how to check phone numbers for country $country";
1605 return $self->ut_textn($field);
1612 Check/untaint hexadecimal values.
1617 my($self, $field) = @_;
1618 $self->getfield($field) =~ /^([\da-fA-F]+)$/
1619 or return "Illegal (hex) $field: ". $self->getfield($field);
1620 $self->setfield($field, uc($1));
1624 =item ut_hexn COLUMN
1626 Check/untaint hexadecimal values. May be null.
1631 my($self, $field) = @_;
1632 $self->getfield($field) =~ /^([\da-fA-F]*)$/
1633 or return "Illegal (hex) $field: ". $self->getfield($field);
1634 $self->setfield($field, uc($1));
1639 Check/untaint ip addresses. IPv4 only for now.
1644 my( $self, $field ) = @_;
1645 $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
1646 or return "Illegal (IP address) $field: ". $self->getfield($field);
1647 for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
1648 $self->setfield($field, "$1.$2.$3.$4");
1654 Check/untaint ip addresses. IPv4 only for now. May be null.
1659 my( $self, $field ) = @_;
1660 if ( $self->getfield($field) =~ /^()$/ ) {
1661 $self->setfield($field,'');
1664 $self->ut_ip($field);
1668 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
1670 Check/untaint coordinates.
1671 Accepts the following forms:
1681 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
1682 The latter form (that is, the MMM are thousands of minutes) is
1683 assumed if the "MMM" is exactly three digits or two digits > 59.
1685 To be safe, just use the DDD.DDDDD form.
1687 If LOWER or UPPER are specified, then the coordinate is checked
1688 for lower and upper bounds, respectively.
1694 my ($self, $field) = (shift, shift);
1696 my $lower = shift if scalar(@_);
1697 my $upper = shift if scalar(@_);
1698 my $coord = $self->getfield($field);
1699 my $neg = $coord =~ s/^(-)//;
1701 my ($d, $m, $s) = (0, 0, 0);
1704 (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
1705 (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
1706 (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
1708 $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
1711 return "Invalid (coordinate with minutes > 59) $field: "
1712 . $self->getfield($field);
1715 $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
1717 if (defined($lower) and ($coord < $lower)) {
1718 return "Invalid (coordinate < $lower) $field: "
1719 . $self->getfield($field);;
1722 if (defined($upper) and ($coord > $upper)) {
1723 return "Invalid (coordinate > $upper) $field: "
1724 . $self->getfield($field);;
1727 $self->setfield($field, $coord);
1731 return "Invalid (coordinate) $field: " . $self->getfield($field);
1735 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
1737 Same as ut_coord, except optionally null.
1743 my ($self, $field) = (shift, shift);
1745 if ($self->getfield($field) =~ /^$/) {
1748 return $self->ut_coord($field, @_);
1754 =item ut_domain COLUMN
1756 Check/untaint host and domain names.
1761 my( $self, $field ) = @_;
1762 #$self->getfield($field) =~/^(\w+\.)*\w+$/
1763 $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
1764 or return "Illegal (domain) $field: ". $self->getfield($field);
1765 $self->setfield($field,$1);
1769 =item ut_name COLUMN
1771 Check/untaint proper names; allows alphanumerics, spaces and the following
1772 punctuation: , . - '
1779 my( $self, $field ) = @_;
1780 $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
1781 or return gettext('illegal_name'). " $field: ". $self->getfield($field);
1782 $self->setfield($field,$1);
1788 Check/untaint zip codes.
1792 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
1795 my( $self, $field, $country ) = @_;
1797 if ( $country eq 'US' ) {
1799 $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
1800 or return gettext('illegal_zip'). " $field for country $country: ".
1801 $self->getfield($field);
1802 $self->setfield($field, $1);
1804 } elsif ( $country eq 'CA' ) {
1806 $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
1807 or return gettext('illegal_zip'). " $field for country $country: ".
1808 $self->getfield($field);
1809 $self->setfield($field, "$1 $2");
1813 if ( $self->getfield($field) =~ /^\s*$/
1814 && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
1817 $self->setfield($field,'');
1819 $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
1820 or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
1821 $self->setfield($field,$1);
1829 =item ut_country COLUMN
1831 Check/untaint country codes. Country names are changed to codes, if possible -
1832 see L<Locale::Country>.
1837 my( $self, $field ) = @_;
1838 unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
1839 if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
1840 && country2code($1) ) {
1841 $self->setfield($field,uc(country2code($1)));
1844 $self->getfield($field) =~ /^(\w\w)$/
1845 or return "Illegal (country) $field: ". $self->getfield($field);
1846 $self->setfield($field,uc($1));
1850 =item ut_anything COLUMN
1852 Untaints arbitrary data. Be careful.
1857 my( $self, $field ) = @_;
1858 $self->getfield($field) =~ /^(.*)$/s
1859 or return "Illegal $field: ". $self->getfield($field);
1860 $self->setfield($field,$1);
1864 =item ut_enum COLUMN CHOICES_ARRAYREF
1866 Check/untaint a column, supplying all possible choices, like the "enum" type.
1871 my( $self, $field, $choices ) = @_;
1872 foreach my $choice ( @$choices ) {
1873 if ( $self->getfield($field) eq $choice ) {
1874 $self->setfield($choice);
1878 return "Illegal (enum) field $field: ". $self->getfield($field);
1881 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
1883 Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
1884 on the column first.
1888 sub ut_foreign_key {
1889 my( $self, $field, $table, $foreign ) = @_;
1890 qsearchs($table, { $foreign => $self->getfield($field) })
1891 or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
1892 " in $table.$foreign";
1896 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
1898 Like ut_foreign_key, except the null value is also allowed.
1902 sub ut_foreign_keyn {
1903 my( $self, $field, $table, $foreign ) = @_;
1904 $self->getfield($field)
1905 ? $self->ut_foreign_key($field, $table, $foreign)
1909 =item ut_agentnum_acl
1911 Checks this column as an agentnum, taking into account the current users's
1916 sub ut_agentnum_acl {
1917 my( $self, $field, $null_acl ) = @_;
1919 my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
1920 return "Illegal agentnum: $error" if $error;
1922 my $curuser = $FS::CurrentUser::CurrentUser;
1924 if ( $self->$field() ) {
1926 return "Access deined"
1927 unless $curuser->agentnum($self->$field());
1931 return "Access denied"
1932 unless $curuser->access_right($null_acl);
1940 =item virtual_fields [ TABLE ]
1942 Returns a list of virtual fields defined for the table. This should not
1943 be exported, and should only be called as an instance or class method.
1947 sub virtual_fields {
1950 $table = $self->table or confess "virtual_fields called on non-table";
1952 confess "Unknown table $table" unless dbdef->table($table);
1954 return () unless dbdef->table('part_virtual_field');
1956 unless ( $virtual_fields_cache{$table} ) {
1957 my $query = 'SELECT name from part_virtual_field ' .
1958 "WHERE dbtable = '$table'";
1960 my $result = $dbh->selectcol_arrayref($query);
1961 confess "Error executing virtual fields query: $query: ". $dbh->errstr
1963 $virtual_fields_cache{$table} = $result;
1966 @{$virtual_fields_cache{$table}};
1971 =item fields [ TABLE ]
1973 This is a wrapper for real_fields and virtual_fields. Code that called
1974 fields before should probably continue to call fields.
1979 my $something = shift;
1981 if($something->isa('FS::Record')) {
1982 $table = $something->table;
1984 $table = $something;
1985 $something = "FS::$table";
1987 return (real_fields($table), $something->virtual_fields());
1990 =item pvf FIELD_NAME
1992 Returns the FS::part_virtual_field object corresponding to a field in the
1993 record (specified by FIELD_NAME).
1998 my ($self, $name) = (shift, shift);
2000 if(grep /^$name$/, $self->virtual_fields) {
2001 return qsearchs('part_virtual_field', { dbtable => $self->table,
2007 =item vfieldpart_hashref TABLE
2009 Returns a hashref of virtual field names and vfieldparts applicable to the given
2014 sub vfieldpart_hashref {
2016 my $table = $self->table;
2018 return {} unless dbdef->table('part_virtual_field');
2021 my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
2022 "dbtable = '$table'";
2023 my $sth = $dbh->prepare($statement);
2024 $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
2025 return { map { $_->{name}, $_->{vfieldpart} }
2026 @{$sth->fetchall_arrayref({})} };
2030 =item encrypt($value)
2032 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2034 Returns the encrypted string.
2036 You should generally not have to worry about calling this, as the system handles this for you.
2041 my ($self, $value) = @_;
2044 my $conf = new FS::Conf;
2045 if ($conf->exists('encryption')) {
2046 if ($self->is_encrypted($value)) {
2047 # Return the original value if it isn't plaintext.
2048 $encrypted = $value;
2051 if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2052 # RSA doesn't like the empty string so let's pack it up
2053 # The database doesn't like the RSA data so uuencode it
2054 my $length = length($value)+1;
2055 $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2057 die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2064 =item is_encrypted($value)
2066 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2072 my ($self, $value) = @_;
2073 # Possible Bug - Some work may be required here....
2075 if ($value =~ /^M/ && length($value) > 80) {
2082 =item decrypt($value)
2084 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2086 You should generally not have to worry about calling this, as the system handles this for you.
2091 my ($self,$value) = @_;
2092 my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2093 my $conf = new FS::Conf;
2094 if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2096 if (ref($rsa_decrypt) =~ /::RSA/) {
2097 my $encrypted = unpack ("u*", $value);
2098 $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2099 if ($@) {warn "Decryption Failed"};
2107 #Initialize the Module
2108 $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2110 my $conf = new FS::Conf;
2111 if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') {
2112 $rsa_module = $conf->config('encryptionmodule');
2116 eval ("require $rsa_module"); # No need to import the namespace
2119 # Initialize Encryption
2120 if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') {
2121 my $public_key = join("\n",$conf->config('encryptionpublickey'));
2122 $rsa_encrypt = $rsa_module->new_public_key($public_key);
2125 # Intitalize Decryption
2126 if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') {
2127 my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2128 $rsa_decrypt = $rsa_module->new_private_key($private_key);
2132 =item h_search ACTION
2134 Given an ACTION, either "insert", or "delete", returns the appropriate history
2135 record corresponding to this record, if any.
2140 my( $self, $action ) = @_;
2142 my $table = $self->table;
2145 my $primary_key = dbdef->table($table)->primary_key;
2148 'table' => "h_$table",
2149 'hashref' => { $primary_key => $self->$primary_key(),
2150 'history_action' => $action,
2158 Given an ACTION, either "insert", or "delete", returns the timestamp of the
2159 appropriate history record corresponding to this record, if any.
2164 my($self, $action) = @_;
2165 my $h = $self->h_search($action);
2166 $h ? $h->history_date : '';
2175 =item real_fields [ TABLE ]
2177 Returns a list of the real columns in the specified table. Called only by
2178 fields() and other subroutines elsewhere in FS::Record.
2185 my($table_obj) = dbdef->table($table);
2186 confess "Unknown table $table" unless $table_obj;
2187 $table_obj->columns;
2190 =item _quote VALUE, TABLE, COLUMN
2192 This is an internal function used to construct SQL statements. It returns
2193 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2194 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2199 my($value, $table, $column) = @_;
2200 my $column_obj = dbdef->table($table)->column($column);
2201 my $column_type = $column_obj->type;
2202 my $nullable = $column_obj->null;
2204 warn " $table.$column: $value ($column_type".
2205 ( $nullable ? ' NULL' : ' NOT NULL' ).
2206 ")\n" if $DEBUG > 2;
2208 if ( $value eq '' && $nullable ) {
2210 } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2211 cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2214 } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2215 ! $column_type =~ /(char|binary|text)$/i ) {
2224 This is deprecated. Don't use it.
2226 It returns a hash-type list with the fields of this record's table set true.
2231 carp "warning: hfields is deprecated";
2234 foreach (fields($table)) {
2243 "$_: ". $self->getfield($_). "|"
2244 } (fields($self->table)) );
2247 sub DESTROY { return; }
2251 # #use Carp qw(cluck);
2252 # #cluck "DESTROYING $self";
2253 # warn "DESTROYING $self";
2257 # return ! eval { join('',@_), kill 0; 1; };
2260 =item str2time_sql [ DRIVER_NAME ]
2262 Returns a function to convert to unix time based on database type, such as
2263 "EXTRACT( EPOCH FROM" for Pg or "UNIX_TIMESTAMP(" for mysql. See
2264 the str2time_sql_closing method to return a closing string rather than just
2265 using a closing parenthesis as previously suggested.
2267 You can pass an optional driver name such as "Pg", "mysql" or
2268 $dbh->{Driver}->{Name} to return a function for that database instead of
2269 the current database.
2274 my $driver = shift || driver_name;
2276 return 'UNIX_TIMESTAMP(' if $driver =~ /^mysql/i;
2277 return 'EXTRACT( EPOCH FROM ' if $driver =~ /^Pg/i;
2279 warn "warning: unknown database type $driver; guessing how to convert ".
2280 "dates to UNIX timestamps";
2281 return 'EXTRACT(EPOCH FROM ';
2285 =item str2time_sql_closing [ DRIVER_NAME ]
2287 Returns the closing suffix of a function to convert to unix time based on
2288 database type, such as ")::integer" for Pg or ")" for mysql.
2290 You can pass an optional driver name such as "Pg", "mysql" or
2291 $dbh->{Driver}->{Name} to return a function for that database instead of
2292 the current database.
2296 sub str2time_sql_closing {
2297 my $driver = shift || driver_name;
2299 return ' )::INTEGER ' if $driver =~ /^Pg/i;
2307 This module should probably be renamed, since much of the functionality is
2308 of general use. It is not completely unlike Adapter::DBI (see below).
2310 Exported qsearch and qsearchs should be deprecated in favor of method calls
2311 (against an FS::Record object like the old search and searchs that qsearch
2312 and qsearchs were on top of.)
2314 The whole fields / hfields mess should be removed.
2316 The various WHERE clauses should be subroutined.
2318 table string should be deprecated in favor of DBIx::DBSchema::Table.
2320 No doubt we could benefit from a Tied hash. Documenting how exists / defined
2321 true maps to the database (and WHERE clauses) would also help.
2323 The ut_ methods should ask the dbdef for a default length.
2325 ut_sqltype (like ut_varchar) should all be defined
2327 A fallback check method should be provided which uses the dbdef.
2329 The ut_money method assumes money has two decimal digits.
2331 The Pg money kludge in the new method only strips `$'.
2333 The ut_phonen method only checks US-style phone numbers.
2335 The _quote function should probably use ut_float instead of a regex.
2337 All the subroutines probably should be methods, here or elsewhere.
2339 Probably should borrow/use some dbdef methods where appropriate (like sub
2342 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
2343 or allow it to be set. Working around it is ugly any way around - DBI should
2344 be fixed. (only affects RDBMS which return uppercase column names)
2346 ut_zip should take an optional country like ut_phone.
2350 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
2352 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.