X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=7d5ff0582667bd5346f7ee3649bda7d046817fc8;hp=a04ddb9820ea376a0c3d89f0cc85d91835d56b52;hb=25747983ac27c3b804a2f15312c8c7b59769e014;hpb=4e5a0655072be725acf00394186b93c96bba17ee diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index a04ddb982..7d5ff0582 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -1,20 +1,24 @@ package FS::Record; use strict; -use vars qw($dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK $DEBUG); +use vars qw( $dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK $DEBUG + $me %dbdef_cache ); use subs qw(reload_dbdef); use Exporter; use Carp qw(carp cluck croak confess); use File::CounterFile; use Locale::Country; +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); $DEBUG = 0; +$me = '[FS::Record]'; #ask FS::UID to run this stuff for us later $FS::UID::callback{'FS::Record'} = sub { @@ -56,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'); @@ -121,7 +125,10 @@ sub new { my $self = {}; bless ($self, $class); - $self->{'Table'} = shift unless defined ( $self->table ); + unless ( defined ( $self->table ) ) { + $self->{'Table'} = shift; + carp "warning: FS::Record::new called with table name ". $self->{'Table'}; + } my $hashref = $self->{'Hash'} = shift; @@ -174,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 @@ -208,26 +215,65 @@ 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 ) { - "$_ IS NULL"; + 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 ); } $statement .= " $extra_sql" if defined($extra_sql); - warn $statement if $DEBUG; + warn "[debug]$me $statement\n" if $DEBUG; my $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement"; - $sth->execute( map $record->{$_}, + my $bind = 1; + + foreach my $field ( grep defined( $record->{$_} ) && $record->{$_} ne '', @fields - ) or croak "Error executing \"$statement\": ". $sth->errstr; + ) { + if ( $record->{$field} =~ /^\d+(\.\d+)?$/ + && $dbdef->table($table)->column($field)->type =~ /(int)/i + ) { + $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } ); + } else { + $sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_VARCHAR } ); + } + } + +# $sth->execute( map $record->{$_}, +# grep defined( $record->{$_} ) && $record->{$_} ne '', @fields +# ) or croak "Error executing \"$statement\": ". $sth->errstr; + + $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr; + $dbh->commit or croak $dbh->errstr if $FS::UID::AutoCommit; if ( eval 'scalar(@FS::'. $table. '::ISA);' ) { @@ -313,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 @@ -367,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. @@ -442,19 +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'; @@ -463,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; ''; @@ -489,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 $_ = \"\" )" @@ -502,8 +562,18 @@ sub delete { ? ( $self->dbdef_table->primary_key) : $self->fields ); + 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'; @@ -513,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! ''; } @@ -540,13 +612,7 @@ returns the error, otherwise returns false. sub replace { my ( $new, $old ) = ( shift, shift ); - warn "[debug][FS::Record] $new ->replace $old\n" if $DEBUG; - - my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields; - unless ( @diff ) { - carp "[warning][FS::Record] $new -> replace $old: records identical"; - return ''; - } + warn "[debug]$me $new ->replace $old\n" if $DEBUG; return "Records not in same table!" unless $new->table eq $old->table; @@ -558,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,$_) @@ -575,8 +647,27 @@ sub replace { } ( $primary_key ? ( $primary_key ) : $old->fields ) ) ; + 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'; @@ -586,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; ''; @@ -613,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 @@ -721,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. @@ -729,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); ''; } @@ -745,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); ''; } @@ -801,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); @@ -852,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); ''; @@ -870,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); ''; } @@ -885,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); } ''; @@ -948,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 @@ -988,12 +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; + $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 @@ -1003,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 @@ -1012,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 { @@ -1073,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.