X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=7d5ff0582667bd5346f7ee3649bda7d046817fc8;hp=b5f33e12bf2e1592d9f4c5b43cd72dee59ec74a2;hb=25747983ac27c3b804a2f15312c8c7b59769e014;hpb=6ce7cc58f12b76532ca3c4944618902c1718aa48 diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index b5f33e12b..7d5ff0582 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -1,18 +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 FS::UID qw(dbh checkruid swapuid getotaker datasrc driver_name); -use FS::dbdef; +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); +@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 { @@ -54,26 +60,27 @@ 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'); - $value = $record->ut_float('column'); - $value = $record->ut_number('column'); - $value = $record->ut_numbern('column'); - $value = $record->ut_money('column'); - $value = $record->ut_text('column'); - $value = $record->ut_textn('column'); - $value = $record->ut_alpha('column'); - $value = $record->ut_alphan('column'); - $value = $record->ut_phonen('column'); - $value = $record->ut_anythingn('column'); + $error = $record->ut_float('column'); + $error = $record->ut_number('column'); + $error = $record->ut_numbern('column'); + $error = $record->ut_money('column'); + $error = $record->ut_text('column'); + $error = $record->ut_textn('column'); + $error = $record->ut_alpha('column'); + $error = $record->ut_alphan('column'); + $error = $record->ut_phonen('column'); + $error = $record->ut_anything('column'); + $error = $record->ut_name('column'); $dbdef = reload_dbdef; $dbdef = reload_dbdef "/non/standard/filename"; @@ -118,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; @@ -126,16 +136,38 @@ sub new { $hashref->{$field}='' unless defined $hashref->{$field}; #trim the '$' and ',' from money fields for Pg (belong HERE?) #(what about Pg i18n?) - if ( driver_name eq 'Pg' + if ( driver_name =~ /^Pg$/i && $self->dbdef_table->column($field)->type eq 'money' ) { ${$hashref}{$field} =~ s/^\$//; ${$hashref}{$field} =~ s/\,//; } } + $self->_cache($hashref, shift) if $self->can('_cache') && @_; + $self; } +sub new_or_cached { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + bless ($self, $class); + + $self->{'Table'} = shift unless defined ( $self->table ); + + my $hashref = $self->{'Hash'} = shift; + my $cache = shift; + if ( defined( $cache->cache->{$hashref->{$cache->key}} ) ) { + my $obj = $cache->cache->{$hashref->{$cache->key}}; + $obj->_cache($hashref, $cache) if $obj->can('_cache'); + $obj; + } else { + $cache->cache->{$hashref->{$cache->key}} = $self->new($hashref, $cache); + } + +} + sub create { my $proto = shift; my $class = ref($proto) || $proto; @@ -149,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 @@ -168,43 +200,94 @@ objects. =cut sub qsearch { - my($table, $record, $select, $extra_sql ) = @_; + my($stable, $record, $select, $extra_sql, $cache ) = @_; + #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table"; + #for jsearch + $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable"; + $stable = $1; $select ||= '*'; my $dbh = dbh; + my $table = $cache ? $cache->table : $stable; + my @fields = grep exists($record->{$_}), fields($table); - my $statement = "SELECT $select FROM $table"; + 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 eq 'Pg' ) { - "$_ 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 $dbh->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);' ) { if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) { #derivied class didn't override new method, so this optimization is safe - map { - new( "FS::$table", { %{$_} } ) - } @{$sth->fetchall_arrayref( {} )}; + if ( $cache ) { + map { + new_or_cached( "FS::$table", { %{$_} }, $cache ) + } @{$sth->fetchall_arrayref( {} )}; + } else { + map { + new( "FS::$table", { %{$_} } ) + } @{$sth->fetchall_arrayref( {} )}; + } } else { warn "untested code (class FS::$table uses custom new method)"; map { @@ -220,6 +303,27 @@ sub qsearch { } +=item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY + +Experimental JOINed search method. Using this method, you can execute a +single SELECT spanning multiple tables, and cache the results for subsequent +method calls. Interface will almost definately change in an incompatible +fashion. + +Arguments: + +=cut + +sub jsearch { + my($table, $record, $select, $extra_sql, $ptable, $pkey ) = @_; + my $cache = FS::SearchCache->new( $ptable, $pkey ); + my %saw; + ( $cache, + grep { !$saw{$_->getfield($pkey)}++ } + qsearch($table, $record, $select, $extra_sql, $cache ) + ); +} + =item qsearchs TABLE, HASHREF Same as qsearch, except that if more than one record matches, it Bs but @@ -255,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 @@ -308,17 +412,33 @@ $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; +# $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. @@ -368,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'; @@ -389,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; ''; @@ -415,11 +549,11 @@ 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 $_ = \"\" )" - ? ( driver_name eq 'Pg' + ? ( driver_name =~ /^Pg$/i ? "$_ IS NULL" : "( $_ IS NULL OR $_ = \"\" )" ) @@ -428,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'; @@ -439,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! ''; } @@ -466,12 +612,7 @@ returns the error, otherwise returns false. sub replace { my ( $new, $old ) = ( shift, shift ); - - my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields; - unless ( @diff ) { - carp "warning: records identical"; - return ''; - } + warn "[debug]$me $new ->replace $old\n" if $DEBUG; return "Records not in same table!" unless $new->table eq $old->table; @@ -483,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,$_) @@ -492,7 +639,7 @@ sub replace { map { $old->getfield($_) eq '' #? "( $_ IS NULL OR $_ = \"\" )" - ? ( driver_name eq 'Pg' + ? ( driver_name =~ /^Pg$/i ? "$_ IS NULL" : "( $_ IS NULL OR $_ = \"\" )" ) @@ -500,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'; @@ -511,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; ''; @@ -538,10 +706,27 @@ 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 -on primary keys and single-field unique columns (see L). +on primary keys and single-field unique columns (see L). Returns the new value. =cut @@ -560,7 +745,6 @@ sub unique { #warn "table $table is tainted" if is_tainted($table); #warn "field $field is tainted" if is_tainted($field); - &swapuid; my($counter) = new File::CounterFile "$table.$field",0; # hack for web demo # getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!"; @@ -571,7 +755,6 @@ sub unique { my($index)=$counter->inc; $index=$counter->inc while qsearchs($table,{$field=>$index}); #just in case - &swapuid; $index =~ /^(\d*)$/; $index=$1; @@ -648,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. @@ -656,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); ''; } @@ -672,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); ''; } @@ -725,16 +912,16 @@ sub ut_phonen { my $phonen = $self->getfield($field); if ( $phonen eq '' ) { $self->setfield($field,''); - } elsif ( $country eq 'US' ) { + } 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); } else { - warn "don't know how to check phone numbers for country $country"; - return $self->ut_alphan($field); + warn "warning: don't know how to check phone numbers for country $country"; + return $self->ut_textn($field); } ''; } @@ -779,14 +966,71 @@ 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); ''; } +=item ut_name COLUMN + +Check/untaint proper names; allows alphanumerics, spaces and the following +punctuation: , . - ' + +May not be null. + +=cut + +sub ut_name { + my( $self, $field ) = @_; + $self->getfield($field) =~ /^([\w \,\.\-\']+)$/ + or return gettext('illegal_name'). " $field: ". $self->getfield($field); + $self->setfield($field,$1); + ''; +} + +=item ut_zip COLUMN + +Check/untaint zip codes. + =cut +sub ut_zip { + my( $self, $field, $country ) = @_; + if ( $country eq 'US' ) { + $self->getfield($field) =~ /\s*(\d{5}(\-\d{4})?)\s*$/ + 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 gettext('illegal_zip'). " $field: ". $self->getfield($field); + $self->setfield($field,$1); + } + ''; +} + +=item ut_country COLUMN + +Check/untaint country codes. Country names are changed to codes, if possible - +see L. + +=cut + +sub ut_country { + my( $self, $field ) = @_; + unless ( $self->getfield($field) =~ /^(\w\w)$/ ) { + if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/ + && country2code($1) ) { + $self->setfield($field,uc(country2code($1))); + } + } + $self->getfield($field) =~ /^(\w\w)$/ + or return "Illegal (country) $field: ". $self->getfield($field); + $self->setfield($field,uc($1)); + ''; +} + =item ut_anything COLUMN Untaints arbitrary data. Be careful. @@ -794,18 +1038,63 @@ Untaints arbitrary data. Be careful. =cut sub ut_anything { - my($self,$field)=@_; - $self->getfield($field) =~ /^(.*)$/ + my( $self, $field ) = @_; + $self->getfield($field) =~ /^(.*)$/s or return "Illegal $field: ". $self->getfield($field); $self->setfield($field,$1); ''; } +=item ut_enum COLUMN CHOICES_ARRAYREF + +Check/untaint a column, supplying all possible choices, like the "enum" type. + +=cut + +sub ut_enum { + my( $self, $field, $choices ) = @_; + foreach my $choice ( @$choices ) { + if ( $self->getfield($field) eq $choice ) { + $self->setfield($choice); + return ''; + } + } + 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 of the columns in this record's table, or an explicitly specified table. -(See L). +(See L). =cut @@ -821,30 +1110,35 @@ sub fields { } #croak "Usage: \@fields = fields(\$table)\n or: \@fields = \$record->fields" unless $table; my($table_obj) = $dbdef->table($table); - croak "Unknown table $table" unless $table_obj; + confess "Unknown table $table" unless $table_obj; $table_obj->columns; } +=back + =head1 SUBROUTINES =over 4 =item reload_dbdef([FILENAME]) -Load a database definition (see L), optionally from a non-default -filename. This command is executed at startup unless -I<$FS::Record::setup_hack> is true. Returns a FS::dbdef object. +Load a database definition (see L), optionally from a +non-default filename. This command is executed at startup unless +I<$FS::Record::setup_hack> is true. Returns a DBIx::DBSchema object. =cut sub reload_dbdef { my $file = shift || $dbdef_file; - $dbdef = load FS::dbdef ($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 @@ -854,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 @@ -863,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 { @@ -889,12 +1183,12 @@ sub hfields { \%hash; } -#sub _dump { -# my($self)=@_; -# join("\n", map { -# "$_: ". $self->getfield($_). "|" -# } (fields($self->table)) ); -#} +sub _dump { + my($self)=@_; + join("\n", map { + "$_: ". $self->getfield($_). "|" + } (fields($self->table)) ); +} sub DESTROY { return; } @@ -911,10 +1205,6 @@ sub DESTROY { return; } =back -=head1 VERSION - -$Id: Record.pm,v 1.13 2001-02-20 16:31:06 ivan Exp $ - =head1 BUGS This module should probably be renamed, since much of the functionality is @@ -928,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. @@ -943,7 +1233,7 @@ The ut_money method assumes money has two decimal digits. The Pg money kludge in the new method only strips `$'. -The ut_phonen method assumes US-style phone numbers. +The ut_phonen method only checks US-style phone numbers. The _quote function should probably use ut_float instead of a regex. @@ -956,9 +1246,11 @@ As of 1.14, DBI fetchall_hashref( {} ) doesn't set fetchrow_hashref NAME_lc, or allow it to be set. Working around it is ugly any way around - DBI should be fixed. (only affects RDBMS which return uppercase column names) +ut_zip should take an optional country like ut_phone. + =head1 SEE ALSO -L, L, L +L, L, L Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.