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 )',
221 Much code still uses old-style positional parameters, this is also probably
222 fine in the common case where there are only two parameters:
224 my @records = qsearch( 'table', { 'field' => 'value' } );
226 ###oops, argh, FS::Record::new only lets us create database fields.
227 #Normal behaviour if SELECT is not specified is `*', as in
228 #C<SELECT * FROM table WHERE ...>. However, there is an experimental new
229 #feature where you can specify SELECT - remember, the objects returned,
230 #although blessed into the appropriate `FS::TABLE' package, will only have the
231 #fields you specify. This might have unwanted results if you then go calling
232 #regular FS::TABLE methods
238 my($stable, $record, $select, $extra_sql, $order_by, $cache, $addl_from );
240 if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too
242 $stable = $opt->{'table'} or die "table name is required";
243 $record = $opt->{'hashref'} || {};
244 $select = $opt->{'select'} || '*';
245 $extra_sql = $opt->{'extra_sql'} || '';
246 $order_by = $opt->{'order_by'} || '';
247 $cache = $opt->{'cache_obj'} || '';
248 $addl_from = $opt->{'addl_from'} || '';
249 $debug = $opt->{'debug'} || '';
251 ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_;
255 #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table";
257 $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable";
261 my $table = $cache ? $cache->table : $stable;
262 my $dbdef_table = dbdef->table($table)
263 or die "No schema for table $table found - ".
264 "do you need to run freeside-upgrade?";
265 my $pkey = $dbdef_table->primary_key;
267 my @real_fields = grep exists($record->{$_}), real_fields($table);
269 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
270 @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
272 cluck "warning: FS::$table not loaded; virtual fields not searchable";
273 @virtual_fields = ();
276 my $statement = "SELECT $select FROM $stable";
277 $statement .= " $addl_from" if $addl_from;
278 if ( @real_fields or @virtual_fields ) {
279 $statement .= ' WHERE '. join(' AND ',
280 get_real_fields($table, $record, \@real_fields) ,
281 get_virtual_fields($table, $pkey, $record, \@virtual_fields),
285 $statement .= " $extra_sql" if defined($extra_sql);
286 $statement .= " $order_by" if defined($order_by);
288 warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug;
289 my $sth = $dbh->prepare($statement)
290 or croak "$dbh->errstr doing $statement";
295 grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
297 if ( $record->{$field} =~ /^\d+(\.\d+)?$/
298 && dbdef->table($table)->column($field)->type =~ /(int|(big)?serial)/i
300 $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } );
302 $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_VARCHAR } );
306 # $sth->execute( map $record->{$_},
307 # grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
308 # ) or croak "Error executing \"$statement\": ". $sth->errstr;
310 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
312 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
313 @virtual_fields = "FS::$table"->virtual_fields;
315 cluck "warning: FS::$table not loaded; virtual fields not returned either";
316 @virtual_fields = ();
320 tie %result, "Tie::IxHash";
321 my @stuff = @{ $sth->fetchall_arrayref( {} ) };
322 if ( $pkey && scalar(@stuff) && $stuff[0]->{$pkey} ) {
323 %result = map { $_->{$pkey}, $_ } @stuff;
325 @result{@stuff} = @stuff;
330 if ( keys(%result) and @virtual_fields ) {
332 "SELECT virtual_field.recnum, part_virtual_field.name, ".
333 "virtual_field.value ".
334 "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ".
335 "WHERE part_virtual_field.dbtable = '$table' AND ".
336 "virtual_field.recnum IN (".
337 join(',', keys(%result)). ") AND part_virtual_field.name IN ('".
338 join(q!', '!, @virtual_fields) . "')";
339 warn "[debug]$me $statement\n" if $DEBUG > 1;
340 $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement";
341 $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
343 foreach (@{ $sth->fetchall_arrayref({}) }) {
344 my $recnum = $_->{recnum};
345 my $name = $_->{name};
346 my $value = $_->{value};
347 if (exists($result{$recnum})) {
348 $result{$recnum}->{$name} = $value;
353 if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
354 if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) {
355 #derivied class didn't override new method, so this optimization is safe
358 new_or_cached( "FS::$table", { %{$_} }, $cache )
362 new( "FS::$table", { %{$_} } )
366 #okay, its been tested
367 # warn "untested code (class FS::$table uses custom new method)";
369 eval 'FS::'. $table. '->new( { %{$_} } )';
373 # Check for encrypted fields and decrypt them.
374 ## only in the local copy, not the cached object
375 if ( $conf && $conf->exists('encryption') # $conf doesn't exist when doing
376 # the initial search for
378 && eval 'defined(@FS::'. $table . '::encrypted_fields)') {
379 foreach my $record (@return) {
380 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
381 # Set it directly... This may cause a problem in the future...
382 $record->setfield($field, $record->decrypt($record->getfield($field)));
387 cluck "warning: FS::$table not loaded; returning FS::Record objects";
389 FS::Record->new( $table, { %{$_} } );
395 ## makes this easier to read
397 sub get_virtual_fields {
401 my $virtual_fields = shift;
407 if ( ref($record->{$_}) ) {
408 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
409 if ( uc($op) eq 'ILIKE' ) {
411 $record->{$_}{'value'} = lc($record->{$_}{'value'});
412 $column = "LOWER($_)";
414 $record->{$_} = $record->{$_}{'value'};
417 # ... EXISTS ( SELECT name, value FROM part_virtual_field
419 # ON part_virtual_field.vfieldpart = virtual_field.vfieldpart
420 # WHERE recnum = svc_acct.svcnum
421 # AND (name, value) = ('egad', 'brain') )
423 my $value = $record->{$_};
427 $subq = ($value ? 'EXISTS ' : 'NOT EXISTS ') .
428 "( SELECT part_virtual_field.name, virtual_field.value ".
429 "FROM part_virtual_field JOIN virtual_field ".
430 "ON part_virtual_field.vfieldpart = virtual_field.vfieldpart ".
431 "WHERE virtual_field.recnum = ${table}.${pkey} ".
432 "AND part_virtual_field.name = '${column}'".
434 " AND virtual_field.value ${op} '${value}'"
438 } @{ $virtual_fields } ) ;
441 sub get_real_fields {
444 my $real_fields = shift;
446 ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability
452 if ( ref($record->{$_}) ) {
453 $op = $record->{$_}{'op'} if $record->{$_}{'op'};
454 #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg';
455 if ( uc($op) eq 'ILIKE' ) {
457 $record->{$_}{'value'} = lc($record->{$_}{'value'});
458 $column = "LOWER($_)";
460 $record->{$_} = $record->{$_}{'value'}
463 if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
465 if ( driver_name eq 'Pg' ) {
466 my $type = dbdef->table($table)->column($column)->type;
467 if ( $type =~ /(int|(big)?serial)/i ) {
468 qq-( $column IS NULL )-;
470 qq-( $column IS NULL OR $column = '' )-;
473 qq-( $column IS NULL OR $column = "" )-;
475 } elsif ( $op eq '!=' ) {
476 if ( driver_name eq 'Pg' ) {
477 my $type = dbdef->table($table)->column($column)->type;
478 if ( $type =~ /(int|(big)?serial)/i ) {
479 qq-( $column IS NOT NULL )-;
481 qq-( $column IS NOT NULL AND $column != '' )-;
484 qq-( $column IS NOT NULL AND $column != "" )-;
487 if ( driver_name eq 'Pg' ) {
488 qq-( $column $op '' )-;
490 qq-( $column $op "" )-;
496 } @{ $real_fields } );
499 =item by_key PRIMARY_KEY_VALUE
501 This is a class method that returns the record with the given primary key
502 value. This method is only useful in FS::Record subclasses. For example:
504 my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
508 my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
513 my ($class, $pkey_value) = @_;
515 my $table = $class->table
516 or croak "No table for $class found";
518 my $dbdef_table = dbdef->table($table)
519 or die "No schema for table $table found - ".
520 "do you need to create it or run dbdef-create?";
521 my $pkey = $dbdef_table->primary_key
522 or die "No primary key for table $table";
524 return qsearchs($table, { $pkey => $pkey_value });
527 =item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
529 Experimental JOINed search method. Using this method, you can execute a
530 single SELECT spanning multiple tables, and cache the results for subsequent
531 method calls. Interface will almost definately change in an incompatible
539 my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_;
540 my $cache = FS::SearchCache->new( $ptable, $pkey );
543 grep { !$saw{$_->getfield($pkey)}++ }
544 qsearch($table, $record, $select, $extra_sql, $cache )
548 =item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
550 Same as qsearch, except that if more than one record matches, it B<carp>s but
551 returns the first. If this happens, you either made a logic error in asking
552 for a single item, or your data is corrupted.
556 sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
558 my(@result) = qsearch(@_);
559 cluck "warning: Multiple records in scalar search ($table)"
560 if scalar(@result) > 1;
561 #should warn more vehemently if the search was on a primary key?
562 scalar(@result) ? ($result[0]) : ();
573 Returns the table name.
578 # cluck "warning: FS::Record::table deprecated; supply one in subclass!";
585 Returns the DBIx::DBSchema::Table object for the table.
591 my($table)=$self->table;
592 dbdef->table($table);
597 Returns the primary key for the table.
603 my $pkey = $self->dbdef_table->primary_key;
606 =item get, getfield COLUMN
608 Returns the value of the column/field/key COLUMN.
613 my($self,$field) = @_;
614 # to avoid "Use of unitialized value" errors
615 if ( defined ( $self->{Hash}->{$field} ) ) {
616 $self->{Hash}->{$field};
626 =item set, setfield COLUMN, VALUE
628 Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE.
633 my($self,$field,$value) = @_;
634 $self->{'modified'} = 1;
635 $self->{'Hash'}->{$field} = $value;
642 =item AUTLOADED METHODS
644 $record->column is a synonym for $record->get('column');
646 $record->column('value') is a synonym for $record->set('column','value');
653 my($field)=$AUTOLOAD;
655 if ( defined($value) ) {
656 confess "errant AUTOLOAD $field for $self (arg $value)"
657 unless ref($self) && $self->can('setfield');
658 $self->setfield($field,$value);
660 confess "errant AUTOLOAD $field for $self (no args)"
661 unless ref($self) && $self->can('getfield');
662 $self->getfield($field);
668 # my $field = $AUTOLOAD;
670 # if ( defined($_[1]) ) {
671 # $_[0]->setfield($field, $_[1]);
673 # $_[0]->getfield($field);
679 Returns a list of the column/value pairs, usually for assigning to a new hash.
681 To make a distinct duplicate of an FS::Record object, you can do:
683 $new = new FS::Record ( $old->table, { $old->hash } );
689 confess $self. ' -> hash: Hash attribute is undefined'
690 unless defined($self->{'Hash'});
691 %{ $self->{'Hash'} };
696 Returns a reference to the column/value hash. This may be deprecated in the
697 future; if there's a reason you can't just use the autoloaded or get/set
709 Returns true if any of this object's values have been modified with set (or via
710 an autoloaded method). Doesn't yet recognize when you retreive a hashref and
720 =item select_for_update
722 Selects this record with the SQL "FOR UPDATE" command. This can be useful as
727 sub select_for_update {
729 my $primary_key = $self->primary_key;
732 'table' => $self->table,
733 'hashref' => { $primary_key => $self->$primary_key() },
734 'extra_sql' => 'FOR UPDATE',
740 Inserts this record to the database. If there is an error, returns the error,
741 otherwise returns false.
749 warn "$self -> insert" if $DEBUG;
751 my $error = $self->check;
752 return $error if $error;
754 #single-field unique keys are given a value if false
755 #(like MySQL's AUTO_INCREMENT or Pg SERIAL)
756 foreach ( $self->dbdef_table->unique_singles) {
757 $self->unique($_) unless $self->getfield($_);
760 #and also the primary key, if the database isn't going to
761 my $primary_key = $self->dbdef_table->primary_key;
763 if ( $primary_key ) {
764 my $col = $self->dbdef_table->column($primary_key);
767 uc($col->type) =~ /^(BIG)?SERIAL\d?/
768 || ( driver_name eq 'Pg'
769 && defined($col->default)
770 && $col->default =~ /^nextval\(/i
772 || ( driver_name eq 'mysql'
773 && defined($col->local)
774 && $col->local =~ /AUTO_INCREMENT/i
776 $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq;
779 my $table = $self->table;
782 # Encrypt before the database
783 my $conf = new FS::Conf;
784 if ($conf->exists('encryption') && defined(eval '@FS::'. $table . '::encrypted_fields')) {
785 foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
786 $self->{'saved'} = $self->getfield($field);
787 $self->setfield($field, $self->encrypt($self->getfield($field)));
792 #false laziness w/delete
794 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
797 my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
800 my $statement = "INSERT INTO $table ";
801 if ( @real_fields ) {
804 join( ', ', @real_fields ).
806 join( ', ', @values ).
810 $statement .= 'DEFAULT VALUES';
812 warn "[debug]$me $statement\n" if $DEBUG > 1;
813 my $sth = dbh->prepare($statement) or return dbh->errstr;
815 local $SIG{HUP} = 'IGNORE';
816 local $SIG{INT} = 'IGNORE';
817 local $SIG{QUIT} = 'IGNORE';
818 local $SIG{TERM} = 'IGNORE';
819 local $SIG{TSTP} = 'IGNORE';
820 local $SIG{PIPE} = 'IGNORE';
822 $sth->execute or return $sth->errstr;
824 # get inserted id from the database, if applicable & needed
825 if ( $db_seq && ! $self->getfield($primary_key) ) {
826 warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
830 if ( driver_name eq 'Pg' ) {
832 #my $oid = $sth->{'pg_oid_status'};
833 #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?";
835 my $default = $self->dbdef_table->column($primary_key)->default;
836 unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) {
837 dbh->rollback if $FS::UID::AutoCommit;
838 return "can't parse $table.$primary_key default value".
839 " for sequence name: $default";
843 my $i_sql = "SELECT currval('$sequence')";
844 my $i_sth = dbh->prepare($i_sql) or do {
845 dbh->rollback if $FS::UID::AutoCommit;
848 $i_sth->execute() or do { #$i_sth->execute($oid)
849 dbh->rollback if $FS::UID::AutoCommit;
850 return $i_sth->errstr;
852 $insertid = $i_sth->fetchrow_arrayref->[0];
854 } elsif ( driver_name eq 'mysql' ) {
856 $insertid = dbh->{'mysql_insertid'};
857 # work around mysql_insertid being null some of the time, ala RT :/
858 unless ( $insertid ) {
859 warn "WARNING: DBD::mysql didn't return mysql_insertid; ".
860 "using SELECT LAST_INSERT_ID();";
861 my $i_sql = "SELECT LAST_INSERT_ID()";
862 my $i_sth = dbh->prepare($i_sql) or do {
863 dbh->rollback if $FS::UID::AutoCommit;
866 $i_sth->execute or do {
867 dbh->rollback if $FS::UID::AutoCommit;
868 return $i_sth->errstr;
870 $insertid = $i_sth->fetchrow_arrayref->[0];
875 dbh->rollback if $FS::UID::AutoCommit;
876 return "don't know how to retreive inserted ids from ". driver_name.
877 ", try using counterfiles (maybe run dbdef-create?)";
881 $self->setfield($primary_key, $insertid);
886 grep defined($self->getfield($_)) && $self->getfield($_) ne "",
887 $self->virtual_fields;
888 if (@virtual_fields) {
889 my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
891 my $vfieldpart = $self->vfieldpart_hashref;
893 my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
896 my $v_sth = dbh->prepare($v_statement) or do {
897 dbh->rollback if $FS::UID::AutoCommit;
901 foreach (keys(%v_values)) {
902 $v_sth->execute($self->getfield($primary_key),
906 dbh->rollback if $FS::UID::AutoCommit;
907 return $v_sth->errstr;
914 if ( defined dbdef->table('h_'. $table) ) {
915 my $h_statement = $self->_h_statement('insert');
916 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
917 $h_sth = dbh->prepare($h_statement) or do {
918 dbh->rollback if $FS::UID::AutoCommit;
924 $h_sth->execute or return $h_sth->errstr if $h_sth;
926 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
928 # Now that it has been saved, reset the encrypted fields so that $new
930 foreach my $field (keys %{$saved}) {
931 $self->setfield($field, $saved->{$field});
939 Depriciated (use insert instead).
944 cluck "warning: FS::Record::add deprecated!";
945 insert @_; #call method in this scope
950 Delete this record from the database. If there is an error, returns the error,
951 otherwise returns false.
958 my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ',
960 $self->getfield($_) eq ''
961 #? "( $_ IS NULL OR $_ = \"\" )"
962 ? ( driver_name eq 'Pg'
964 : "( $_ IS NULL OR $_ = \"\" )"
966 : "$_ = ". _quote($self->getfield($_),$self->table,$_)
967 } ( $self->dbdef_table->primary_key )
968 ? ( $self->dbdef_table->primary_key)
969 : real_fields($self->table)
971 warn "[debug]$me $statement\n" if $DEBUG > 1;
972 my $sth = dbh->prepare($statement) or return dbh->errstr;
975 if ( defined dbdef->table('h_'. $self->table) ) {
976 my $h_statement = $self->_h_statement('delete');
977 warn "[debug]$me $h_statement\n" if $DEBUG > 2;
978 $h_sth = dbh->prepare($h_statement) or return dbh->errstr;
983 my $primary_key = $self->dbdef_table->primary_key;
986 my $vfp = $self->vfieldpart_hashref;
987 foreach($self->virtual_fields) {
988 next if $self->getfield($_) eq '';
989 unless(@del_vfields) {
990 my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
991 $v_sth = dbh->prepare($st) or return dbh->errstr;
993 push @del_vfields, $_;
996 local $SIG{HUP} = 'IGNORE';
997 local $SIG{INT} = 'IGNORE';
998 local $SIG{QUIT} = 'IGNORE';
999 local $SIG{TERM} = 'IGNORE';
1000 local $SIG{TSTP} = 'IGNORE';
1001 local $SIG{PIPE} = 'IGNORE';
1003 my $rc = $sth->execute or return $sth->errstr;
1004 #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
1005 $h_sth->execute or return $h_sth->errstr if $h_sth;
1006 $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
1007 or return $v_sth->errstr
1008 foreach (@del_vfields);
1010 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1012 #no need to needlessly destoy the data either (causes problems actually)
1013 #undef $self; #no need to keep object!
1020 Depriciated (use delete instead).
1025 cluck "warning: FS::Record::del deprecated!";
1026 &delete(@_); #call method in this scope
1029 =item replace OLD_RECORD
1031 Replace the OLD_RECORD with this one in the database. If there is an error,
1032 returns the error, otherwise returns false.
1037 my ($new, $old) = (shift, shift);
1039 $old = $new->replace_old unless defined($old);
1041 warn "[debug]$me $new ->replace $old\n" if $DEBUG;
1043 if ( $new->can('replace_check') ) {
1044 my $error = $new->replace_check($old);
1045 return $error if $error;
1048 return "Records not in same table!" unless $new->table eq $old->table;
1050 my $primary_key = $old->dbdef_table->primary_key;
1051 return "Can't change primary key $primary_key ".
1052 'from '. $old->getfield($primary_key).
1053 ' to ' . $new->getfield($primary_key)
1055 && ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
1057 my $error = $new->check;
1058 return $error if $error;
1060 # Encrypt for replace
1061 my $conf = new FS::Conf;
1063 if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . '::encrypted_fields')) {
1064 foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
1065 $saved->{$field} = $new->getfield($field);
1066 $new->setfield($field, $new->encrypt($new->getfield($field)));
1070 #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
1071 my %diff = map { ($new->getfield($_) ne $old->getfield($_))
1072 ? ($_, $new->getfield($_)) : () } $old->fields;
1074 unless (keys(%diff) || $no_update_diff ) {
1075 carp "[warning]$me $new -> replace $old: records identical"
1076 unless $nowarn_identical;
1080 my $statement = "UPDATE ". $old->table. " SET ". join(', ',
1082 "$_ = ". _quote($new->getfield($_),$old->table,$_)
1083 } real_fields($old->table)
1088 if ( $old->getfield($_) eq '' ) {
1090 #false laziness w/qsearch
1091 if ( driver_name eq 'Pg' ) {
1092 my $type = $old->dbdef_table->column($_)->type;
1093 if ( $type =~ /(int|(big)?serial)/i ) {
1096 qq-( $_ IS NULL OR $_ = '' )-;
1099 qq-( $_ IS NULL OR $_ = "" )-;
1103 "$_ = ". _quote($old->getfield($_),$old->table,$_);
1106 } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
1109 warn "[debug]$me $statement\n" if $DEBUG > 1;
1110 my $sth = dbh->prepare($statement) or return dbh->errstr;
1113 if ( defined dbdef->table('h_'. $old->table) ) {
1114 my $h_old_statement = $old->_h_statement('replace_old');
1115 warn "[debug]$me $h_old_statement\n" if $DEBUG > 2;
1116 $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr;
1122 if ( defined dbdef->table('h_'. $new->table) ) {
1123 my $h_new_statement = $new->_h_statement('replace_new');
1124 warn "[debug]$me $h_new_statement\n" if $DEBUG > 2;
1125 $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr;
1130 # For virtual fields we have three cases with different SQL
1131 # statements: add, replace, delete
1135 my (@add_vfields, @rep_vfields, @del_vfields);
1136 my $vfp = $old->vfieldpart_hashref;
1137 foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
1138 if($diff{$_} eq '') {
1140 unless(@del_vfields) {
1141 my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
1142 "AND vfieldpart = ?";
1143 warn "[debug]$me $st\n" if $DEBUG > 2;
1144 $v_del_sth = dbh->prepare($st) or return dbh->errstr;
1146 push @del_vfields, $_;
1147 } elsif($old->getfield($_) eq '') {
1149 unless(@add_vfields) {
1150 my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
1152 warn "[debug]$me $st\n" if $DEBUG > 2;
1153 $v_add_sth = dbh->prepare($st) or return dbh->errstr;
1155 push @add_vfields, $_;
1158 unless(@rep_vfields) {
1159 my $st = "UPDATE virtual_field SET value = ? ".
1160 "WHERE recnum = ? AND vfieldpart = ?";
1161 warn "[debug]$me $st\n" if $DEBUG > 2;
1162 $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
1164 push @rep_vfields, $_;
1168 local $SIG{HUP} = 'IGNORE';
1169 local $SIG{INT} = 'IGNORE';
1170 local $SIG{QUIT} = 'IGNORE';
1171 local $SIG{TERM} = 'IGNORE';
1172 local $SIG{TSTP} = 'IGNORE';
1173 local $SIG{PIPE} = 'IGNORE';
1175 my $rc = $sth->execute or return $sth->errstr;
1176 #not portable #return "Record not found (or records identical)." if $rc eq "0E0";
1177 $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth;
1178 $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth;
1180 $v_del_sth->execute($old->getfield($primary_key),
1182 or return $v_del_sth->errstr
1183 foreach(@del_vfields);
1185 $v_add_sth->execute($new->getfield($_),
1186 $old->getfield($primary_key),
1188 or return $v_add_sth->errstr
1189 foreach(@add_vfields);
1191 $v_rep_sth->execute($new->getfield($_),
1192 $old->getfield($primary_key),
1194 or return $v_rep_sth->errstr
1195 foreach(@rep_vfields);
1197 dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
1199 # Now that it has been saved, reset the encrypted fields so that $new
1200 # can still be used.
1201 foreach my $field (keys %{$saved}) {
1202 $new->setfield($field, $saved->{$field});
1210 my( $self ) = shift;
1211 warn "[$me] replace called with no arguments; autoloading old record\n"
1214 my $primary_key = $self->dbdef_table->primary_key;
1215 if ( $primary_key ) {
1216 $self->by_key( $self->$primary_key() ) #this is what's returned
1217 or croak "can't find ". $self->table. ".$primary_key ".
1218 $self->$primary_key();
1220 croak $self->table. " has no primary key; pass old record as argument";
1227 Depriciated (use replace instead).
1232 cluck "warning: FS::Record::rep deprecated!";
1233 replace @_; #call method in this scope
1238 Checks virtual fields (using check_blocks). Subclasses should still provide
1239 a check method to validate real fields, foreign keys, etc., and call this
1240 method via $self->SUPER::check.
1242 (FIXME: Should this method try to make sure that it I<is> being called from
1243 a subclass's check method, to keep the current semantics as far as possible?)
1248 #confess "FS::Record::check not implemented; supply one in subclass!";
1251 foreach my $field ($self->virtual_fields) {
1252 for ($self->getfield($field)) {
1253 # See notes on check_block in FS::part_virtual_field.
1254 eval $self->pvf($field)->check_block;
1256 #this is bad, probably want to follow the stack backtrace up and see
1258 my $err = "Fatal error checking $field for $self";
1260 return "$err (see log for backtrace): $@";
1263 $self->setfield($field, $_);
1270 my( $self, $action, $time ) = @_;
1275 grep { defined($self->getfield($_)) && $self->getfield($_) ne "" }
1276 real_fields($self->table);
1279 # If we're encrypting then don't ever store the payinfo or CVV2 in the history....
1280 # You can see if it changed by the paymask...
1281 my $conf = new FS::Conf;
1282 if ($conf->exists('encryption') ) {
1283 @fields = grep $_ ne 'payinfo' && $_ ne 'cvv2', @fields;
1285 my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
1287 "INSERT INTO h_". $self->table. " ( ".
1288 join(', ', qw(history_date history_user history_action), @fields ).
1290 join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
1297 B<Warning>: External use is B<deprecated>.
1299 Replaces COLUMN in record with a unique number, using counters in the
1300 filesystem. Used by the B<insert> method on single-field unique columns
1301 (see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
1302 that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
1304 Returns the new value.
1309 my($self,$field) = @_;
1310 my($table)=$self->table;
1312 croak "Unique called on field $field, but it is ",
1313 $self->getfield($field),
1315 if $self->getfield($field);
1317 #warn "table $table is tainted" if is_tainted($table);
1318 #warn "field $field is tainted" if is_tainted($field);
1320 my($counter) = new File::CounterFile "$table.$field",0;
1322 # getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!";
1324 # my($counter) = new File::CounterFile "$user/$table.$field",0;
1327 my $index = $counter->inc;
1328 $index = $counter->inc while qsearchs($table, { $field=>$index } );
1330 $index =~ /^(\d*)$/;
1333 $self->setfield($field,$index);
1337 =item ut_float COLUMN
1339 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May not be
1340 null. If there is an error, returns the error, otherwise returns false.
1345 my($self,$field)=@_ ;
1346 ($self->getfield($field) =~ /^(\d+\.\d+)$/ ||
1347 $self->getfield($field) =~ /^(\d+)$/ ||
1348 $self->getfield($field) =~ /^(\d+\.\d+e\d+)$/ ||
1349 $self->getfield($field) =~ /^(\d+e\d+)$/)
1350 or return "Illegal or empty (float) $field: ". $self->getfield($field);
1351 $self->setfield($field,$1);
1354 =item ut_floatn COLUMN
1356 Check/untaint floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
1357 null. If there is an error, returns the error, otherwise returns false.
1361 #false laziness w/ut_ipn
1363 my( $self, $field ) = @_;
1364 if ( $self->getfield($field) =~ /^()$/ ) {
1365 $self->setfield($field,'');
1368 $self->ut_float($field);
1372 =item ut_sfloat COLUMN
1374 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10.
1375 May not be null. If there is an error, returns the error, otherwise returns
1381 my($self,$field)=@_ ;
1382 ($self->getfield($field) =~ /^(-?\d+\.\d+)$/ ||
1383 $self->getfield($field) =~ /^(-?\d+)$/ ||
1384 $self->getfield($field) =~ /^(-?\d+\.\d+[eE]-?\d+)$/ ||
1385 $self->getfield($field) =~ /^(-?\d+[eE]-?\d+)$/)
1386 or return "Illegal or empty (float) $field: ". $self->getfield($field);
1387 $self->setfield($field,$1);
1390 =item ut_sfloatn COLUMN
1392 Check/untaint signed floating point numeric data: 1.1, 1, 1.1e10, 1e10. May be
1393 null. If there is an error, returns the error, otherwise returns false.
1398 my( $self, $field ) = @_;
1399 if ( $self->getfield($field) =~ /^()$/ ) {
1400 $self->setfield($field,'');
1403 $self->ut_sfloat($field);
1407 =item ut_snumber COLUMN
1409 Check/untaint signed numeric data (whole numbers). If there is an error,
1410 returns the error, otherwise returns false.
1415 my($self, $field) = @_;
1416 $self->getfield($field) =~ /^(-?)\s*(\d+)$/
1417 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1418 $self->setfield($field, "$1$2");
1422 =item ut_snumbern COLUMN
1424 Check/untaint signed numeric data (whole numbers). If there is an error,
1425 returns the error, otherwise returns false.
1430 my($self, $field) = @_;
1431 $self->getfield($field) =~ /^(-?)\s*(\d*)$/
1432 or return "Illegal (numeric) $field: ". $self->getfield($field);
1434 return "Illegal (numeric) $field: ". $self->getfield($field)
1437 $self->setfield($field, "$1$2");
1441 =item ut_number COLUMN
1443 Check/untaint simple numeric data (whole numbers). May not be null. If there
1444 is an error, returns the error, otherwise returns false.
1449 my($self,$field)=@_;
1450 $self->getfield($field) =~ /^(\d+)$/
1451 or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
1452 $self->setfield($field,$1);
1456 =item ut_numbern COLUMN
1458 Check/untaint simple numeric data (whole numbers). May be null. If there is
1459 an error, returns the error, otherwise returns false.
1464 my($self,$field)=@_;
1465 $self->getfield($field) =~ /^(\d*)$/
1466 or return "Illegal (numeric) $field: ". $self->getfield($field);
1467 $self->setfield($field,$1);
1471 =item ut_money COLUMN
1473 Check/untaint monetary numbers. May be negative. Set to 0 if null. If there
1474 is an error, returns the error, otherwise returns false.
1479 my($self,$field)=@_;
1480 $self->setfield($field, 0) if $self->getfield($field) eq '';
1481 $self->getfield($field) =~ /^(\-)? ?(\d*)(\.\d{2})?$/
1482 or return "Illegal (money) $field: ". $self->getfield($field);
1483 #$self->setfield($field, "$1$2$3" || 0);
1484 $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0);
1488 =item ut_text COLUMN
1490 Check/untaint text. Alphanumerics, spaces, and the following punctuation
1491 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ]
1492 May not be null. If there is an error, returns the error, otherwise returns
1498 my($self,$field)=@_;
1499 #warn "msgcat ". \&msgcat. "\n";
1500 #warn "notexist ". \¬exist. "\n";
1501 #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
1502 $self->getfield($field)
1503 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]+)$/
1504 or return gettext('illegal_or_empty_text'). " $field: ".
1505 $self->getfield($field);
1506 $self->setfield($field,$1);
1510 =item ut_textn COLUMN
1512 Check/untaint text. Alphanumerics, spaces, and the following punctuation
1513 symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? /
1514 May be null. If there is an error, returns the error, otherwise returns false.
1519 my($self,$field)=@_;
1520 $self->getfield($field)
1521 =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/
1522 or return gettext('illegal_text'). " $field: ". $self->getfield($field);
1523 $self->setfield($field,$1);
1527 =item ut_alpha COLUMN
1529 Check/untaint alphanumeric strings (no spaces). May not be null. If there is
1530 an error, returns the error, otherwise returns false.
1535 my($self,$field)=@_;
1536 $self->getfield($field) =~ /^(\w+)$/
1537 or return "Illegal or empty (alphanumeric) $field: ".
1538 $self->getfield($field);
1539 $self->setfield($field,$1);
1543 =item ut_alpha COLUMN
1545 Check/untaint alphanumeric strings (no spaces). May be null. If there is an
1546 error, returns the error, otherwise returns false.
1551 my($self,$field)=@_;
1552 $self->getfield($field) =~ /^(\w*)$/
1553 or return "Illegal (alphanumeric) $field: ". $self->getfield($field);
1554 $self->setfield($field,$1);
1558 =item ut_phonen COLUMN [ COUNTRY ]
1560 Check/untaint phone numbers. May be null. If there is an error, returns
1561 the error, otherwise returns false.
1563 Takes an optional two-letter ISO country code; without it or with unsupported
1564 countries, ut_phonen simply calls ut_alphan.
1569 my( $self, $field, $country ) = @_;
1570 return $self->ut_alphan($field) unless defined $country;
1571 my $phonen = $self->getfield($field);
1572 if ( $phonen eq '' ) {
1573 $self->setfield($field,'');
1574 } elsif ( $country eq 'US' || $country eq 'CA' ) {
1576 $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/
1577 or return gettext('illegal_phone'). " $field: ". $self->getfield($field);
1578 $phonen = "$1-$2-$3";
1579 $phonen .= " x$4" if $4;
1580 $self->setfield($field,$phonen);
1582 warn "warning: don't know how to check phone numbers for country $country";
1583 return $self->ut_textn($field);
1590 Check/untaint hexadecimal values.
1595 my($self, $field) = @_;
1596 $self->getfield($field) =~ /^([\da-fA-F]+)$/
1597 or return "Illegal (hex) $field: ". $self->getfield($field);
1598 $self->setfield($field, uc($1));
1602 =item ut_hexn COLUMN
1604 Check/untaint hexadecimal values. May be null.
1609 my($self, $field) = @_;
1610 $self->getfield($field) =~ /^([\da-fA-F]*)$/
1611 or return "Illegal (hex) $field: ". $self->getfield($field);
1612 $self->setfield($field, uc($1));
1617 Check/untaint ip addresses. IPv4 only for now.
1622 my( $self, $field ) = @_;
1623 $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/
1624 or return "Illegal (IP address) $field: ". $self->getfield($field);
1625 for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; }
1626 $self->setfield($field, "$1.$2.$3.$4");
1632 Check/untaint ip addresses. IPv4 only for now. May be null.
1637 my( $self, $field ) = @_;
1638 if ( $self->getfield($field) =~ /^()$/ ) {
1639 $self->setfield($field,'');
1642 $self->ut_ip($field);
1646 =item ut_coord COLUMN [ LOWER [ UPPER ] ]
1648 Check/untaint coordinates.
1649 Accepts the following forms:
1659 The "DDD MM SS" and "DDD MM MMM" are potentially ambiguous.
1660 The latter form (that is, the MMM are thousands of minutes) is
1661 assumed if the "MMM" is exactly three digits or two digits > 59.
1663 To be safe, just use the DDD.DDDDD form.
1665 If LOWER or UPPER are specified, then the coordinate is checked
1666 for lower and upper bounds, respectively.
1672 my ($self, $field) = (shift, shift);
1674 my $lower = shift if scalar(@_);
1675 my $upper = shift if scalar(@_);
1676 my $coord = $self->getfield($field);
1677 my $neg = $coord =~ s/^(-)//;
1679 my ($d, $m, $s) = (0, 0, 0);
1682 (($d) = ($coord =~ /^(\s*\d{1,3}(?:\.\d+)?)\s*$/)) ||
1683 (($d, $m) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2}(?:\.\d+))\s*$/)) ||
1684 (($d, $m, $s) = ($coord =~ /^(\s*\d{1,3})\s+(\d{1,2})\s+(\d{1,3})\s*$/))
1686 $s = (((($s =~ /^\d{3}$/) or $s > 59) ? ($s / 1000) : ($s / 60)) / 60);
1689 return "Invalid (coordinate with minutes > 59) $field: "
1690 . $self->getfield($field);
1693 $coord = ($neg ? -1 : 1) * sprintf('%.8f', $d + $m + $s);
1695 if (defined($lower) and ($coord < $lower)) {
1696 return "Invalid (coordinate < $lower) $field: "
1697 . $self->getfield($field);;
1700 if (defined($upper) and ($coord > $upper)) {
1701 return "Invalid (coordinate > $upper) $field: "
1702 . $self->getfield($field);;
1705 $self->setfield($field, $coord);
1709 return "Invalid (coordinate) $field: " . $self->getfield($field);
1713 =item ut_coordn COLUMN [ LOWER [ UPPER ] ]
1715 Same as ut_coord, except optionally null.
1721 my ($self, $field) = (shift, shift);
1723 if ($self->getfield($field) =~ /^$/) {
1726 return $self->ut_coord($field, @_);
1732 =item ut_domain COLUMN
1734 Check/untaint host and domain names.
1739 my( $self, $field ) = @_;
1740 #$self->getfield($field) =~/^(\w+\.)*\w+$/
1741 $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/
1742 or return "Illegal (domain) $field: ". $self->getfield($field);
1743 $self->setfield($field,$1);
1747 =item ut_name COLUMN
1749 Check/untaint proper names; allows alphanumerics, spaces and the following
1750 punctuation: , . - '
1757 my( $self, $field ) = @_;
1758 $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
1759 or return gettext('illegal_name'). " $field: ". $self->getfield($field);
1760 $self->setfield($field,$1);
1766 Check/untaint zip codes.
1770 my @zip_reqd_countries = qw( AU CA US ); #CA, US implicit...
1773 my( $self, $field, $country ) = @_;
1775 if ( $country eq 'US' ) {
1777 $self->getfield($field) =~ /^\s*(\d{5}(\-\d{4})?)\s*$/
1778 or return gettext('illegal_zip'). " $field for country $country: ".
1779 $self->getfield($field);
1780 $self->setfield($field, $1);
1782 } elsif ( $country eq 'CA' ) {
1784 $self->getfield($field) =~ /^\s*([A-Z]\d[A-Z])\s*(\d[A-Z]\d)\s*$/i
1785 or return gettext('illegal_zip'). " $field for country $country: ".
1786 $self->getfield($field);
1787 $self->setfield($field, "$1 $2");
1791 if ( $self->getfield($field) =~ /^\s*$/
1792 && ( !$country || ! grep { $_ eq $country } @zip_reqd_countries )
1795 $self->setfield($field,'');
1797 $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
1798 or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
1799 $self->setfield($field,$1);
1807 =item ut_country COLUMN
1809 Check/untaint country codes. Country names are changed to codes, if possible -
1810 see L<Locale::Country>.
1815 my( $self, $field ) = @_;
1816 unless ( $self->getfield($field) =~ /^(\w\w)$/ ) {
1817 if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/
1818 && country2code($1) ) {
1819 $self->setfield($field,uc(country2code($1)));
1822 $self->getfield($field) =~ /^(\w\w)$/
1823 or return "Illegal (country) $field: ". $self->getfield($field);
1824 $self->setfield($field,uc($1));
1828 =item ut_anything COLUMN
1830 Untaints arbitrary data. Be careful.
1835 my( $self, $field ) = @_;
1836 $self->getfield($field) =~ /^(.*)$/s
1837 or return "Illegal $field: ". $self->getfield($field);
1838 $self->setfield($field,$1);
1842 =item ut_enum COLUMN CHOICES_ARRAYREF
1844 Check/untaint a column, supplying all possible choices, like the "enum" type.
1849 my( $self, $field, $choices ) = @_;
1850 foreach my $choice ( @$choices ) {
1851 if ( $self->getfield($field) eq $choice ) {
1852 $self->setfield($choice);
1856 return "Illegal (enum) field $field: ". $self->getfield($field);
1859 =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN
1861 Check/untaint a foreign column key. Call a regular ut_ method (like ut_number)
1862 on the column first.
1866 sub ut_foreign_key {
1867 my( $self, $field, $table, $foreign ) = @_;
1868 qsearchs($table, { $foreign => $self->getfield($field) })
1869 or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
1870 " in $table.$foreign";
1874 =item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN
1876 Like ut_foreign_key, except the null value is also allowed.
1880 sub ut_foreign_keyn {
1881 my( $self, $field, $table, $foreign ) = @_;
1882 $self->getfield($field)
1883 ? $self->ut_foreign_key($field, $table, $foreign)
1887 =item ut_agentnum_acl
1889 Checks this column as an agentnum, taking into account the current users's
1894 sub ut_agentnum_acl {
1895 my( $self, $field, $null_acl ) = @_;
1897 my $error = $self->ut_foreign_keyn($field, 'agent', 'agentnum');
1898 return "Illegal agentnum: $error" if $error;
1900 my $curuser = $FS::CurrentUser::CurrentUser;
1902 if ( $self->$field() ) {
1904 return "Access deined"
1905 unless $curuser->agentnum($self->$field());
1909 return "Access denied"
1910 unless $curuser->access_right($null_acl);
1918 =item virtual_fields [ TABLE ]
1920 Returns a list of virtual fields defined for the table. This should not
1921 be exported, and should only be called as an instance or class method.
1925 sub virtual_fields {
1928 $table = $self->table or confess "virtual_fields called on non-table";
1930 confess "Unknown table $table" unless dbdef->table($table);
1932 return () unless dbdef->table('part_virtual_field');
1934 unless ( $virtual_fields_cache{$table} ) {
1935 my $query = 'SELECT name from part_virtual_field ' .
1936 "WHERE dbtable = '$table'";
1938 my $result = $dbh->selectcol_arrayref($query);
1939 confess "Error executing virtual fields query: $query: ". $dbh->errstr
1941 $virtual_fields_cache{$table} = $result;
1944 @{$virtual_fields_cache{$table}};
1949 =item fields [ TABLE ]
1951 This is a wrapper for real_fields and virtual_fields. Code that called
1952 fields before should probably continue to call fields.
1957 my $something = shift;
1959 if($something->isa('FS::Record')) {
1960 $table = $something->table;
1962 $table = $something;
1963 $something = "FS::$table";
1965 return (real_fields($table), $something->virtual_fields());
1970 =item pvf FIELD_NAME
1972 Returns the FS::part_virtual_field object corresponding to a field in the
1973 record (specified by FIELD_NAME).
1978 my ($self, $name) = (shift, shift);
1980 if(grep /^$name$/, $self->virtual_fields) {
1981 return qsearchs('part_virtual_field', { dbtable => $self->table,
1991 =item real_fields [ TABLE ]
1993 Returns a list of the real columns in the specified table. Called only by
1994 fields() and other subroutines elsewhere in FS::Record.
2001 my($table_obj) = dbdef->table($table);
2002 confess "Unknown table $table" unless $table_obj;
2003 $table_obj->columns;
2006 =item _quote VALUE, TABLE, COLUMN
2008 This is an internal function used to construct SQL statements. It returns
2009 VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
2010 type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
2015 my($value, $table, $column) = @_;
2016 my $column_obj = dbdef->table($table)->column($column);
2017 my $column_type = $column_obj->type;
2018 my $nullable = $column_obj->null;
2020 warn " $table.$column: $value ($column_type".
2021 ( $nullable ? ' NULL' : ' NOT NULL' ).
2022 ")\n" if $DEBUG > 2;
2024 if ( $value eq '' && $nullable ) {
2026 } elsif ( $value eq '' && $column_type =~ /^(int|numeric)/ ) {
2027 cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
2030 } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
2031 ! $column_type =~ /(char|binary|text)$/i ) {
2038 =item vfieldpart_hashref TABLE
2040 Returns a hashref of virtual field names and vfieldparts applicable to the given
2045 sub vfieldpart_hashref {
2047 my $table = $self->table;
2049 return {} unless dbdef->table('part_virtual_field');
2052 my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
2053 "dbtable = '$table'";
2054 my $sth = $dbh->prepare($statement);
2055 $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
2056 return { map { $_->{name}, $_->{vfieldpart} }
2057 @{$sth->fetchall_arrayref({})} };
2064 This is deprecated. Don't use it.
2066 It returns a hash-type list with the fields of this record's table set true.
2071 carp "warning: hfields is deprecated";
2074 foreach (fields($table)) {
2083 "$_: ". $self->getfield($_). "|"
2084 } (fields($self->table)) );
2087 =item encrypt($value)
2089 Encrypts the credit card using a combination of PK to encrypt and uuencode to armour.
2091 Returns the encrypted string.
2093 You should generally not have to worry about calling this, as the system handles this for you.
2099 my ($self, $value) = @_;
2102 my $conf = new FS::Conf;
2103 if ($conf->exists('encryption')) {
2104 if ($self->is_encrypted($value)) {
2105 # Return the original value if it isn't plaintext.
2106 $encrypted = $value;
2109 if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
2110 # RSA doesn't like the empty string so let's pack it up
2111 # The database doesn't like the RSA data so uuencode it
2112 my $length = length($value)+1;
2113 $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
2115 die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
2122 =item is_encrypted($value)
2124 Checks to see if the string is encrypted and returns true or false (1/0) to indicate it's status.
2130 my ($self, $value) = @_;
2131 # Possible Bug - Some work may be required here....
2133 if ($value =~ /^M/ && length($value) > 80) {
2140 =item decrypt($value)
2142 Uses the private key to decrypt the string. Returns the decryoted string or undef on failure.
2144 You should generally not have to worry about calling this, as the system handles this for you.
2149 my ($self,$value) = @_;
2150 my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
2151 my $conf = new FS::Conf;
2152 if ($conf->exists('encryption') && $self->is_encrypted($value)) {
2154 if (ref($rsa_decrypt) =~ /::RSA/) {
2155 my $encrypted = unpack ("u*", $value);
2156 $decrypted = unpack("Z*", eval{$rsa_decrypt->decrypt($encrypted)});
2157 if ($@) {warn "Decryption Failed"};
2165 #Initialize the Module
2166 $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
2168 my $conf = new FS::Conf;
2169 if ($conf->exists('encryptionmodule') && $conf->config_binary('encryptionmodule') ne '') {
2170 $rsa_module = $conf->config('encryptionmodule');
2174 eval ("require $rsa_module"); # No need to import the namespace
2177 # Initialize Encryption
2178 if ($conf->exists('encryptionpublickey') && $conf->config_binary('encryptionpublickey') ne '') {
2179 my $public_key = join("\n",$conf->config('encryptionpublickey'));
2180 $rsa_encrypt = $rsa_module->new_public_key($public_key);
2183 # Intitalize Decryption
2184 if ($conf->exists('encryptionprivatekey') && $conf->config_binary('encryptionprivatekey') ne '') {
2185 my $private_key = join("\n",$conf->config('encryptionprivatekey'));
2186 $rsa_decrypt = $rsa_module->new_private_key($private_key);
2190 sub DESTROY { return; }
2194 # #use Carp qw(cluck);
2195 # #cluck "DESTROYING $self";
2196 # warn "DESTROYING $self";
2200 # return ! eval { join('',@_), kill 0; 1; };
2207 This module should probably be renamed, since much of the functionality is
2208 of general use. It is not completely unlike Adapter::DBI (see below).
2210 Exported qsearch and qsearchs should be deprecated in favor of method calls
2211 (against an FS::Record object like the old search and searchs that qsearch
2212 and qsearchs were on top of.)
2214 The whole fields / hfields mess should be removed.
2216 The various WHERE clauses should be subroutined.
2218 table string should be deprecated in favor of DBIx::DBSchema::Table.
2220 No doubt we could benefit from a Tied hash. Documenting how exists / defined
2221 true maps to the database (and WHERE clauses) would also help.
2223 The ut_ methods should ask the dbdef for a default length.
2225 ut_sqltype (like ut_varchar) should all be defined
2227 A fallback check method should be provided which uses the dbdef.
2229 The ut_money method assumes money has two decimal digits.
2231 The Pg money kludge in the new method only strips `$'.
2233 The ut_phonen method only checks US-style phone numbers.
2235 The _quote function should probably use ut_float instead of a regex.
2237 All the subroutines probably should be methods, here or elsewhere.
2239 Probably should borrow/use some dbdef methods where appropriate (like sub
2242 As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc,
2243 or allow it to be set. Working around it is ugly any way around - DBI should
2244 be fixed. (only affects RDBMS which return uppercase column names)
2246 ut_zip should take an optional country like ut_phone.
2250 L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
2252 Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.