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);
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 )',
220 Much code still uses old-style positional parameters, this is also probably
221 fine in the common case where there are only two parameters:
223 my @records = qsearch( 'table', { 'field' => 'value' } );
225 ###oops, argh, FS::Record::new only lets us create database fields.
226 #Normal behaviour if SELECT is not specified is `*', as in
227 #C<SELECT * FROM table WHERE ...>. However, there is an experimental new
228 #feature where you can specify SELECT - remember, the objects returned,
229 #although blessed into the appropriate `FS::TABLE' package, will only have the
230 #fields you specify. This might have unwanted results if you then go calling
231 #regular FS::TABLE methods
237 my($stable, $record, $select, $extra_sql, $order_by, $cache, $addl_from );
238 if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too
240 $stable = $opt->{'table'} or die "table name is required";
241 $record = $opt->{'hashref'} || {};
242 $select = $opt->{'select'} || '*';
243 $extra_sql = $opt->{'extra_sql'} || '';
244 $order_by = $opt->{'order_by'} || '';
245 $cache = $opt->{'cache_obj'} || '';
246 $addl_from = $opt->{'addl_from'} || '';
248 ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_;
252 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
254 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
258 my $table = $cache ? $cache->table : $stable;
259 my $dbdef_table = dbdef->table($table)
260 or die "No schema for table $table found - ".
261 "do you need to run freeside-upgrade?";
262 my $pkey = $dbdef_table->primary_key;
264 my @real_fields = grep exists($record->{$_}), real_fields($table);
266 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
267 @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
269 cluck "warning: FS::$table not loaded; virtual fields not searchable";
270 @virtual_fields = ();
273 my $statement = "SELECT $select FROM $stable";
274 $statement .= " $addl_from" if $addl_from;
275 if ( @real_fields or @virtual_fields ) {
276 $statement .= ' WHERE '. join(' AND ',
277 get_real_fields($table, $record, \@real_fields) ,
278 get_virtual_fields($table, $pkey, $record, \@virtual_fields),
282 $statement .= " $extra_sql" if defined($extra_sql);
283 $statement .= " $order_by" if defined($order_by);
285 warn "[debug]$me $statement\n" if $DEBUG > 1;
286 my $sth = $dbh->prepare($statement)
287 or croak "$dbh->errstr doing $statement";
292 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
294 if ( $record->{$field} =~ /^\d+(\.\d+)?$/
295 && dbdef->table($table)->column($field)->type =~ /(int|(big)?serial)/i
297 $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } );
299 $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_VARCHAR } );
303 # $sth->execute( map $record->{$_},
304 # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
305 # ) or croak "Error executing \"$statement\": ". $sth->errstr;
307 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
309 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
310 @virtual_fields = "FS::$table"->virtual_fields;
312 cluck "warning: FS::$table not loaded; virtual fields not returned either";
313 @virtual_fields = ();
317 tie %result, "Tie::IxHash";
318 my @stuff = @{ $sth->fetchall_arrayref( {} ) };
319 if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
320 %result = map { $_->{$pkey}, $_ } @stuff;
322 @result{@stuff} = @stuff;
327 if ( keys(%result) and @virtual_fields ) {
329 "SELECT virtual_field.recnum, part_virtual_field.name, ".
330 "virtual_field.value ".
331 "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ".
332 "WHERE part_virtual_field.dbtable = '$table' AND ".
333 "virtual_field.recnum IN (".
334 join(',', keys(%result)). ") AND part_virtual_field.name IN ('".
335 join(q!', '!, @virtual_fields) . "')";
336 warn "[debug]$me $statement\n" if $DEBUG > 1;
337 $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement";
338 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
340 foreach (@{ $sth->fetchall_arrayref({}) }) {
341 my $recnum = $_->{recnum};
342 my $name = $_->{name};
343 my $value = $_->{value};
344 if (exists($result{$recnum})) {
345 $result{$recnum}->{$name} = $value;
350 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
351 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
352 #derivied class didn't override new method, so this optimization is safe
355 new_or_cached( "FS::$table", { %{$_} }, $cache )
359 new( "FS::$table", { %{$_} } )
363 #okay, its been tested
364 # warn "untested code (class FS::$table uses custom new method)";
366 eval 'FS::'. $table. '->new( { %{$_} } )';
370 # Check for encrypted fields and decrypt them.
371 ## only in the local copy, not the cached object
372 if ( $conf && $conf->exists('encryption') # $conf doesn't exist when doing
373 # the initial search for
375 && eval 'defined(@FS::'. $table . '::encrypted_fields)') {
376 foreach my $record (@return) {
377 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
378 # Set it directly... This may cause a problem in the future...
379 $record->setfield($field, $record->decrypt($record->getfield($field)));
384 cluck "warning: FS::$table not loaded; returning FS::Record objects";
386 FS::Record->new( $table, { %{$_} } );
392 ## makes this easier to read
394 sub get_virtual_fields {
398 my $virtual_fields = shift;
404 if ( ref($record->{$_}) ) {
405 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
406 if ( uc($op) eq 'ILIKE' ) {
408 $record->{$_}{'value'} = lc($record->{$_}{'value'});
409 $column = "LOWER($_)";
411 $record->{$_} = $record->{$_}{'value'};
414 # ... EXISTS ( SELECT name, value FROM part_virtual_field
416 # ON part_virtual_field.vfieldpart = virtual_field.vfieldpart
417 # WHERE recnum = svc_acct.svcnum
418 # AND (name, value) = ('egad', 'brain') )
420 my $value = $record->{$_};
424 $subq = ($value ? 'EXISTS ' : 'NOT EXISTS ') .
425 "( SELECT part_virtual_field.name, virtual_field.value ".
426 "FROM part_virtual_field JOIN virtual_field ".
427 "ON part_virtual_field.vfieldpart = virtual_field.vfieldpart ".
428 "WHERE virtual_field.recnum = ${table}.${pkey} ".
429 "AND part_virtual_field.name = '${column}'".
431 " AND virtual_field.value ${op} '${value}'"
435 } @{ $virtual_fields } ) ;
438 sub get_real_fields {
441 my $real_fields = shift;
443 ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability
449 if ( ref($record->{$_}) ) {
450 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
451 #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
452 if ( uc($op) eq 'ILIKE' ) {
454 $record->{$_}{'value'} = lc($record->{$_}{'value'});
455 $column = "LOWER($_)";
457 $record->{$_} = $record->{$_}{'value'}
460 if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
462 if ( driver_name eq 'Pg' ) {
463 my $type = dbdef->table($table)->column($column)->type;
464 if ( $type =~ /(int|(big)?serial)/i ) {
465 qq-( $column IS NULL )-;
467 qq-( $column IS NULL OR $column = '' )-;
470 qq-( $column IS NULL OR $column = "" )-;
472 } elsif ( $op 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 NOT NULL )-;
478 qq-( $column IS NOT NULL AND $column != '' )-;
481 qq-( $column IS NOT NULL AND $column != "" )-;
484 if ( driver_name eq 'Pg' ) {
485 qq-( $column $op '' )-;
487 qq-( $column $op "" )-;
493 } @{ $real_fields } );
496 =item by_key PRIMARY_KEY_VALUE
498 This is a class method that returns the record with the given primary key
499 value. This method is only useful in FS::Record subclasses. For example:
501 my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
505 my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
510 my ($class, $pkey_value) = @_;
512 my $table = $class->table
513 or croak "No table for $class found";
515 my $dbdef_table = dbdef->table($table)
516 or die "No schema for table $table found - ".
517 "do you need to create it or run dbdef-create?";
518 my $pkey = $dbdef_table->primary_key
519 or die "No primary key for table $table";
521 return qsearchs($table, { $pkey => $pkey_value });
524 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
526 Experimental JOINed search method. Using this method, you can execute a
527 single SELECT spanning multiple tables, and cache the results for subsequent
528 method calls. Interface will almost definately change in an incompatible
536 my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
537 my $cache = FS::SearchCache->new( $ptable, $pkey );
540 grep { !$saw{$_->getfield($pkey)}++ }
541 qsearch($table, $record, $select, $extra_sql, $cache )
545 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
547 Same as qsearch, except that if more than one record matches, it B<carp>s but
548 returns the first. If this happens, you either made a logic error in asking
549 for a single item, or your data is corrupted.
553 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
555 my(@result) = qsearch(@_);
556 cluck "warning: Multiple records in scalar search ($table)"
557 if scalar(@result) > 1;
558 #should warn more vehemently if the search was on a primary key?
559 scalar(@result) ? ($result[0]) : ();
570 Returns the table name.
575 # cluck "warning: FS::Record::table deprecated; supply one in subclass!";
582 Returns the DBIx::DBSchema::Table object for the table.
588 my($table)=$self->table;
589 dbdef->table($table);
594 Returns the primary key for the table.
600 my $pkey = $self->dbdef_table->primary_key;
603 =item get, getfield COLUMN
605 Returns the value of the column/field/key COLUMN.
610 my($self,$field) = @_;
611 # to avoid "Use of unitialized value" errors
612 if ( defined ( $self->{Hash}->{$field} ) ) {
613 $self->{Hash}->{$field};
623 =item set, setfield COLUMN, VALUE
625 Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE.
630 my($self,$field,$value) = @_;
631 $self->{'modified'} = 1;
632 $self->{'Hash'}->{$field} = $value;
639 =item AUTLOADED METHODS
641 $record->column is a synonym for $record->get('column');
643 $record->column('value') is a synonym for $record->set('column','value');
650 my($field)=$AUTOLOAD;
652 if ( defined($value) ) {
653 confess "errant AUTOLOAD $field for $self (arg $value)"
654 unless ref($self) && $self->can('setfield');
655 $self->setfield($field,$value);
657 confess "errant AUTOLOAD $field for $self (no args)"
658 unless ref($self) && $self->can('getfield');
659 $self->getfield($field);
665 # my $field = $AUTOLOAD;
667 # if ( defined($_[1]) ) {
668 # $_[0]->setfield($field, $_[1]);
670 # $_[0]->getfield($field);
676 Returns a list of the column/value pairs, usually for assigning to a new hash.
678 To make a distinct duplicate of an FS::Record object, you can do:
680 $new = new FS::Record ( $old->table, { $old->hash } );
686 confess $self. ' -> hash: Hash attribute is undefined'
687 unless defined($self->{'Hash'});
688 %{ $self->{'Hash'} };
693 Returns a reference to the column/value hash. This may be deprecated in the
694 future; if there's a reason you can't just use the autoloaded or get/set
706 Returns true if any of this object's values have been modified with set (or via
707 an autoloaded method). Doesn't yet recognize when you retreive a hashref and
717 =item select_for_update
719 Selects this record with the SQL "FOR UPDATE" command. This can be useful as
724 sub select_for_update {
726 my $primary_key = $self->primary_key;
729 'table' => $self->table,
730 'hashref' => { $primary_key => $self->$primary_key() },
731 'extra_sql' => 'FOR UPDATE',
737 Inserts this record to the database. If there is an error, returns the error,
738 otherwise returns false.
746 warn "$self -> insert" if $DEBUG;
748 my $error = $self->check;
749 return $error if $error;
751 #single-field unique keys are given a value if false
752 #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
753 foreach ( $self->dbdef_table->unique_singles) {
754 $self->unique($_) unless $self->getfield($_);
757 #and also the primary key, if the database isn't going to
758 my $primary_key = $self->dbdef_table->primary_key;
760 if ( $primary_key ) {
761 my $col = $self->dbdef_table->column($primary_key);
764 uc($col->type) =~ /^(BIG)?SERIAL\d?/
765 || ( driver_name eq 'Pg'
766 && defined($col->default)
767 && $col->default =~ /^nextval\(/i
769 || ( driver_name eq 'mysql'
770 && defined($col->local)
771 && $col->local =~ /AUTO_INCREMENT/i
773 $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
776 my $table = $self->table;
779 # Encrypt before the database
780 my $conf = new FS::Conf;
781 if ($conf->exists('encryption') && defined(eval '@FS::'. $table . '::encrypted_fields')) {
782 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
783 $self->{'saved'} = $self->getfield($field);
784 $self->setfield($field, $self->encrypt($self->getfield($field)));
789 #false laziness w/delete
791 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
794 my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
797 my $statement = "INSERT INTO $table ";
798 if ( @real_fields ) {
801 join( ', ', @real_fields ).
803 join( ', ', @values ).
807 $statement .= 'DEFAULT VALUES';
809 warn "[debug]$me $statement\n" if $DEBUG > 1;
810 my $sth = dbh->prepare($statement) or return dbh->errstr;
812 local $SIG{HUP} = 'IGNORE';
813 local $SIG{INT} = 'IGNORE';
814 local $SIG{QUIT} = 'IGNORE';
815 local $SIG{TERM} = 'IGNORE';
816 local $SIG{TSTP} = 'IGNORE';
817 local $SIG{PIPE} = 'IGNORE';
819 $sth->execute or return $sth->errstr;
821 # get inserted id from the database, if applicable & needed
822 if ( $db_seq && ! $self->getfield($primary_key) ) {
823 warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
827 if ( driver_name eq 'Pg' ) {
829 #my $oid = $sth->{'pg_oid_status'};
830 #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
832 my $default = $self->dbdef_table->column($primary_key)->default;
833 unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
834 dbh->rollback if $FS::UID::AutoCommit;
835 return "can't parse $table.$primary_key default value".
836 " for sequence name: $default";
840 my $i_sql = "SELECT currval('$sequence')";
841 my $i_sth = dbh->prepare($i_sql) or do {
842 dbh->rollback if $FS::UID::AutoCommit;
845 $i_sth->execute() or do { #$i_sth->execute($oid)
846 dbh->rollback if $FS::UID::AutoCommit;
847 return $i_sth->errstr;
849 $insertid = $i_sth->fetchrow_arrayref->[0];
851 } elsif ( driver_name eq 'mysql' ) {
853 $insertid = dbh->{'mysql_insertid'};
854 # work around mysql_insertid being null some of the time, ala RT :/
855 unless ( $insertid ) {
856 warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
857 "using SELECT LAST_INSERT_ID();";
858 my $i_sql = "SELECT LAST_INSERT_ID()";
859 my $i_sth = dbh->prepare($i_sql) or do {
860 dbh->rollback if $FS::UID::AutoCommit;
863 $i_sth->execute or do {
864 dbh->rollback if $FS::UID::AutoCommit;
865 return $i_sth->errstr;
867 $insertid = $i_sth->fetchrow_arrayref->[0];
872 dbh->rollback if $FS::UID::AutoCommit;
873 return "don't know how to retreive inserted ids from ". driver_name.
874 ", try using counterfiles (maybe run dbdef-create?)";
878 $self->setfield($primary_key, $insertid);
883 grep defined($self->getfield($_)) && $self->getfield($_) ne "",
884 $self->virtual_fields;
885 if (@virtual_fields) {
886 my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
888 my $vfieldpart = $self->vfieldpart_hashref;
890 my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
893 my $v_sth = dbh->prepare($v_statement) or do {
894 dbh->rollback if $FS::UID::AutoCommit;
898 foreach (keys(%v_values)) {
899 $v_sth->execute($self->getfield($primary_key),
903 dbh->rollback if $FS::UID::AutoCommit;
904 return $v_sth->errstr;
911 if ( defined dbdef->table('h_'. $table) ) {
912 my $h_statement = $self->_h_statement('insert');
913 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
914 $h_sth = dbh->prepare($h_statement) or do {
915 dbh->rollback if $FS::UID::AutoCommit;
921 $h_sth->execute or return $h_sth->errstr if $h_sth;
923 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
925 # Now that it has been saved, reset the encrypted fields so that $new
927 foreach my $field (keys %{$saved}) {
928 $self->setfield($field, $saved->{$field});
936 Depriciated (use insert instead).
941 cluck "warning: FS::Record::add deprecated!";
942 insert @_; #call method in this scope
947 Delete this record from the database. If there is an error, returns the error,
948 otherwise returns false.
955 my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
957 $self->getfield($_) eq ''
958 #? "( $_ IS NULL OR $_ = \"\" )"
959 ? ( driver_name eq 'Pg'
961 : "( $_ IS NULL OR $_ = \"\" )"
963 : "$_ = ". _quote($self->getfield($_),$self->table,$_)
964 } ( $self->dbdef_table->primary_key )
965 ? ( $self->dbdef_table->primary_key)
966 : real_fields($self->table)
968 warn "[debug]$me $statement\n" if $DEBUG > 1;
969 my $sth = dbh->prepare($statement) or return dbh->errstr;
972 if ( defined dbdef->table('h_'. $self->table) ) {
973 my $h_statement = $self->_h_statement('delete');
974 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
975 $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
980 my $primary_key = $self->dbdef_table->primary_key;
983 my $vfp = $self->vfieldpart_hashref;
984 foreach($self->virtual_fields) {
985 next if $self->getfield($_) eq '';
986 unless(@del_vfields) {
987 my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
988 $v_sth = dbh->prepare($st) or return dbh->errstr;
990 push @del_vfields, $_;
993 local $SIG{HUP} = 'IGNORE';
994 local $SIG{INT} = 'IGNORE';
995 local $SIG{QUIT} = 'IGNORE';
996 local $SIG{TERM} = 'IGNORE';
997 local $SIG{TSTP} = 'IGNORE';
998 local $SIG{PIPE} = 'IGNORE';
1000 my $rc = $sth->execute or return $sth->errstr;
1001 #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1002 $h_sth->execute or return $h_sth->errstr if $h_sth;
1003 $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
1004 or return $v_sth->errstr
1005 foreach (@del_vfields);
1007 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1009 #no need to needlessly destoy the data either (causes problems actually)
1010 #undef $self; #no need to keep object!
1017 Depriciated (use delete instead).
1022 cluck "warning: FS::Record::del deprecated!";
1023 &delete(@_); #call method in this scope
1026 =item replace OLD_RECORD
1028 Replace the OLD_RECORD with this one in the database. If there is an error,
1029 returns the error, otherwise returns false.
1034 my ($new, $old) = (shift, shift);
1036 $old = $new->replace_old unless defined($old);
1038 warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1040 if ( $new->can('replace_check') ) {
1041 my $error = $new->replace_check($old);
1042 return $error if $error;
1045 return "Records not in same table!" unless $new->table eq $old->table;
1047 my $primary_key = $old->dbdef_table->primary_key;
1048 return "Can't change primary key $primary_key ".
1049 'from '. $old->getfield($primary_key).
1050 ' to ' . $new->getfield($primary_key)
1052 && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1054 my $error = $new->check;
1055 return $error if $error;
1057 # Encrypt for replace
1058 my $conf = new FS::Conf;
1060 if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) {
1061 foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1062 $saved->{$field} = $new->getfield($field);
1063 $new->setfield($field, $new->encrypt($new->getfield($field)));
1067 #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1068 my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1069 ? ($_, $new->getfield($_)) : () } $old->fields;
1071 unless (keys(%diff) || $no_update_diff ) {
1072 carp "[warning]$me $new -> replace $old: records identical"
1073 unless $nowarn_identical;
1077 my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1079 "$_ = ". _quote($new->getfield($_),$old->table,$_)
1080 } real_fields($old->table)
1085 if ( $old->getfield($_) eq '' ) {
1087 #false laziness w/qsearch
1088 if ( driver_name eq 'Pg' ) {
1089 my $type = $old->dbdef_table->column($_)->type;
1090 if ( $type =~ /(int|(big)?serial)/i ) {
1093 qq-( $_ IS NULL OR $_ = '' )-;
1096 qq-( $_ IS NULL OR $_ = "" )-;
1100 "$_ = ". _quote($old->getfield($_),$old->table,$_);
1103 } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1106 warn "[debug]$me $statement\n" if $DEBUG > 1;
1107 my $sth = dbh->prepare($statement) or return dbh->errstr;
1110 if ( defined dbdef->table('h_'. $old->table) ) {
1111 my $h_old_statement = $old->_h_statement('replace_old');
1112 warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1113 $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1119 if ( defined dbdef->table('h_'. $new->table) ) {
1120 my $h_new_statement = $new->_h_statement('replace_new');
1121 warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1122 $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1127 # For virtual fields we have three cases with different SQL
1128 # statements: add, replace, delete
1132 my (@add_vfields, @rep_vfields, @del_vfields);
1133 my $vfp = $old->vfieldpart_hashref;
1134 foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
1135 if($diff{$_} eq '') {
1137 unless(@del_vfields) {
1138 my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
1139 "AND vfieldpart = ?";
1140 warn "[debug]$me $st\n" if $DEBUG > 2;
1141 $v_del_sth = dbh->prepare($st) or return dbh->errstr;
1143 push @del_vfields, $_;
1144 } elsif($old->getfield($_) eq '') {
1146 unless(@add_vfields) {
1147 my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
1149 warn "[debug]$me $st\n" if $DEBUG > 2;
1150 $v_add_sth = dbh->prepare($st) or return dbh->errstr;
1152 push @add_vfields, $_;
1155 unless(@rep_vfields) {
1156 my $st = "UPDATE virtual_field SET value = ? ".
1157 "WHERE recnum = ? AND vfieldpart = ?";
1158 warn "[debug]$me $st\n" if $DEBUG > 2;
1159 $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
1161 push @rep_vfields, $_;
1165 local $SIG{HUP} = 'IGNORE';
1166 local $SIG{INT} = 'IGNORE';
1167 local $SIG{QUIT} = 'IGNORE';
1168 local $SIG{TERM} = 'IGNORE';
1169 local $SIG{TSTP} = 'IGNORE';
1170 local $SIG{PIPE} = 'IGNORE';
1172 my $rc = $sth->execute or return $sth->errstr;
1173 #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1174 $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1175 $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1177 $v_del_sth->execute($old->getfield($primary_key),
1179 or return $v_del_sth->errstr
1180 foreach(@del_vfields);
1182 $v_add_sth->execute($new->getfield($_),
1183 $old->getfield($primary_key),
1185 or return $v_add_sth->errstr
1186 foreach(@add_vfields);
1188 $v_rep_sth->execute($new->getfield($_),
1189 $old->getfield($primary_key),
1191 or return $v_rep_sth->errstr
1192 foreach(@rep_vfields);
1194 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1196 # Now that it has been saved, reset the encrypted fields so that $new
1197 # can still be used.
1198 foreach my $field (keys %{$saved}) {
1199 $new->setfield($field, $saved->{$field});
1207 my( $self ) = shift;
1208 warn "[$me] replace called with no arguments; autoloading old record\n"
1211 my $primary_key = $self->dbdef_table->primary_key;
1212 if ( $primary_key ) {
1213 $self->by_key( $self->$primary_key() ) #this is what's returned
1214 or croak "can't find ". $self->table. ".$primary_key ".
1215 $self->$primary_key();
1217 croak $self->table. " has no primary key; pass old record as argument";
1224 Depriciated (use replace instead).
1229 cluck "warning: FS::Record::rep deprecated!";
1230 replace @_; #call method in this scope
1235 Checks virtual fields (using check_blocks). Subclasses should still provide
1236 a check method to validate real fields, foreign keys, etc., and call this
1237 method via $self->SUPER::check.
1239 (FIXME: Should this method try to make sure that it I<is> being called from
1240 a subclass's check method, to keep the current semantics as far as possible?)
1245 #confess "FS::Record::check not implemented; supply one in subclass!";
1248 foreach my $field ($self->virtual_fields) {
1249 for ($self->getfield($field)) {
1250 # See notes on check_block in FS::part_virtual_field.
1251 eval $self->pvf($field)->check_block;
1253 #this is bad, probably want to follow the stack backtrace up and see
1255 my $err = "Fatal error checking $field for $self";
1257 return "$err (see log for backtrace): $@";
1260 $self->setfield($field, $_);
1267 my( $self, $action, $time ) = @_;
1272 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1273 real_fields($self->table);
1276 # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1277 # You can see if it changed by the paymask...
1278 my $conf = new FS::Conf;
1279 if ($conf->exists('encryption') ) {
1280 @fields = grep $_ ne 'payinfo' && $_ ne 'cvv2', @fields;
1282 my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1284 "INSERT INTO h_". $self->table. " ( ".
1285 join(', ', qw(history_date history_user history_action), @fields ).
1287 join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1294 B<Warning>: External use is B<deprecated>.
1296 Replaces COLUMN in record with a unique number, using counters in the
1297 filesystem. Used by the B<insert> method on single-field unique columns
1298 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1299 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1301 Returns the new value.
1306 my($self,$field) = @_;
1307 my($table)=$self->table;
1309 croak "Unique called on field $field, but it is ",
1310 $self->getfield($field),
1312 if $self->getfield($field);
1314 #warn "table $table is tainted" if is_tainted($table);
1315 #warn "field $field is tainted" if is_tainted($field);
1317 my($counter) = new File::CounterFile "$table.$field",0;
1319 # getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1321 # my($counter) = new File::CounterFile "$user/$table.$field",0;
1324 my $index = $counter->inc;
1325 $index = $counter->inc while qsearchs($table, { $field=>$index } );
1327 $index =~ /^(\d*)$/;
1330 $self->setfield($field,$index);
1334 =item ut_float COLUMN
1336 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be
1337 null. If there is an error, returns the error, otherwise returns false.
1342 my($self,$field)=@_ ;
1343 ($self->getfield($field) =~ /^(\d+\.\d+)$/ ||
1344 $self->getfield($field) =~ /^(\d+)$/ ||
1345 $self->getfield($field) =~ /^(\d+\.\d+e\d+)$/ ||
1346 $self->getfield($field) =~ /^(\d+e\d+)$/)
1347 or return "Illegal or empty (float) $field: ". $self->getfield($field);
1348 $self->setfield($field,$1);
1351 =item ut_floatn COLUMN
1353 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
1354 null. If there is an error, returns the error, otherwise returns false.
1358 #false laziness w/ut_ipn
1360 my( $self, $field ) = @_;
1361 if ( $self->getfield($field) =~ /^()$/ ) {
1362 $self->setfield($field,'');
1365 $self->ut_float($field);
1369 =item ut_sfloat COLUMN
1371 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1372 May not be null. If there is an error, returns the error, otherwise returns
1378 my($self,$field)=@_ ;
1379 ($self->getfield($field) =~ /^(-?\d+\.\d+)$/ ||
1380 $self->getfield($field) =~ /^(-?\d+)$/ ||
1381 $self->getfield($field) =~ /^(-?\d+\.\d+[eE]-?\d+)$/ ||
1382 $self->getfield($field) =~ /^(-?\d+[eE]-?\d+)$/)
1383 or return "Illegal or empty (float) $field: ". $self->getfield($field);
1384 $self->setfield($field,$1);
1387 =item ut_sfloatn COLUMN
1389 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
1390 null. If there is an error, returns the error, otherwise returns false.
1395 my( $self, $field ) = @_;
1396 if ( $self->getfield($field) =~ /^()$/ ) {
1397 $self->setfield($field,'');
1400 $self->ut_sfloat($field);
1404 =item ut_snumber COLUMN
1406 Check/untaint signed numeric data (whole numbers). If there is an error,
1407 returns the error, otherwise returns false.
1412 my($self, $field) = @_;
1413 $self->getfield($field) =~ /^(-?)\s*(\d+)$/
1414 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1415 $self->setfield($field, "$1$2");
1419 =item ut_snumbern COLUMN
1421 Check/untaint signed numeric data (whole numbers). If there is an error,
1422 returns the error, otherwise returns false.
1427 my($self, $field) = @_;
1428 $self->getfield($field) =~ /^(-?)\s*(\d*)$/
1429 or return "Illegal (numeric) $field: ". $self->getfield($field);
1431 return "Illegal (numeric) $field: ". $self->getfield($field)
1434 $self->setfield($field, "$1$2");
1438 =item ut_number COLUMN
1440 Check/untaint simple numeric data (whole numbers). May not be null. If there
1441 is an error, returns the error, otherwise returns false.
1446 my($self,$field)=@_;
1447 $self->getfield($field) =~ /^(\d+)$/
1448 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1449 $self->setfield($field,$1);
1453 =item ut_numbern COLUMN
1455 Check/untaint simple numeric data (whole numbers). May be null. If there is
1456 an error, returns the error, otherwise returns false.
1461 my($self,$field)=@_;
1462 $self->getfield($field) =~ /^(\d*)$/
1463 or return "Illegal (numeric) $field: ". $self->getfield($field);
1464 $self->setfield($field,$1);
1468 =item ut_money COLUMN
1470 Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
1471 is an error, returns the error, otherwise returns false.
1476 my($self,$field)=@_;
1477 $self->setfield($field, 0) if $self->getfield($field) eq '';
1478 $self->getfield($field) =~ /^(\-)? ?(\d*)(\.\d{2})?$/
1479 or return "Illegal (money) $field: ". $self->getfield($field);
1480 #$self->setfield($field, "$1$2$3" || 0);
1481 $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
1485 =item ut_text COLUMN
1487 Check/untaint text. Alphanumerics, spaces, and the following punctuation
1488 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ]
1489 May not be null. If there is an error, returns the error, otherwise returns
1495 my($self,$field)=@_;
1496 #warn "msgcat ". \&msgcat. "\n";
1497 #warn "notexist ". \¬exist. "\n";
1498 #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
1499 $self->getfield($field)
1500 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/
1501 or return gettext('illegal_or_empty_text'). " $field: ".
1502 $self->getfield($field);
1503 $self->setfield($field,$1);
1507 =item ut_textn COLUMN
1509 Check/untaint text. Alphanumerics, spaces, and the following punctuation
1510 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
1511 May be null. If there is an error, returns the error, otherwise returns false.
1516 my($self,$field)=@_;
1517 $self->getfield($field)
1518 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/
1519 or return gettext('illegal_text'). " $field: ". $self->getfield($field);
1520 $self->setfield($field,$1);
1524 =item ut_alpha COLUMN
1526 Check/untaint alphanumeric strings (no spaces). May not be null. If there is
1527 an error, returns the error, otherwise returns false.
1532 my($self,$field)=@_;
1533 $self->getfield($field) =~ /^(\w+)$/
1534 or return "Illegal or empty (alphanumeric) $field: ".
1535 $self->getfield($field);
1536 $self->setfield($field,$1);
1540 =item ut_alpha COLUMN
1542 Check/untaint alphanumeric strings (no spaces). May be null. If there is an
1543 error, returns the error, otherwise returns false.
1548 my($self,$field)=@_;
1549 $self->getfield($field) =~ /^(\w*)$/
1550 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
1551 $self->setfield($field,$1);
1555 =item ut_phonen COLUMN [ COUNTRY ]
1557 Check/untaint phone numbers. May be null. If there is an error, returns
1558 the error, otherwise returns false.
1560 Takes an optional two-letter ISO country code; without it or with unsupported
1561 countries, ut_phonen simply calls ut_alphan.
1566 my( $self, $field, $country ) = @_;
1567 return $self->ut_alphan($field) unless defined $country;
1568 my $phonen = $self->getfield($field);
1569 if ( $phonen eq '' ) {
1570 $self->setfield($field,'');
1571 } elsif ( $country eq 'US' || $country eq 'CA' ) {
1573 $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
1574 or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
1575 $phonen = "$1-$2-$3";
1576 $phonen .= " x$4" if $4;
1577 $self->setfield($field,$phonen);
1579 warn "warning: don't know how to check phone numbers for country $country";
1580 return $self->ut_textn($field);
1587 Check/untaint hexadecimal values.
1592 my($self, $field) = @_;
1593 $self->getfield($field) =~ /^([\da-fA-F]+)$/
1594 or return "Illegal (hex) $field: ". $self->getfield($field);
1595 $self->setfield($field, uc($1));
1599 =item ut_hexn COLUMN
1601 Check/untaint hexadecimal values. May be null.
1606 my($self, $field) = @_;
1607 $self->getfield($field) =~ /^([\da-fA-F]*)$/
1608 or return "Illegal (hex) $field: ". $self->getfield($field);
1609 $self->setfield($field, uc($1));
1614 Check/untaint ip addresses. IPv4 only for now.
1619 my( $self, $field ) = @_;
1620 $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
1621 or return "Illegal (IP address) $field: ". $self->getfield($field);
1622 for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
1623 $self->setfield($field, "$1.$2.$3.$4");
1629 Check/untaint ip addresses. IPv4 only for now. May be null.
1634 my( $self, $field ) = @_;
1635 if ( $self->getfield($field) =~ /^()$/ ) {
1636 $self->setfield($field,'');
1639 $self->ut_ip($field);
1643 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
1645 Check/untaint coordinates.
1646 Accepts the following forms:
1656 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
1657 The latter form (that is, the MMM are thousands of minutes) is
1658 assumed if the "MMM" is exactly three digits or two digits > 59.
1660 To be safe, just use the DDD.DDDDD form.
1662 If LOWER or UPPER are specified, then the coordinate is checked
1663 for lower and upper bounds, respectively.
1669 my ($self, $field) = (shift, shift);
1671 my $lower = shift if scalar(@_);
1672 my $upper = shift if scalar(@_);
1673 my $coord = $self->getfield($field);
1674 my $neg = $coord =~ s/^(-)//;
1676 my ($d, $m, $s) = (0, 0, 0);
1679 (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
1680 (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
1681 (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
1683 $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
1686 return "Invalid (coordinate with minutes > 59) $field: "
1687 . $self->getfield($field);
1690 $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
1692 if (defined($lower) and ($coord < $lower)) {
1693 return "Invalid (coordinate < $lower) $field: "
1694 . $self->getfield($field);;
1697 if (defined($upper) and ($coord > $upper)) {
1698 return "Invalid (coordinate > $upper) $field: "
1699 . $self->getfield($field);;
1702 $self->setfield($field, $coord);
1706 return "Invalid (coordinate) $field: " . $self->getfield($field);
1710 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
1712 Same as ut_coord, except optionally null.
1718 my ($self, $field) = (shift, shift);
1720 if ($self->getfield($field) =~ /^$/) {
1723 return $self->ut_coord($field, @_);
1729 =item ut_domain COLUMN
1731 Check/untaint host and domain names.
1736 my( $self, $field ) = @_;
1737 #$self->getfield($field) =~/^(\w+\.)*\w+$/
1738 $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
1739 or return "Illegal (domain) $field: ". $self->getfield($field);
1740 $self->setfield($field,$1);
1744 =item ut_name COLUMN
1746 Check/untaint proper names; allows alphanumerics, spaces and the following
1747 punctuation: , . - '
1754 my( $self, $field ) = @_;
1755 $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
1756 or return gettext('illegal_name'). " $field: ". $self->getfield($field);
1757 $self->setfield($field,$1);
1763 Check/untaint zip codes.
1767 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
1770 my( $self, $field, $country ) = @_;
1772 if ( $country eq 'US' ) {
1774 $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
1775 or return gettext('illegal_zip'). " $field for country $country: ".
1776 $self->getfield($field);
1777 $self->setfield($field, $1);
1779 } elsif ( $country eq 'CA' ) {
1781 $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
1782 or return gettext('illegal_zip'). " $field for country $country: ".
1783 $self->getfield($field);
1784 $self->setfield($field, "$1 $2");
1788 if ( $self->getfield($field) =~ /^\s*$/
1789 && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
1792 $self->setfield($field,'');
1794 $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
1795 or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
1796 $self->setfield($field,$1);
1804 =item ut_country COLUMN
1806 Check/untaint country codes. Country names are changed to codes, if possible -
1807 see L<Locale::Country>.
1812 my( $self, $field ) = @_;
1813 unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
1814 if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
1815 && country2code($1) ) {
1816 $self->setfield($field,uc(country2code($1)));
1819 $self->getfield($field) =~ /^(\w\w)$/
1820 or return "Illegal (country) $field: ". $self->getfield($field);
1821 $self->setfield($field,uc($1));
1825 =item ut_anything COLUMN
1827 Untaints arbitrary data. Be careful.
1832 my( $self, $field ) = @_;
1833 $self->getfield($field) =~ /^(.*)$/s
1834 or return "Illegal $field: ". $self->getfield($field);
1835 $self->setfield($field,$1);
1839 =item ut_enum COLUMN CHOICES_ARRAYREF
1841 Check/untaint a column, supplying all possible choices, like the "enum" type.
1846 my( $self, $field, $choices ) = @_;
1847 foreach my $choice ( @$choices ) {
1848 if ( $self->getfield($field) eq $choice ) {
1849 $self->setfield($choice);
1853 return "Illegal (enum) field $field: ". $self->getfield($field);
1856 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
1858 Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
1859 on the column first.
1863 sub ut_foreign_key {
1864 my( $self, $field, $table, $foreign ) = @_;
1865 qsearchs($table, { $foreign => $self->getfield($field) })
1866 or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
1867 " in $table.$foreign";
1871 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
1873 Like ut_foreign_key, except the null value is also allowed.
1877 sub ut_foreign_keyn {
1878 my( $self, $field, $table, $foreign ) = @_;
1879 $self->getfield($field)
1880 ? $self->ut_foreign_key($field, $table, $foreign)
1884 =item ut_agentnum_acl
1886 Checks this column as an agentnum, taking into account the current users's
1891 sub ut_agentnum_acl {
1892 my( $self, $field, $null_acl ) = @_;
1894 my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
1895 return "Illegal agentnum: $error" if $error;
1897 my $curuser = $FS::CurrentUser::CurrentUser;
1899 if ( $self->$field() ) {
1901 return "Access deined"
1902 unless $curuser->agentnum($self->$field());
1906 return "Access denied"
1907 unless $curuser->access_right($null_acl);
1915 =item virtual_fields [ TABLE ]
1917 Returns a list of virtual fields defined for the table. This should not
1918 be exported, and should only be called as an instance or class method.
1922 sub virtual_fields {
1925 $table = $self->table or confess "virtual_fields called on non-table";
1927 confess "Unknown table $table" unless dbdef->table($table);
1929 return () unless dbdef->table('part_virtual_field');
1931 unless ( $virtual_fields_cache{$table} ) {
1932 my $query = 'SELECT name from part_virtual_field ' .
1933 "WHERE dbtable = '$table'";
1935 my $result = $dbh->selectcol_arrayref($query);
1936 confess "Error executing virtual fields query: $query: ". $dbh->errstr
1938 $virtual_fields_cache{$table} = $result;
1941 @{$virtual_fields_cache{$table}};
1946 =item fields [ TABLE ]
1948 This is a wrapper for real_fields and virtual_fields. Code that called
1949 fields before should probably continue to call fields.
1954 my $something = shift;
1956 if($something->isa('FS::Record')) {
1957 $table = $something->table;
1959 $table = $something;
1960 $something = "FS::$table";
1962 return (real_fields($table), $something->virtual_fields());
1967 =item pvf FIELD_NAME
1969 Returns the FS::part_virtual_field object corresponding to a field in the
1970 record (specified by FIELD_NAME).
1975 my ($self, $name) = (shift, shift);
1977 if(grep /^$name$/, $self->virtual_fields) {
1978 return qsearchs('part_virtual_field', { dbtable => $self->table,
1988 =item real_fields [ TABLE ]
1990 Returns a list of the real columns in the specified table. Called only by
1991 fields() and other subroutines elsewhere in FS::Record.
1998 my($table_obj) = dbdef->table($table);
1999 confess "Unknown table $table" unless $table_obj;
2000 $table_obj->columns;
2003 =item _quote VALUE, TABLE, COLUMN
2005 This is an internal function used to construct SQL statements. It returns
2006 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2007 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2012 my($value, $table, $column) = @_;
2013 my $column_obj = dbdef->table($table)->column($column);
2014 my $column_type = $column_obj->type;
2015 my $nullable = $column_obj->null;
2017 warn " $table.$column: $value ($column_type".
2018 ( $nullable ? ' NULL' : ' NOT NULL' ).
2019 ")\n" if $DEBUG > 2;
2021 if ( $value eq '' && $nullable ) {
2023 } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2024 cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2027 } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2028 ! $column_type =~ /(char|binary|text)$/i ) {
2035 =item vfieldpart_hashref TABLE
2037 Returns a hashref of virtual field names and vfieldparts applicable to the given
2042 sub vfieldpart_hashref {
2044 my $table = $self->table;
2046 return {} unless dbdef->table('part_virtual_field');
2049 my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
2050 "dbtable = '$table'";
2051 my $sth = $dbh->prepare($statement);
2052 $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
2053 return { map { $_->{name}, $_->{vfieldpart} }
2054 @{$sth->fetchall_arrayref({})} };
2061 This is deprecated. Don't use it.
2063 It returns a hash-type list with the fields of this record's table set true.
2068 carp "warning: hfields is deprecated";
2071 foreach (fields($table)) {
2080 "$_: ". $self->getfield($_). "|"
2081 } (fields($self->table)) );
2084 =item encrypt($value)
2086 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2088 Returns the encrypted string.
2090 You should generally not have to worry about calling this, as the system handles this for you.
2096 my ($self, $value) = @_;
2099 my $conf = new FS::Conf;
2100 if ($conf->exists('encryption')) {
2101 if ($self->is_encrypted($value)) {
2102 # Return the original value if it isn't plaintext.
2103 $encrypted = $value;
2106 if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2107 # RSA doesn't like the empty string so let's pack it up
2108 # The database doesn't like the RSA data so uuencode it
2109 my $length = length($value)+1;
2110 $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2112 die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2119 =item is_encrypted($value)
2121 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2127 my ($self, $value) = @_;
2128 # Possible Bug - Some work may be required here....
2130 if ($value =~ /^M/ && length($value) > 80) {
2137 =item decrypt($value)
2139 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2141 You should generally not have to worry about calling this, as the system handles this for you.
2146 my ($self,$value) = @_;
2147 my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2148 my $conf = new FS::Conf;
2149 if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2151 if (ref($rsa_decrypt) =~ /::RSA/) {
2152 my $encrypted = unpack ("u*", $value);
2153 $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2154 if ($@) {warn "Decryption Failed"};
2162 #Initialize the Module
2163 $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2165 my $conf = new FS::Conf;
2166 if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') {
2167 $rsa_module = $conf->config('encryptionmodule');
2171 eval ("require $rsa_module"); # No need to import the namespace
2174 # Initialize Encryption
2175 if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') {
2176 my $public_key = join("\n",$conf->config('encryptionpublickey'));
2177 $rsa_encrypt = $rsa_module->new_public_key($public_key);
2180 # Intitalize Decryption
2181 if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') {
2182 my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2183 $rsa_decrypt = $rsa_module->new_private_key($private_key);
2187 sub DESTROY { return; }
2191 # #use Carp qw(cluck);
2192 # #cluck "DESTROYING $self";
2193 # warn "DESTROYING $self";
2197 # return ! eval { join('',@_), kill 0; 1; };
2204 This module should probably be renamed, since much of the functionality is
2205 of general use. It is not completely unlike Adapter::DBI (see below).
2207 Exported qsearch and qsearchs should be deprecated in favor of method calls
2208 (against an FS::Record object like the old search and searchs that qsearch
2209 and qsearchs were on top of.)
2211 The whole fields / hfields mess should be removed.
2213 The various WHERE clauses should be subroutined.
2215 table string should be deprecated in favor of DBIx::DBSchema::Table.
2217 No doubt we could benefit from a Tied hash. Documenting how exists / defined
2218 true maps to the database (and WHERE clauses) would also help.
2220 The ut_ methods should ask the dbdef for a default length.
2222 ut_sqltype (like ut_varchar) should all be defined
2224 A fallback check method should be provided which uses the dbdef.
2226 The ut_money method assumes money has two decimal digits.
2228 The Pg money kludge in the new method only strips `$'.
2230 The ut_phonen method only checks US-style phone numbers.
2232 The _quote function should probably use ut_float instead of a regex.
2234 All the subroutines probably should be methods, here or elsewhere.
2236 Probably should borrow/use some dbdef methods where appropriate (like sub
2239 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
2240 or allow it to be set. Working around it is ugly any way around - DBI should
2241 be fixed. (only affects RDBMS which return uppercase column names)
2243 ut_zip should take an optional country like ut_phone.
2247 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
2249 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.