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.25;
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);
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 #'cache_obj' => '', #optional
215 'addl_from' => 'LEFT JOIN othtable USING ( field )',
219 Much code still uses old-style positional parameters, this is also probably
220 fine in the common case where there are only two parameters:
222 my @records = qsearch( 'table', { 'field' => 'value' } );
224 ###oops, argh, FS::Record::new only lets us create database fields.
225 #Normal behaviour if SELECT is not specified is `*', as in
226 #C<SELECT * FROM table WHERE ...>. However, there is an experimental new
227 #feature where you can specify SELECT - remember, the objects returned,
228 #although blessed into the appropriate `FS::TABLE' package, will only have the
229 #fields you specify. This might have unwanted results if you then go calling
230 #regular FS::TABLE methods
236 my($stable, $record, $select, $extra_sql, $cache, $addl_from );
237 if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too
239 $stable = $opt->{'table'} or die "table name is required";
240 $record = $opt->{'hashref'} || {};
241 $select = $opt->{'select'} || '*';
242 $extra_sql = $opt->{'extra_sql'} || '';
243 $cache = $opt->{'cache_obj'} || '';
244 $addl_from = $opt->{'addl_from'} || '';
246 ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_;
250 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
252 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
256 my $table = $cache ? $cache->table : $stable;
257 my $dbdef_table = dbdef->table($table)
258 or die "No schema for table $table found - ".
259 "do you need to run freeside-upgrade?";
260 my $pkey = $dbdef_table->primary_key;
262 my @real_fields = grep exists($record->{$_}), real_fields($table);
264 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
265 @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
267 cluck "warning: FS::$table not loaded; virtual fields not searchable";
268 @virtual_fields = ();
271 my $statement = "SELECT $select FROM $stable";
272 $statement .= " $addl_from" if $addl_from;
273 if ( @real_fields or @virtual_fields ) {
274 $statement .= ' WHERE '. join(' AND ',
279 if ( ref($record->{$_}) ) {
280 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
281 #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
282 if ( uc($op) eq 'ILIKE' ) {
284 $record->{$_}{'value'} = lc($record->{$_}{'value'});
285 $column = "LOWER($_)";
287 $record->{$_} = $record->{$_}{'value'}
290 if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
292 if ( driver_name eq 'Pg' ) {
293 my $type = dbdef->table($table)->column($column)->type;
294 if ( $type =~ /(int|(big)?serial)/i ) {
295 qq-( $column IS NULL )-;
297 qq-( $column IS NULL OR $column = '' )-;
300 qq-( $column IS NULL OR $column = "" )-;
302 } elsif ( $op eq '!=' ) {
303 if ( driver_name eq 'Pg' ) {
304 my $type = dbdef->table($table)->column($column)->type;
305 if ( $type =~ /(int|(big)?serial)/i ) {
306 qq-( $column IS NOT NULL )-;
308 qq-( $column IS NOT NULL AND $column != '' )-;
311 qq-( $column IS NOT NULL AND $column != "" )-;
314 if ( driver_name eq 'Pg' ) {
315 qq-( $column $op '' )-;
317 qq-( $column $op "" )-;
327 if ( ref($record->{$_}) ) {
328 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
329 if ( uc($op) eq 'ILIKE' ) {
331 $record->{$_}{'value'} = lc($record->{$_}{'value'});
332 $column = "LOWER($_)";
334 $record->{$_} = $record->{$_}{'value'};
337 # ... EXISTS ( SELECT name, value FROM part_virtual_field
339 # ON part_virtual_field.vfieldpart = virtual_field.vfieldpart
340 # WHERE recnum = svc_acct.svcnum
341 # AND (name, value) = ('egad', 'brain') )
343 my $value = $record->{$_};
347 $subq = ($value ? 'EXISTS ' : 'NOT EXISTS ') .
348 "( SELECT part_virtual_field.name, virtual_field.value ".
349 "FROM part_virtual_field JOIN virtual_field ".
350 "ON part_virtual_field.vfieldpart = virtual_field.vfieldpart ".
351 "WHERE virtual_field.recnum = ${table}.${pkey} ".
352 "AND part_virtual_field.name = '${column}'".
354 " AND virtual_field.value ${op} '${value}'"
358 } @virtual_fields ) );
362 $statement .= " $extra_sql" if defined($extra_sql);
364 warn "[debug]$me $statement\n" if $DEBUG > 1;
365 my $sth = $dbh->prepare($statement)
366 or croak "$dbh->errstr doing $statement";
371 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
373 if ( $record->{$field} =~ /^\d+(\.\d+)?$/
374 && dbdef->table($table)->column($field)->type =~ /(int|(big)?serial)/i
376 $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } );
378 $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_VARCHAR } );
382 # $sth->execute( map $record->{$_},
383 # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
384 # ) or croak "Error executing \"$statement\": ". $sth->errstr;
386 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
388 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
389 @virtual_fields = "FS::$table"->virtual_fields;
391 cluck "warning: FS::$table not loaded; virtual fields not returned either";
392 @virtual_fields = ();
396 tie %result, "Tie::IxHash";
397 my @stuff = @{ $sth->fetchall_arrayref( {} ) };
398 if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
399 %result = map { $_->{$pkey}, $_ } @stuff;
401 @result{@stuff} = @stuff;
406 if ( keys(%result) and @virtual_fields ) {
408 "SELECT virtual_field.recnum, part_virtual_field.name, ".
409 "virtual_field.value ".
410 "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ".
411 "WHERE part_virtual_field.dbtable = '$table' AND ".
412 "virtual_field.recnum IN (".
413 join(',', keys(%result)). ") AND part_virtual_field.name IN ('".
414 join(q!', '!, @virtual_fields) . "')";
415 warn "[debug]$me $statement\n" if $DEBUG > 1;
416 $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement";
417 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
419 foreach (@{ $sth->fetchall_arrayref({}) }) {
420 my $recnum = $_->{recnum};
421 my $name = $_->{name};
422 my $value = $_->{value};
423 if (exists($result{$recnum})) {
424 $result{$recnum}->{$name} = $value;
429 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
430 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
431 #derivied class didn't override new method, so this optimization is safe
434 new_or_cached( "FS::$table", { %{$_} }, $cache )
438 new( "FS::$table", { %{$_} } )
442 #okay, its been tested
443 # warn "untested code (class FS::$table uses custom new method)";
445 eval 'FS::'. $table. '->new( { %{$_} } )';
449 # Check for encrypted fields and decrypt them.
450 ## only in the local copy, not the cached object
451 if ( $conf && $conf->exists('encryption') # $conf doesn't exist when doing
452 # the initial search for
454 && eval 'defined(@FS::'. $table . '::encrypted_fields)') {
455 foreach my $record (@return) {
456 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
457 # Set it directly... This may cause a problem in the future...
458 $record->setfield($field, $record->decrypt($record->getfield($field)));
463 cluck "warning: FS::$table not loaded; returning FS::Record objects";
465 FS::Record->new( $table, { %{$_} } );
471 =item by_key PRIMARY_KEY_VALUE
473 This is a class method that returns the record with the given primary key
474 value. This method is only useful in FS::Record subclasses. For example:
476 my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
480 my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
485 my ($class, $pkey_value) = @_;
487 my $table = $class->table
488 or croak "No table for $class found";
490 my $dbdef_table = dbdef->table($table)
491 or die "No schema for table $table found - ".
492 "do you need to create it or run dbdef-create?";
493 my $pkey = $dbdef_table->primary_key
494 or die "No primary key for table $table";
496 return qsearchs($table, { $pkey => $pkey_value });
499 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
501 Experimental JOINed search method. Using this method, you can execute a
502 single SELECT spanning multiple tables, and cache the results for subsequent
503 method calls. Interface will almost definately change in an incompatible
511 my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
512 my $cache = FS::SearchCache->new( $ptable, $pkey );
515 grep { !$saw{$_->getfield($pkey)}++ }
516 qsearch($table, $record, $select, $extra_sql, $cache )
520 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
522 Same as qsearch, except that if more than one record matches, it B<carp>s but
523 returns the first. If this happens, you either made a logic error in asking
524 for a single item, or your data is corrupted.
528 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
530 my(@result) = qsearch(@_);
531 cluck "warning: Multiple records in scalar search ($table)"
532 if scalar(@result) > 1;
533 #should warn more vehemently if the search was on a primary key?
534 scalar(@result) ? ($result[0]) : ();
545 Returns the table name.
550 # cluck "warning: FS::Record::table deprecated; supply one in subclass!";
557 Returns the DBIx::DBSchema::Table object for the table.
563 my($table)=$self->table;
564 dbdef->table($table);
569 Returns the primary key for the table.
575 my $pkey = $self->dbdef_table->primary_key;
578 =item get, getfield COLUMN
580 Returns the value of the column/field/key COLUMN.
585 my($self,$field) = @_;
586 # to avoid "Use of unitialized value" errors
587 if ( defined ( $self->{Hash}->{$field} ) ) {
588 $self->{Hash}->{$field};
598 =item set, setfield COLUMN, VALUE
600 Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE.
605 my($self,$field,$value) = @_;
606 $self->{'modified'} = 1;
607 $self->{'Hash'}->{$field} = $value;
614 =item AUTLOADED METHODS
616 $record->column is a synonym for $record->get('column');
618 $record->column('value') is a synonym for $record->set('column','value');
625 my($field)=$AUTOLOAD;
627 if ( defined($value) ) {
628 confess "errant AUTOLOAD $field for $self (arg $value)"
629 unless ref($self) && $self->can('setfield');
630 $self->setfield($field,$value);
632 confess "errant AUTOLOAD $field for $self (no args)"
633 unless ref($self) && $self->can('getfield');
634 $self->getfield($field);
640 # my $field = $AUTOLOAD;
642 # if ( defined($_[1]) ) {
643 # $_[0]->setfield($field, $_[1]);
645 # $_[0]->getfield($field);
651 Returns a list of the column/value pairs, usually for assigning to a new hash.
653 To make a distinct duplicate of an FS::Record object, you can do:
655 $new = new FS::Record ( $old->table, { $old->hash } );
661 confess $self. ' -> hash: Hash attribute is undefined'
662 unless defined($self->{'Hash'});
663 %{ $self->{'Hash'} };
668 Returns a reference to the column/value hash. This may be deprecated in the
669 future; if there's a reason you can't just use the autoloaded or get/set
681 Returns true if any of this object's values have been modified with set (or via
682 an autoloaded method). Doesn't yet recognize when you retreive a hashref and
692 =item select_for_update
694 Selects this record with the SQL "FOR UPDATE" command. This can be useful as
699 sub select_for_update {
701 my $primary_key = $self->primary_key;
704 'table' => $self->table,
705 'hashref' => { $primary_key => $self->$primary_key() },
706 'extra_sql' => 'FOR UPDATE',
712 Inserts this record to the database. If there is an error, returns the error,
713 otherwise returns false.
721 warn "$self -> insert" if $DEBUG;
723 my $error = $self->check;
724 return $error if $error;
726 #single-field unique keys are given a value if false
727 #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
728 foreach ( $self->dbdef_table->unique->singles ) {
729 $self->unique($_) unless $self->getfield($_);
732 #and also the primary key, if the database isn't going to
733 my $primary_key = $self->dbdef_table->primary_key;
735 if ( $primary_key ) {
736 my $col = $self->dbdef_table->column($primary_key);
739 uc($col->type) =~ /^(BIG)?SERIAL\d?/
740 || ( driver_name eq 'Pg'
741 && defined($col->default)
742 && $col->default =~ /^nextval\(/i
744 || ( driver_name eq 'mysql'
745 && defined($col->local)
746 && $col->local =~ /AUTO_INCREMENT/i
748 $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
751 my $table = $self->table;
754 # Encrypt before the database
755 if ($conf->exists('encryption') && defined(eval '@FS::'. $table . '::encrypted_fields')) {
756 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
757 $self->{'saved'} = $self->getfield($field);
758 $self->setfield($field, $self->encrypt($self->getfield($field)));
763 #false laziness w/delete
765 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
768 my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
771 my $statement = "INSERT INTO $table ";
772 if ( @real_fields ) {
775 join( ', ', @real_fields ).
777 join( ', ', @values ).
781 $statement .= 'DEFAULT VALUES';
783 warn "[debug]$me $statement\n" if $DEBUG > 1;
784 my $sth = dbh->prepare($statement) or return dbh->errstr;
786 local $SIG{HUP} = 'IGNORE';
787 local $SIG{INT} = 'IGNORE';
788 local $SIG{QUIT} = 'IGNORE';
789 local $SIG{TERM} = 'IGNORE';
790 local $SIG{TSTP} = 'IGNORE';
791 local $SIG{PIPE} = 'IGNORE';
793 $sth->execute or return $sth->errstr;
795 # get inserted id from the database, if applicable & needed
796 if ( $db_seq && ! $self->getfield($primary_key) ) {
797 warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
801 if ( driver_name eq 'Pg' ) {
803 #my $oid = $sth->{'pg_oid_status'};
804 #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
806 my $default = $self->dbdef_table->column($primary_key)->default;
807 unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
808 dbh->rollback if $FS::UID::AutoCommit;
809 return "can't parse $table.$primary_key default value".
810 " for sequence name: $default";
814 my $i_sql = "SELECT currval('$sequence')";
815 my $i_sth = dbh->prepare($i_sql) or do {
816 dbh->rollback if $FS::UID::AutoCommit;
819 $i_sth->execute() or do { #$i_sth->execute($oid)
820 dbh->rollback if $FS::UID::AutoCommit;
821 return $i_sth->errstr;
823 $insertid = $i_sth->fetchrow_arrayref->[0];
825 } elsif ( driver_name eq 'mysql' ) {
827 $insertid = dbh->{'mysql_insertid'};
828 # work around mysql_insertid being null some of the time, ala RT :/
829 unless ( $insertid ) {
830 warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
831 "using SELECT LAST_INSERT_ID();";
832 my $i_sql = "SELECT LAST_INSERT_ID()";
833 my $i_sth = dbh->prepare($i_sql) or do {
834 dbh->rollback if $FS::UID::AutoCommit;
837 $i_sth->execute or do {
838 dbh->rollback if $FS::UID::AutoCommit;
839 return $i_sth->errstr;
841 $insertid = $i_sth->fetchrow_arrayref->[0];
846 dbh->rollback if $FS::UID::AutoCommit;
847 return "don't know how to retreive inserted ids from ". driver_name.
848 ", try using counterfiles (maybe run dbdef-create?)";
852 $self->setfield($primary_key, $insertid);
857 grep defined($self->getfield($_)) && $self->getfield($_) ne "",
858 $self->virtual_fields;
859 if (@virtual_fields) {
860 my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
862 my $vfieldpart = $self->vfieldpart_hashref;
864 my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
867 my $v_sth = dbh->prepare($v_statement) or do {
868 dbh->rollback if $FS::UID::AutoCommit;
872 foreach (keys(%v_values)) {
873 $v_sth->execute($self->getfield($primary_key),
877 dbh->rollback if $FS::UID::AutoCommit;
878 return $v_sth->errstr;
885 if ( defined dbdef->table('h_'. $table) ) {
886 my $h_statement = $self->_h_statement('insert');
887 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
888 $h_sth = dbh->prepare($h_statement) or do {
889 dbh->rollback if $FS::UID::AutoCommit;
895 $h_sth->execute or return $h_sth->errstr if $h_sth;
897 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
899 # Now that it has been saved, reset the encrypted fields so that $new
901 foreach my $field (keys %{$saved}) {
902 $self->setfield($field, $saved->{$field});
910 Depriciated (use insert instead).
915 cluck "warning: FS::Record::add deprecated!";
916 insert @_; #call method in this scope
921 Delete this record from the database. If there is an error, returns the error,
922 otherwise returns false.
929 my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
931 $self->getfield($_) eq ''
932 #? "( $_ IS NULL OR $_ = \"\" )"
933 ? ( driver_name eq 'Pg'
935 : "( $_ IS NULL OR $_ = \"\" )"
937 : "$_ = ". _quote($self->getfield($_),$self->table,$_)
938 } ( $self->dbdef_table->primary_key )
939 ? ( $self->dbdef_table->primary_key)
940 : real_fields($self->table)
942 warn "[debug]$me $statement\n" if $DEBUG > 1;
943 my $sth = dbh->prepare($statement) or return dbh->errstr;
946 if ( defined dbdef->table('h_'. $self->table) ) {
947 my $h_statement = $self->_h_statement('delete');
948 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
949 $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
954 my $primary_key = $self->dbdef_table->primary_key;
957 my $vfp = $self->vfieldpart_hashref;
958 foreach($self->virtual_fields) {
959 next if $self->getfield($_) eq '';
960 unless(@del_vfields) {
961 my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
962 $v_sth = dbh->prepare($st) or return dbh->errstr;
964 push @del_vfields, $_;
967 local $SIG{HUP} = 'IGNORE';
968 local $SIG{INT} = 'IGNORE';
969 local $SIG{QUIT} = 'IGNORE';
970 local $SIG{TERM} = 'IGNORE';
971 local $SIG{TSTP} = 'IGNORE';
972 local $SIG{PIPE} = 'IGNORE';
974 my $rc = $sth->execute or return $sth->errstr;
975 #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
976 $h_sth->execute or return $h_sth->errstr if $h_sth;
977 $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
978 or return $v_sth->errstr
979 foreach (@del_vfields);
981 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
983 #no need to needlessly destoy the data either (causes problems actually)
984 #undef $self; #no need to keep object!
991 Depriciated (use delete instead).
996 cluck "warning: FS::Record::del deprecated!";
997 &delete(@_); #call method in this scope
1000 =item replace OLD_RECORD
1002 Replace the OLD_RECORD with this one in the database. If there is an error,
1003 returns the error, otherwise returns false.
1008 my ($new, $old) = (shift, shift);
1010 $old = $new->replace_old unless defined($old);
1012 warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1014 if ( $new->can('replace_check') ) {
1015 my $error = $new->replace_check($old);
1016 return $error if $error;
1019 return "Records not in same table!" unless $new->table eq $old->table;
1021 my $primary_key = $old->dbdef_table->primary_key;
1022 return "Can't change primary key $primary_key ".
1023 'from '. $old->getfield($primary_key).
1024 ' to ' . $new->getfield($primary_key)
1026 && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1028 my $error = $new->check;
1029 return $error if $error;
1031 # Encrypt for replace
1032 my $conf = new FS::Conf;
1034 if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) {
1035 foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1036 $saved->{$field} = $new->getfield($field);
1037 $new->setfield($field, $new->encrypt($new->getfield($field)));
1041 #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1042 my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1043 ? ($_, $new->getfield($_)) : () } $old->fields;
1045 unless (keys(%diff) || $no_update_diff ) {
1046 carp "[warning]$me $new -> replace $old: records identical"
1047 unless $nowarn_identical;
1051 my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1053 "$_ = ". _quote($new->getfield($_),$old->table,$_)
1054 } real_fields($old->table)
1059 if ( $old->getfield($_) eq '' ) {
1061 #false laziness w/qsearch
1062 if ( driver_name eq 'Pg' ) {
1063 my $type = $old->dbdef_table->column($_)->type;
1064 if ( $type =~ /(int|(big)?serial)/i ) {
1067 qq-( $_ IS NULL OR $_ = '' )-;
1070 qq-( $_ IS NULL OR $_ = "" )-;
1074 "$_ = ". _quote($old->getfield($_),$old->table,$_);
1077 } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1080 warn "[debug]$me $statement\n" if $DEBUG > 1;
1081 my $sth = dbh->prepare($statement) or return dbh->errstr;
1084 if ( defined dbdef->table('h_'. $old->table) ) {
1085 my $h_old_statement = $old->_h_statement('replace_old');
1086 warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1087 $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1093 if ( defined dbdef->table('h_'. $new->table) ) {
1094 my $h_new_statement = $new->_h_statement('replace_new');
1095 warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1096 $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1101 # For virtual fields we have three cases with different SQL
1102 # statements: add, replace, delete
1106 my (@add_vfields, @rep_vfields, @del_vfields);
1107 my $vfp = $old->vfieldpart_hashref;
1108 foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
1109 if($diff{$_} eq '') {
1111 unless(@del_vfields) {
1112 my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
1113 "AND vfieldpart = ?";
1114 warn "[debug]$me $st\n" if $DEBUG > 2;
1115 $v_del_sth = dbh->prepare($st) or return dbh->errstr;
1117 push @del_vfields, $_;
1118 } elsif($old->getfield($_) eq '') {
1120 unless(@add_vfields) {
1121 my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
1123 warn "[debug]$me $st\n" if $DEBUG > 2;
1124 $v_add_sth = dbh->prepare($st) or return dbh->errstr;
1126 push @add_vfields, $_;
1129 unless(@rep_vfields) {
1130 my $st = "UPDATE virtual_field SET value = ? ".
1131 "WHERE recnum = ? AND vfieldpart = ?";
1132 warn "[debug]$me $st\n" if $DEBUG > 2;
1133 $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
1135 push @rep_vfields, $_;
1139 local $SIG{HUP} = 'IGNORE';
1140 local $SIG{INT} = 'IGNORE';
1141 local $SIG{QUIT} = 'IGNORE';
1142 local $SIG{TERM} = 'IGNORE';
1143 local $SIG{TSTP} = 'IGNORE';
1144 local $SIG{PIPE} = 'IGNORE';
1146 my $rc = $sth->execute or return $sth->errstr;
1147 #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1148 $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1149 $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1151 $v_del_sth->execute($old->getfield($primary_key),
1153 or return $v_del_sth->errstr
1154 foreach(@del_vfields);
1156 $v_add_sth->execute($new->getfield($_),
1157 $old->getfield($primary_key),
1159 or return $v_add_sth->errstr
1160 foreach(@add_vfields);
1162 $v_rep_sth->execute($new->getfield($_),
1163 $old->getfield($primary_key),
1165 or return $v_rep_sth->errstr
1166 foreach(@rep_vfields);
1168 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1170 # Now that it has been saved, reset the encrypted fields so that $new
1171 # can still be used.
1172 foreach my $field (keys %{$saved}) {
1173 $new->setfield($field, $saved->{$field});
1181 my( $self ) = shift;
1182 warn "[$me] replace called with no arguments; autoloading old record\n"
1185 my $primary_key = $self->dbdef_table->primary_key;
1186 if ( $primary_key ) {
1187 $self->by_key( $self->$primary_key() ) #this is what's returned
1188 or croak "can't find ". $self->table. ".$primary_key ".
1189 $self->$primary_key();
1191 croak $self->table. " has no primary key; pass old record as argument";
1198 Depriciated (use replace instead).
1203 cluck "warning: FS::Record::rep deprecated!";
1204 replace @_; #call method in this scope
1209 Checks virtual fields (using check_blocks). Subclasses should still provide
1210 a check method to validate real fields, foreign keys, etc., and call this
1211 method via $self->SUPER::check.
1213 (FIXME: Should this method try to make sure that it I<is> being called from
1214 a subclass's check method, to keep the current semantics as far as possible?)
1219 #confess "FS::Record::check not implemented; supply one in subclass!";
1222 foreach my $field ($self->virtual_fields) {
1223 for ($self->getfield($field)) {
1224 # See notes on check_block in FS::part_virtual_field.
1225 eval $self->pvf($field)->check_block;
1227 #this is bad, probably want to follow the stack backtrace up and see
1229 my $err = "Fatal error checking $field for $self";
1231 return "$err (see log for backtrace): $@";
1234 $self->setfield($field, $_);
1241 my( $self, $action, $time ) = @_;
1246 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1247 real_fields($self->table);
1250 # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1251 # You can see if it changed by the paymask...
1252 if ($conf->exists('encryption') ) {
1253 @fields = grep $_ ne 'payinfo' && $_ ne 'cvv2', @fields;
1255 my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1257 "INSERT INTO h_". $self->table. " ( ".
1258 join(', ', qw(history_date history_user history_action), @fields ).
1260 join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1267 B<Warning>: External use is B<deprecated>.
1269 Replaces COLUMN in record with a unique number, using counters in the
1270 filesystem. Used by the B<insert> method on single-field unique columns
1271 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1272 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1274 Returns the new value.
1279 my($self,$field) = @_;
1280 my($table)=$self->table;
1282 croak "Unique called on field $field, but it is ",
1283 $self->getfield($field),
1285 if $self->getfield($field);
1287 #warn "table $table is tainted" if is_tainted($table);
1288 #warn "field $field is tainted" if is_tainted($field);
1290 my($counter) = new File::CounterFile "$table.$field",0;
1292 # getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1294 # my($counter) = new File::CounterFile "$user/$table.$field",0;
1297 my $index = $counter->inc;
1298 $index = $counter->inc while qsearchs($table, { $field=>$index } );
1300 $index =~ /^(\d*)$/;
1303 $self->setfield($field,$index);
1307 =item ut_float COLUMN
1309 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be
1310 null. If there is an error, returns the error, otherwise returns false.
1315 my($self,$field)=@_ ;
1316 ($self->getfield($field) =~ /^(\d+\.\d+)$/ ||
1317 $self->getfield($field) =~ /^(\d+)$/ ||
1318 $self->getfield($field) =~ /^(\d+\.\d+e\d+)$/ ||
1319 $self->getfield($field) =~ /^(\d+e\d+)$/)
1320 or return "Illegal or empty (float) $field: ". $self->getfield($field);
1321 $self->setfield($field,$1);
1324 =item ut_floatn COLUMN
1326 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
1327 null. If there is an error, returns the error, otherwise returns false.
1331 #false laziness w/ut_ipn
1333 my( $self, $field ) = @_;
1334 if ( $self->getfield($field) =~ /^()$/ ) {
1335 $self->setfield($field,'');
1338 $self->ut_float($field);
1342 =item ut_sfloat COLUMN
1344 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1345 May not be null. If there is an error, returns the error, otherwise returns
1351 my($self,$field)=@_ ;
1352 ($self->getfield($field) =~ /^(-?\d+\.\d+)$/ ||
1353 $self->getfield($field) =~ /^(-?\d+)$/ ||
1354 $self->getfield($field) =~ /^(-?\d+\.\d+[eE]-?\d+)$/ ||
1355 $self->getfield($field) =~ /^(-?\d+[eE]-?\d+)$/)
1356 or return "Illegal or empty (float) $field: ". $self->getfield($field);
1357 $self->setfield($field,$1);
1360 =item ut_sfloatn COLUMN
1362 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
1363 null. If there is an error, returns the error, otherwise returns false.
1368 my( $self, $field ) = @_;
1369 if ( $self->getfield($field) =~ /^()$/ ) {
1370 $self->setfield($field,'');
1373 $self->ut_sfloat($field);
1377 =item ut_snumber COLUMN
1379 Check/untaint signed numeric data (whole numbers). If there is an error,
1380 returns the error, otherwise returns false.
1385 my($self, $field) = @_;
1386 $self->getfield($field) =~ /^(-?)\s*(\d+)$/
1387 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1388 $self->setfield($field, "$1$2");
1392 =item ut_snumbern COLUMN
1394 Check/untaint signed numeric data (whole numbers). If there is an error,
1395 returns the error, otherwise returns false.
1400 my($self, $field) = @_;
1401 $self->getfield($field) =~ /^(-?)\s*(\d*)$/
1402 or return "Illegal (numeric) $field: ". $self->getfield($field);
1404 return "Illegal (numeric) $field: ". $self->getfield($field)
1407 $self->setfield($field, "$1$2");
1411 =item ut_number COLUMN
1413 Check/untaint simple numeric data (whole numbers). May not be null. If there
1414 is an error, returns the error, otherwise returns false.
1419 my($self,$field)=@_;
1420 $self->getfield($field) =~ /^(\d+)$/
1421 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1422 $self->setfield($field,$1);
1426 =item ut_numbern COLUMN
1428 Check/untaint simple numeric data (whole numbers). May be null. If there is
1429 an error, returns the error, otherwise returns false.
1434 my($self,$field)=@_;
1435 $self->getfield($field) =~ /^(\d*)$/
1436 or return "Illegal (numeric) $field: ". $self->getfield($field);
1437 $self->setfield($field,$1);
1441 =item ut_money COLUMN
1443 Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
1444 is an error, returns the error, otherwise returns false.
1449 my($self,$field)=@_;
1450 $self->setfield($field, 0) if $self->getfield($field) eq '';
1451 $self->getfield($field) =~ /^(\-)? ?(\d*)(\.\d{2})?$/
1452 or return "Illegal (money) $field: ". $self->getfield($field);
1453 #$self->setfield($field, "$1$2$3" || 0);
1454 $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
1458 =item ut_text COLUMN
1460 Check/untaint text. Alphanumerics, spaces, and the following punctuation
1461 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ]
1462 May not be null. If there is an error, returns the error, otherwise returns
1468 my($self,$field)=@_;
1469 #warn "msgcat ". \&msgcat. "\n";
1470 #warn "notexist ". \¬exist. "\n";
1471 #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
1472 $self->getfield($field)
1473 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/
1474 or return gettext('illegal_or_empty_text'). " $field: ".
1475 $self->getfield($field);
1476 $self->setfield($field,$1);
1480 =item ut_textn COLUMN
1482 Check/untaint text. Alphanumerics, spaces, and the following punctuation
1483 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
1484 May be null. If there is an error, returns the error, otherwise returns false.
1489 my($self,$field)=@_;
1490 $self->getfield($field)
1491 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/
1492 or return gettext('illegal_text'). " $field: ". $self->getfield($field);
1493 $self->setfield($field,$1);
1497 =item ut_alpha COLUMN
1499 Check/untaint alphanumeric strings (no spaces). May not be null. If there is
1500 an error, returns the error, otherwise returns false.
1505 my($self,$field)=@_;
1506 $self->getfield($field) =~ /^(\w+)$/
1507 or return "Illegal or empty (alphanumeric) $field: ".
1508 $self->getfield($field);
1509 $self->setfield($field,$1);
1513 =item ut_alpha COLUMN
1515 Check/untaint alphanumeric strings (no spaces). May be null. If there is an
1516 error, returns the error, otherwise returns false.
1521 my($self,$field)=@_;
1522 $self->getfield($field) =~ /^(\w*)$/
1523 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
1524 $self->setfield($field,$1);
1528 =item ut_phonen COLUMN [ COUNTRY ]
1530 Check/untaint phone numbers. May be null. If there is an error, returns
1531 the error, otherwise returns false.
1533 Takes an optional two-letter ISO country code; without it or with unsupported
1534 countries, ut_phonen simply calls ut_alphan.
1539 my( $self, $field, $country ) = @_;
1540 return $self->ut_alphan($field) unless defined $country;
1541 my $phonen = $self->getfield($field);
1542 if ( $phonen eq '' ) {
1543 $self->setfield($field,'');
1544 } elsif ( $country eq 'US' || $country eq 'CA' ) {
1546 $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
1547 or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
1548 $phonen = "$1-$2-$3";
1549 $phonen .= " x$4" if $4;
1550 $self->setfield($field,$phonen);
1552 warn "warning: don't know how to check phone numbers for country $country";
1553 return $self->ut_textn($field);
1560 Check/untaint hexadecimal values.
1565 my($self, $field) = @_;
1566 $self->getfield($field) =~ /^([\da-fA-F]+)$/
1567 or return "Illegal (hex) $field: ". $self->getfield($field);
1568 $self->setfield($field, uc($1));
1572 =item ut_hexn COLUMN
1574 Check/untaint hexadecimal values. May be null.
1579 my($self, $field) = @_;
1580 $self->getfield($field) =~ /^([\da-fA-F]*)$/
1581 or return "Illegal (hex) $field: ". $self->getfield($field);
1582 $self->setfield($field, uc($1));
1587 Check/untaint ip addresses. IPv4 only for now.
1592 my( $self, $field ) = @_;
1593 $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
1594 or return "Illegal (IP address) $field: ". $self->getfield($field);
1595 for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
1596 $self->setfield($field, "$1.$2.$3.$4");
1602 Check/untaint ip addresses. IPv4 only for now. May be null.
1607 my( $self, $field ) = @_;
1608 if ( $self->getfield($field) =~ /^()$/ ) {
1609 $self->setfield($field,'');
1612 $self->ut_ip($field);
1616 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
1618 Check/untaint coordinates.
1619 Accepts the following forms:
1629 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
1630 The latter form (that is, the MMM are thousands of minutes) is
1631 assumed if the "MMM" is exactly three digits or two digits > 59.
1633 To be safe, just use the DDD.DDDDD form.
1635 If LOWER or UPPER are specified, then the coordinate is checked
1636 for lower and upper bounds, respectively.
1642 my ($self, $field) = (shift, shift);
1644 my $lower = shift if scalar(@_);
1645 my $upper = shift if scalar(@_);
1646 my $coord = $self->getfield($field);
1647 my $neg = $coord =~ s/^(-)//;
1649 my ($d, $m, $s) = (0, 0, 0);
1652 (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
1653 (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
1654 (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
1656 $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
1659 return "Invalid (coordinate with minutes > 59) $field: "
1660 . $self->getfield($field);
1663 $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
1665 if (defined($lower) and ($coord < $lower)) {
1666 return "Invalid (coordinate < $lower) $field: "
1667 . $self->getfield($field);;
1670 if (defined($upper) and ($coord > $upper)) {
1671 return "Invalid (coordinate > $upper) $field: "
1672 . $self->getfield($field);;
1675 $self->setfield($field, $coord);
1679 return "Invalid (coordinate) $field: " . $self->getfield($field);
1683 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
1685 Same as ut_coord, except optionally null.
1691 my ($self, $field) = (shift, shift);
1693 if ($self->getfield($field) =~ /^$/) {
1696 return $self->ut_coord($field, @_);
1702 =item ut_domain COLUMN
1704 Check/untaint host and domain names.
1709 my( $self, $field ) = @_;
1710 #$self->getfield($field) =~/^(\w+\.)*\w+$/
1711 $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
1712 or return "Illegal (domain) $field: ". $self->getfield($field);
1713 $self->setfield($field,$1);
1717 =item ut_name COLUMN
1719 Check/untaint proper names; allows alphanumerics, spaces and the following
1720 punctuation: , . - '
1727 my( $self, $field ) = @_;
1728 $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
1729 or return gettext('illegal_name'). " $field: ". $self->getfield($field);
1730 $self->setfield($field,$1);
1736 Check/untaint zip codes.
1740 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
1743 my( $self, $field, $country ) = @_;
1745 if ( $country eq 'US' ) {
1747 $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
1748 or return gettext('illegal_zip'). " $field for country $country: ".
1749 $self->getfield($field);
1750 $self->setfield($field, $1);
1752 } elsif ( $country eq 'CA' ) {
1754 $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
1755 or return gettext('illegal_zip'). " $field for country $country: ".
1756 $self->getfield($field);
1757 $self->setfield($field, "$1 $2");
1761 if ( $self->getfield($field) =~ /^\s*$/
1762 && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
1765 $self->setfield($field,'');
1767 $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
1768 or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
1769 $self->setfield($field,$1);
1777 =item ut_country COLUMN
1779 Check/untaint country codes. Country names are changed to codes, if possible -
1780 see L<Locale::Country>.
1785 my( $self, $field ) = @_;
1786 unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
1787 if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
1788 && country2code($1) ) {
1789 $self->setfield($field,uc(country2code($1)));
1792 $self->getfield($field) =~ /^(\w\w)$/
1793 or return "Illegal (country) $field: ". $self->getfield($field);
1794 $self->setfield($field,uc($1));
1798 =item ut_anything COLUMN
1800 Untaints arbitrary data. Be careful.
1805 my( $self, $field ) = @_;
1806 $self->getfield($field) =~ /^(.*)$/s
1807 or return "Illegal $field: ". $self->getfield($field);
1808 $self->setfield($field,$1);
1812 =item ut_enum COLUMN CHOICES_ARRAYREF
1814 Check/untaint a column, supplying all possible choices, like the "enum" type.
1819 my( $self, $field, $choices ) = @_;
1820 foreach my $choice ( @$choices ) {
1821 if ( $self->getfield($field) eq $choice ) {
1822 $self->setfield($choice);
1826 return "Illegal (enum) field $field: ". $self->getfield($field);
1829 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
1831 Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
1832 on the column first.
1836 sub ut_foreign_key {
1837 my( $self, $field, $table, $foreign ) = @_;
1838 qsearchs($table, { $foreign => $self->getfield($field) })
1839 or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
1840 " in $table.$foreign";
1844 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
1846 Like ut_foreign_key, except the null value is also allowed.
1850 sub ut_foreign_keyn {
1851 my( $self, $field, $table, $foreign ) = @_;
1852 $self->getfield($field)
1853 ? $self->ut_foreign_key($field, $table, $foreign)
1857 =item ut_agentnum_acl
1859 Checks this column as an agentnum, taking into account the current users's
1864 sub ut_agentnum_acl {
1865 my( $self, $field, $null_acl ) = @_;
1867 my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
1868 return "Illegal agentnum: $error" if $error;
1870 my $curuser = $FS::CurrentUser::CurrentUser;
1872 if ( $self->$field() ) {
1874 return "Access deined"
1875 unless $curuser->agentnum($self->$field());
1879 return "Access denied"
1880 unless $curuser->access_right($null_acl);
1888 =item virtual_fields [ TABLE ]
1890 Returns a list of virtual fields defined for the table. This should not
1891 be exported, and should only be called as an instance or class method.
1895 sub virtual_fields {
1898 $table = $self->table or confess "virtual_fields called on non-table";
1900 confess "Unknown table $table" unless dbdef->table($table);
1902 return () unless dbdef->table('part_virtual_field');
1904 unless ( $virtual_fields_cache{$table} ) {
1905 my $query = 'SELECT name from part_virtual_field ' .
1906 "WHERE dbtable = '$table'";
1908 my $result = $dbh->selectcol_arrayref($query);
1909 confess "Error executing virtual fields query: $query: ". $dbh->errstr
1911 $virtual_fields_cache{$table} = $result;
1914 @{$virtual_fields_cache{$table}};
1919 =item fields [ TABLE ]
1921 This is a wrapper for real_fields and virtual_fields. Code that called
1922 fields before should probably continue to call fields.
1927 my $something = shift;
1929 if($something->isa('FS::Record')) {
1930 $table = $something->table;
1932 $table = $something;
1933 $something = "FS::$table";
1935 return (real_fields($table), $something->virtual_fields());
1940 =item pvf FIELD_NAME
1942 Returns the FS::part_virtual_field object corresponding to a field in the
1943 record (specified by FIELD_NAME).
1948 my ($self, $name) = (shift, shift);
1950 if(grep /^$name$/, $self->virtual_fields) {
1951 return qsearchs('part_virtual_field', { dbtable => $self->table,
1961 =item real_fields [ TABLE ]
1963 Returns a list of the real columns in the specified table. Called only by
1964 fields() and other subroutines elsewhere in FS::Record.
1971 my($table_obj) = dbdef->table($table);
1972 confess "Unknown table $table" unless $table_obj;
1973 $table_obj->columns;
1976 =item _quote VALUE, TABLE, COLUMN
1978 This is an internal function used to construct SQL statements. It returns
1979 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
1980 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
1985 my($value, $table, $column) = @_;
1986 my $column_obj = dbdef->table($table)->column($column);
1987 my $column_type = $column_obj->type;
1988 my $nullable = $column_obj->null;
1990 warn " $table.$column: $value ($column_type".
1991 ( $nullable ? ' NULL' : ' NOT NULL' ).
1992 ")\n" if $DEBUG > 2;
1994 if ( $value eq '' && $nullable ) {
1996 } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
1997 cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2000 } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2001 ! $column_type =~ /(char|binary|text)$/i ) {
2008 =item vfieldpart_hashref TABLE
2010 Returns a hashref of virtual field names and vfieldparts applicable to the given
2015 sub vfieldpart_hashref {
2017 my $table = $self->table;
2019 return {} unless dbdef->table('part_virtual_field');
2022 my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
2023 "dbtable = '$table'";
2024 my $sth = $dbh->prepare($statement);
2025 $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
2026 return { map { $_->{name}, $_->{vfieldpart} }
2027 @{$sth->fetchall_arrayref({})} };
2034 This is deprecated. Don't use it.
2036 It returns a hash-type list with the fields of this record's table set true.
2041 carp "warning: hfields is deprecated";
2044 foreach (fields($table)) {
2053 "$_: ". $self->getfield($_). "|"
2054 } (fields($self->table)) );
2057 =item encrypt($value)
2059 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2061 Returns the encrypted string.
2063 You should generally not have to worry about calling this, as the system handles this for you.
2069 my ($self, $value) = @_;
2072 my $conf = new FS::Conf;
2073 if ($conf->exists('encryption')) {
2074 if ($self->is_encrypted($value)) {
2075 # Return the original value if it isn't plaintext.
2076 $encrypted = $value;
2079 if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2080 # RSA doesn't like the empty string so let's pack it up
2081 # The database doesn't like the RSA data so uuencode it
2082 my $length = length($value)+1;
2083 $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2085 die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2092 =item is_encrypted($value)
2094 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2100 my ($self, $value) = @_;
2101 # Possible Bug - Some work may be required here....
2103 if ($value =~ /^M/ && length($value) > 80) {
2110 =item decrypt($value)
2112 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2114 You should generally not have to worry about calling this, as the system handles this for you.
2119 my ($self,$value) = @_;
2120 my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2121 my $conf = new FS::Conf;
2122 if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2124 if (ref($rsa_decrypt) =~ /::RSA/) {
2125 my $encrypted = unpack ("u*", $value);
2126 $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2127 if ($@) {warn "Decryption Failed"};
2135 #Initialize the Module
2136 $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2138 my $conf = new FS::Conf;
2139 if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
2140 $rsa_module = $conf->config('encryptionmodule');
2144 eval ("require $rsa_module"); # No need to import the namespace
2147 # Initialize Encryption
2148 if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
2149 my $public_key = join("\n",$conf->config('encryptionpublickey'));
2150 $rsa_encrypt = $rsa_module->new_public_key($public_key);
2153 # Intitalize Decryption
2154 if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
2155 my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2156 $rsa_decrypt = $rsa_module->new_private_key($private_key);
2160 sub DESTROY { return; }
2164 # #use Carp qw(cluck);
2165 # #cluck "DESTROYING $self";
2166 # warn "DESTROYING $self";
2170 # return ! eval { join('',@_), kill 0; 1; };
2177 This module should probably be renamed, since much of the functionality is
2178 of general use. It is not completely unlike Adapter::DBI (see below).
2180 Exported qsearch and qsearchs should be deprecated in favor of method calls
2181 (against an FS::Record object like the old search and searchs that qsearch
2182 and qsearchs were on top of.)
2184 The whole fields / hfields mess should be removed.
2186 The various WHERE clauses should be subroutined.
2188 table string should be deprecated in favor of DBIx::DBSchema::Table.
2190 No doubt we could benefit from a Tied hash. Documenting how exists / defined
2191 true maps to the database (and WHERE clauses) would also help.
2193 The ut_ methods should ask the dbdef for a default length.
2195 ut_sqltype (like ut_varchar) should all be defined
2197 A fallback check method should be provided which uses the dbdef.
2199 The ut_money method assumes money has two decimal digits.
2201 The Pg money kludge in the new method only strips `$'.
2203 The ut_phonen method only checks US-style phone numbers.
2205 The _quote function should probably use ut_float instead of a regex.
2207 All the subroutines probably should be methods, here or elsewhere.
2209 Probably should borrow/use some dbdef methods where appropriate (like sub
2212 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
2213 or allow it to be set. Working around it is ugly any way around - DBI should
2214 be fixed. (only affects RDBMS which return uppercase column names)
2216 ut_zip should take an optional country like ut_phone.
2220 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
2222 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.