X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=7d5ff0582667bd5346f7ee3649bda7d046817fc8;hp=755cef8303175f90a9bf5976b97c57d4c746ae9b;hb=25747983ac27c3b804a2f15312c8c7b59769e014;hpb=b6c28c086832416944440cab39f3bffc9d3dd1f1 diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index 755cef830..7d5ff0582 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -2,7 +2,7 @@ package FS::Record; use strict; use vars qw( $dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK $DEBUG - $me ); + $me %dbdef_cache ); use subs qw(reload_dbdef); use Exporter; use Carp qw(carp cluck croak confess); @@ -12,6 +12,7 @@ use DBI qw(:sql_types); use DBIx::DBSchema 0.19; use FS::UID qw(dbh checkruid getotaker datasrc driver_name); use FS::SearchCache; +use FS::Msgcat qw(gettext); @ISA = qw(Exporter); @EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch); @@ -59,13 +60,13 @@ FS::Record - Database record objects $hashref = $record->hashref; $error = $record->insert; - #$error = $record->add; #depriciated + #$error = $record->add; #deprecated $error = $record->delete; - #$error = $record->del; #depriciated + #$error = $record->del; #deprecated $error = $new_record->replace($old_record); - #$error = $new_record->rep($old_record); #depriciated + #$error = $new_record->rep($old_record); #deprecated $value = $record->unique('column'); @@ -180,7 +181,7 @@ sub create { } } -=item qsearch TABLE, HASHREF, SELECT, EXTRA_SQL +=item qsearch TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ Searches the database for all records matching (at least) the key/value pairs in HASHREF. Returns all the records found as `FS::TABLE' objects if that @@ -214,14 +215,36 @@ sub qsearch { my $statement = "SELECT $select FROM $stable"; if ( @fields ) { $statement .= ' WHERE '. join(' AND ', map { + + my $op = '='; + if ( ref($record->{$_}) ) { + $op = $record->{$_}{'op'} if $record->{$_}{'op'}; + $op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name !~ /^Pg$/i; + $record->{$_} = $record->{$_}{'value'} + } + if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) { - if ( driver_name =~ /^Pg$/i ) { - qq-( $_ IS NULL OR $_ = '' )-; + if ( $op eq '=' ) { + if ( driver_name =~ /^Pg$/i ) { + qq-( $_ IS NULL OR $_ = '' )-; + } else { + qq-( $_ IS NULL OR $_ = "" )-; + } + } elsif ( $op eq '!=' ) { + if ( driver_name =~ /^Pg$/i ) { + qq-( $_ IS NOT NULL AND $_ != '' )-; + } else { + qq-( $_ IS NOT NULL AND $_ != "" )-; + } } else { - qq-( $_ IS NULL OR $_ = "" )-; + if ( driver_name =~ /^Pg$/i ) { + qq-( $_ $op '' )-; + } else { + qq-( $_ $op "" )-; + } } } else { - "$_ = ?"; + "$_ $op ?"; } } @fields ); } @@ -336,7 +359,7 @@ sub table { =item dbdef_table -Returns the FS::dbdef_table object for the table. +Returns the DBIx::DBSchema::Table object for the table. =cut @@ -390,32 +413,32 @@ $record->column('value') is a synonym for $record->set('column','value'); =cut # readable/safe -#sub AUTOLOAD { -# my($self,$value)=@_; -# my($field)=$AUTOLOAD; -# $field =~ s/.*://; -# if ( defined($value) ) { -# confess "errant AUTOLOAD $field for $self (arg $value)" -# unless $self->can('setfield'); -# $self->setfield($field,$value); -# } else { -# confess "errant AUTOLOAD $field for $self (no args)" -# unless $self->can('getfield'); -# $self->getfield($field); -# } -#} - -# efficient sub AUTOLOAD { - my $field = $AUTOLOAD; + my($self,$value)=@_; + my($field)=$AUTOLOAD; $field =~ s/.*://; - if ( defined($_[1]) ) { - $_[0]->setfield($field, $_[1]); + if ( defined($value) ) { + confess "errant AUTOLOAD $field for $self (arg $value)" + unless $self->can('setfield'); + $self->setfield($field,$value); } else { - $_[0]->getfield($field); + confess "errant AUTOLOAD $field for $self (no args)" + unless $self->can('getfield'); + $self->getfield($field); } } +# efficient +#sub AUTOLOAD { +# my $field = $AUTOLOAD; +# $field =~ s/.*://; +# if ( defined($_[1]) ) { +# $_[0]->setfield($field, $_[1]); +# } else { +# $_[0]->getfield($field); +# } +#} + =item hash Returns a list of the column/value pairs, usually for assigning to a new hash. @@ -465,20 +488,32 @@ sub insert { $self->unique($primary_key) if $primary_key && ! $self->getfield($primary_key); + #false laziness w/delete my @fields = grep defined($self->getfield($_)) && $self->getfield($_) ne "", $self->fields ; + my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields; + #eslaf my $statement = "INSERT INTO ". $self->table. " ( ". - join(', ',@fields ). + join( ', ', @fields ). ") VALUES (". - join(', ',map(_quote($self->getfield($_),$self->table,$_), @fields)). + join( ', ', @values ). ")" ; warn "[debug]$me $statement\n" if $DEBUG; my $sth = dbh->prepare($statement) or return dbh->errstr; + my $h_sth; + if ( defined $dbdef->table('h_'. $self->table) ) { + my $h_statement = $self->_h_statement('insert'); + warn "[debug]$me $h_statement\n" if $DEBUG; + $h_sth = dbh->prepare($h_statement) or return dbh->errstr; + } else { + $h_sth = ''; + } + local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; local $SIG{QUIT} = 'IGNORE'; @@ -487,6 +522,7 @@ sub insert { local $SIG{PIPE} = 'IGNORE'; $sth->execute or return $sth->errstr; + $h_sth->execute or return $h_sth->errstr if $h_sth; dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit; ''; @@ -513,7 +549,7 @@ otherwise returns false. sub delete { my $self = shift; - my($statement)="DELETE FROM ". $self->table. " WHERE ". join(' AND ', + my $statement = "DELETE FROM ". $self->table. " WHERE ". join(' AND ', map { $self->getfield($_) eq '' #? "( $_ IS NULL OR $_ = \"\" )" @@ -529,6 +565,15 @@ sub delete { warn "[debug]$me $statement\n" if $DEBUG; my $sth = dbh->prepare($statement) or return dbh->errstr; + my $h_sth; + if ( defined $dbdef->table('h_'. $self->table) ) { + my $h_statement = $self->_h_statement('delete'); + warn "[debug]$me $h_statement\n" if $DEBUG; + $h_sth = dbh->prepare($h_statement) or return dbh->errstr; + } else { + $h_sth = ''; + } + local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; local $SIG{QUIT} = 'IGNORE'; @@ -538,9 +583,11 @@ sub delete { my $rc = $sth->execute or return $sth->errstr; #not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0"; + $h_sth->execute or return $h_sth->errstr if $h_sth; dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit; - undef $self; #no need to keep object! + #no need to needlessly destoy the data either (causes problems actually) + #undef $self; #no need to keep object! ''; } @@ -567,12 +614,6 @@ sub replace { my ( $new, $old ) = ( shift, shift ); warn "[debug]$me $new ->replace $old\n" if $DEBUG; - my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields; - unless ( @diff ) { - carp "[warning]$me $new -> replace $old: records identical"; - return ''; - } - return "Records not in same table!" unless $new->table eq $old->table; my $primary_key = $old->dbdef_table->primary_key; @@ -583,6 +624,12 @@ sub replace { my $error = $new->check; return $error if $error; + my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields; + unless ( @diff ) { + carp "[warning]$me $new -> replace $old: records identical"; + return ''; + } + my $statement = "UPDATE ". $old->table. " SET ". join(', ', map { "$_ = ". _quote($new->getfield($_),$old->table,$_) @@ -603,6 +650,24 @@ sub replace { warn "[debug]$me $statement\n" if $DEBUG; my $sth = dbh->prepare($statement) or return dbh->errstr; + my $h_old_sth; + if ( defined $dbdef->table('h_'. $old->table) ) { + my $h_old_statement = $old->_h_statement('replace_old'); + warn "[debug]$me $h_old_statement\n" if $DEBUG; + $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr; + } else { + $h_old_sth = ''; + } + + my $h_new_sth; + if ( defined $dbdef->table('h_'. $new->table) ) { + my $h_new_statement = $new->_h_statement('replace_new'); + warn "[debug]$me $h_new_statement\n" if $DEBUG; + $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr; + } else { + $h_new_sth = ''; + } + local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; local $SIG{QUIT} = 'IGNORE'; @@ -612,6 +677,8 @@ sub replace { my $rc = $sth->execute or return $sth->errstr; #not portable #return "Record not found (or records identical)." if $rc eq "0E0"; + $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth; + $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth; dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit; ''; @@ -639,6 +706,23 @@ sub check { confess "FS::Record::check not implemented; supply one in subclass!"; } +sub _h_statement { + my( $self, $action ) = @_; + + my @fields = + grep defined($self->getfield($_)) && $self->getfield($_) ne "", + $self->fields + ; + my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields; + + "INSERT INTO h_". $self->table. " ( ". + join(', ', qw(history_date history_user history_action), @fields ). + ") VALUES (". + join(', ', time, dbh->quote(getotaker()), dbh->quote($action), @values). + ")" + ; +} + =item unique COLUMN Replaces COLUMN in record with a unique number. Called by the B method @@ -747,7 +831,7 @@ sub ut_money { =item ut_text COLUMN Check/untaint text. Alphanumerics, spaces, and the following punctuation -symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / +symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = May not be null. If there is an error, returns the error, otherwise returns false. @@ -755,8 +839,12 @@ false. sub ut_text { my($self,$field)=@_; - $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/]+)$/ - or return "Illegal or empty (text) $field: ". $self->getfield($field); + #warn "msgcat ". \&msgcat. "\n"; + #warn "notexist ". \¬exist. "\n"; + #warn "AUTOLOAD ". \&AUTOLOAD. "\n"; + $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=]+)$/ + or return gettext('illegal_or_empty_text'). " $field: ". + $self->getfield($field); $self->setfield($field,$1); ''; } @@ -771,8 +859,8 @@ May be null. If there is an error, returns the error, otherwise returns false. sub ut_textn { my($self,$field)=@_; - $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/]*)$/ - or return "Illegal (text) $field: ". $self->getfield($field); + $self->getfield($field) =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=]*)$/ + or return gettext('illegal_text'). " $field: ". $self->getfield($field); $self->setfield($field,$1); ''; } @@ -827,7 +915,7 @@ sub ut_phonen { } elsif ( $country eq 'US' || $country eq 'CA' ) { $phonen =~ s/\D//g; $phonen =~ /^(\d{3})(\d{3})(\d{4})(\d*)$/ - or return "Illegal (phone) $field: ". $self->getfield($field); + or return gettext('illegal_phone'). " $field: ". $self->getfield($field); $phonen = "$1-$2-$3"; $phonen .= " x$4" if $4; $self->setfield($field,$phonen); @@ -878,7 +966,7 @@ Check/untaint host and domain names. sub ut_domain { my( $self, $field ) = @_; #$self->getfield($field) =~/^(\w+\.)*\w+$/ - $self->getfield($field) =~/^(\w+\.)*\w+$/ + $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/ or return "Illegal (domain) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; @@ -896,7 +984,7 @@ May not be null. sub ut_name { my( $self, $field ) = @_; $self->getfield($field) =~ /^([\w \,\.\-\']+)$/ - or return "Illegal (name) $field: ". $self->getfield($field); + or return gettext('illegal_name'). " $field: ". $self->getfield($field); $self->setfield($field,$1); ''; } @@ -911,12 +999,12 @@ sub ut_zip { my( $self, $field, $country ) = @_; if ( $country eq 'US' ) { $self->getfield($field) =~ /\s*(\d{5}(\-\d{4})?)\s*$/ - or return "Illegal (zip) $field for country $country: ". + or return gettext('illegal_zip'). " $field for country $country: ". $self->getfield($field); $self->setfield($field,$1); } else { $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/ - or return "Illegal (zip) $field: ". $self->getfield($field); + or return gettext('illegal_zip'). " $field: ". $self->getfield($field); $self->setfield($field,$1); } ''; @@ -974,6 +1062,34 @@ sub ut_enum { return "Illegal (enum) field $field: ". $self->getfield($field); } +=item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN + +Check/untaint a foreign column key. Call a regular ut_ method (like ut_number) +on the column first. + +=cut + +sub ut_foreign_key { + my( $self, $field, $table, $foreign ) = @_; + qsearchs($table, { $foreign => $self->getfield($field) }) + or return "Can't find $field ". $self->getfield($field). + " in $table.$foreign"; + ''; +} + +=item ut_foreign_keyn COLUMN FOREIGN_TABLE FOREIGN_COLUMN + +Like ut_foreign_key, except the null value is also allowed. + +=cut + +sub ut_foreign_keyn { + my( $self, $field, $table, $foreign ) = @_; + $self->getfield($field) + ? $self->ut_foreign_key($field, $table, $foreign) + : ''; +} + =item fields [ TABLE ] This can be used as both a subroutine and a method call. It returns a list @@ -1014,13 +1130,15 @@ I<$FS::Record::setup_hack> is true. Returns a DBIx::DBSchema object. sub reload_dbdef { my $file = shift || $dbdef_file; - $dbdef = load DBIx::DBSchema $file - or die "can't load database schema from $file"; + $dbdef = exists $dbdef_cache{$file} + ? $dbdef_cache{$file} + : $dbdef_cache{$file} = DBIx::DBSchema->load( $file ) + or die "can't load database schema from $file"; } =item dbdef -Returns the current database definition. See L. +Returns the current database definition. See L. =cut @@ -1030,7 +1148,7 @@ sub dbdef { $dbdef; } This is an internal function used to construct SQL statements. It returns VALUE DBI-quoted (see L) unless VALUE is a number and the column -type (see L) does not end in `char' or `binary'. +type (see L) does not end in `char' or `binary'. =cut @@ -1039,7 +1157,7 @@ sub _quote { my($dbh)=dbh; if ( $value =~ /^\d+(\.\d+)?$/ && # ! ( datatype($table,$field) =~ /^char/ ) - ! ( $dbdef->table($table)->column($field)->type =~ /(char|binary)$/i ) + ! $dbdef->table($table)->column($field)->type =~ /(char|binary|text)$/i ) { $value; } else { @@ -1100,7 +1218,7 @@ The whole fields / hfields mess should be removed. The various WHERE clauses should be subroutined. -table string should be depriciated in favor of FS::dbdef_table. +table string should be depriciated in favor of DBIx::DBSchema::Table. No doubt we could benefit from a Tied hash. Documenting how exists / defined true maps to the database (and WHERE clauses) would also help.