X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=a23f37a620d5e2054f2563e6ac0b1a1bb24696b7;hb=b59cf43f0814ea4d484d4b09833dd3c2d493455f;hp=7dc19ccac3f1300221924e95dc8d26c3fe6e44bb;hpb=239484572a9191100993bb1e85ffe8834689feb0;p=freeside.git diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index 7dc19ccac..a23f37a62 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -2,16 +2,17 @@ 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); 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 DBIx::DBSchema 0.21; +use FS::UID qw(dbh 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,14 +60,12 @@ FS::Record - Database record objects $hashref = $record->hashref; $error = $record->insert; - #$error = $record->add; #deprecated $error = $record->delete; - #$error = $record->del; #deprecated $error = $new_record->replace($old_record); - #$error = $new_record->rep($old_record); #deprecated + # external use deprecated - handled by the database (at least for Pg, mysql) $value = $record->unique('column'); $error = $record->ut_float('column'); @@ -87,7 +86,7 @@ FS::Record - Database record objects $quoted_value = _quote($value,'table','field'); - #depriciated + #deprecated $fields = hfields('table'); if ( $fields->{Field} ) { # etc. @@ -131,15 +130,8 @@ sub new { my $hashref = $self->{'Hash'} = shift; - foreach my $field ( $self->fields ) { - $hashref->{$field}='' unless defined $hashref->{$field}; - #trim the '$' and ',' from money fields for Pg (belong HERE?) - #(what about Pg i18n?) - if ( driver_name =~ /^Pg$/i - && $self->dbdef_table->column($field)->type eq 'money' ) { - ${$hashref}{$field} =~ s/^\$//; - ${$hashref}{$field} =~ s/\,//; - } + foreach my $field ( grep !defined($hashref->{$_}), $self->fields ) { + $hashref->{$field}=''; } $self->_cache($hashref, shift) if $self->can('_cache') && @_; @@ -173,7 +165,7 @@ sub create { my $self = {}; bless ($self, $class); if ( defined $self->table ) { - cluck "create constructor is depriciated, use new!"; + cluck "create constructor is deprecated, use new!"; $self->new(@_); } else { croak "FS::Record::create called (not from a subclass)!"; @@ -218,15 +210,29 @@ sub qsearch { my $op = '='; if ( ref($record->{$_}) ) { $op = $record->{$_}{'op'} if $record->{$_}{'op'}; - $op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name !~ /^Pg$/i; + $op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg'; $record->{$_} = $record->{$_}{'value'} } if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) { - if ( driver_name =~ /^Pg$/i ) { - qq-( $_ IS NULL OR $_ = '' )-; + if ( $op eq '=' ) { + if ( driver_name eq 'Pg' ) { + qq-( $_ IS NULL OR $_ = '' )-; + } else { + qq-( $_ IS NULL OR $_ = "" )-; + } + } elsif ( $op eq '!=' ) { + if ( driver_name eq 'Pg' ) { + qq-( $_ IS NOT NULL AND $_ != '' )-; + } else { + qq-( $_ IS NOT NULL AND $_ != "" )-; + } } else { - qq-( $_ IS NULL OR $_ = "" )-; + if ( driver_name eq 'Pg' ) { + qq-( $_ $op '' )-; + } else { + qq-( $_ $op "" )-; + } } } else { "$_ $op ?"; @@ -235,7 +241,7 @@ sub qsearch { } $statement .= " $extra_sql" if defined($extra_sql); - warn "[debug]$me $statement\n" if $DEBUG; + warn "[debug]$me $statement\n" if $DEBUG > 1; my $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement"; @@ -337,7 +343,7 @@ Returns the table name. =cut sub table { -# cluck "warning: FS::Record::table depriciated; supply one in subclass!"; +# cluck "warning: FS::Record::table deprecated; supply one in subclass!"; my $self = shift; $self -> {'Table'}; } @@ -398,32 +404,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. @@ -464,36 +470,48 @@ sub insert { return $error if $error; #single-field unique keys are given a value if false - #(like MySQL's AUTO_INCREMENT) + #(like MySQL's AUTO_INCREMENT or Pg SERIAL) foreach ( $self->dbdef_table->unique->singles ) { $self->unique($_) unless $self->getfield($_); } - #and also the primary key + + #and also the primary key, if the database isn't going to my $primary_key = $self->dbdef_table->primary_key; - $self->unique($primary_key) - if $primary_key && ! $self->getfield($primary_key); + my $db_seq = 0; + if ( $primary_key ) { + my $col = $self->dbdef_table->column($primary_key); + + $db_seq = + uc($col->type) eq 'SERIAL' + || ( driver_name eq 'Pg' + && defined($col->default) + && $col->default =~ /^nextval\(/i + ) + || ( driver_name eq 'mysql' + && defined($col->local) + && $col->local =~ /AUTO_INCREMENT/i + ); + $self->unique($primary_key) unless $self->getfield($primary_key) || $db_seq; + } + my $table = $self->table; #false laziness w/delete my @fields = grep defined($self->getfield($_)) && $self->getfield($_) ne "", $self->fields ; - my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields; + my @values = map { _quote( $self->getfield($_), $table, $_) } @fields; #eslaf - my $statement = "INSERT INTO ". $self->table. " ( ". + my $statement = "INSERT INTO $table ( ". join( ', ', @fields ). ") VALUES (". join( ', ', @values ). ")" ; - warn "[debug]$me $statement\n" if $DEBUG; + warn "[debug]$me $statement\n" if $DEBUG > 1; my $sth = dbh->prepare($statement) or return dbh->errstr; - my $h_statement = $self->_h_statement('insert'); - warn "[debug]$me $h_statement\n" if $DEBUG; - my $h_sth = dbh->prepare($h_statement) or return dbh->errstr; - local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; local $SIG{QUIT} = 'IGNORE'; @@ -502,7 +520,64 @@ sub insert { local $SIG{PIPE} = 'IGNORE'; $sth->execute or return $sth->errstr; - $h_sth->execute or return $h_sth->errstr; + + if ( $db_seq ) { # get inserted id from the database, if applicable + warn "[debug]$me retreiving sequence from database\n" if $DEBUG; + my $insertid = ''; + if ( driver_name eq 'Pg' ) { + + my $oid = $sth->{'pg_oid_status'}; + my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?"; + my $i_sth = dbh->prepare($i_sql) or do { + dbh->rollback if $FS::UID::AutoCommit; + return dbh->errstr; + }; + $i_sth->execute($oid) or do { + dbh->rollback if $FS::UID::AutoCommit; + return $i_sth->errstr; + }; + $insertid = $i_sth->fetchrow_arrayref->[0]; + + } elsif ( driver_name eq 'mysql' ) { + + $insertid = dbh->{'mysql_insertid'}; + # work around mysql_insertid being null some of the time, ala RT :/ + unless ( $insertid ) { + warn "WARNING: DBD::mysql didn't return mysql_insertid; ". + "using SELECT LAST_INSERT_ID();"; + my $i_sql = "SELECT LAST_INSERT_ID()"; + my $i_sth = dbh->prepare($i_sql) or do { + dbh->rollback if $FS::UID::AutoCommit; + return dbh->errstr; + }; + $i_sth->execute or do { + dbh->rollback if $FS::UID::AutoCommit; + return $i_sth->errstr; + }; + $insertid = $i_sth->fetchrow_arrayref->[0]; + } + + } else { + dbh->rollback if $FS::UID::AutoCommit; + return "don't know how to retreive inserted ids from ". driver_name. + ", try using counterfiles (maybe run dbdef-create?)"; + } + $self->setfield($primary_key, $insertid); + } + + my $h_sth; + if ( defined $dbdef->table('h_'. $table) ) { + my $h_statement = $self->_h_statement('insert'); + warn "[debug]$me $h_statement\n" if $DEBUG > 2; + $h_sth = dbh->prepare($h_statement) or do { + dbh->rollback if $FS::UID::AutoCommit; + return dbh->errstr; + }; + } else { + $h_sth = ''; + } + $h_sth->execute or return $h_sth->errstr if $h_sth; + dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit; ''; @@ -515,7 +590,7 @@ Depriciated (use insert instead). =cut sub add { - cluck "warning: FS::Record::add depriciated!"; + cluck "warning: FS::Record::add deprecated!"; insert @_; #call method in this scope } @@ -533,7 +608,7 @@ sub delete { map { $self->getfield($_) eq '' #? "( $_ IS NULL OR $_ = \"\" )" - ? ( driver_name =~ /^Pg$/i + ? ( driver_name eq 'Pg' ? "$_ IS NULL" : "( $_ IS NULL OR $_ = \"\" )" ) @@ -542,12 +617,17 @@ sub delete { ? ( $self->dbdef_table->primary_key) : $self->fields ); - warn "[debug]$me $statement\n" if $DEBUG; + warn "[debug]$me $statement\n" if $DEBUG > 1; my $sth = dbh->prepare($statement) or return dbh->errstr; - my $h_statement = $self->_h_statement('delete'); - warn "[debug]$me $h_statement\n" if $DEBUG; - my $h_sth = dbh->prepare($h_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 > 2; + $h_sth = dbh->prepare($h_statement) or return dbh->errstr; + } else { + $h_sth = ''; + } local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -558,10 +638,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; + $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! ''; } @@ -573,7 +654,7 @@ Depriciated (use delete instead). =cut sub del { - cluck "warning: FS::Record::del depriciated!"; + cluck "warning: FS::Record::del deprecated!"; &delete(@_); #call method in this scope } @@ -613,7 +694,7 @@ sub replace { map { $old->getfield($_) eq '' #? "( $_ IS NULL OR $_ = \"\" )" - ? ( driver_name =~ /^Pg$/i + ? ( driver_name eq 'Pg' ? "$_ IS NULL" : "( $_ IS NULL OR $_ = \"\" )" ) @@ -621,16 +702,26 @@ sub replace { } ( $primary_key ? ( $primary_key ) : $old->fields ) ) ; - warn "[debug]$me $statement\n" if $DEBUG; + warn "[debug]$me $statement\n" if $DEBUG > 1; my $sth = dbh->prepare($statement) or return dbh->errstr; - my $h_old_statement = $old->_h_statement('replace_old'); - warn "[debug]$me $h_old_statement\n" if $DEBUG; - my $h_old_sth = dbh->prepare($h_old_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 > 2; + $h_old_sth = dbh->prepare($h_old_statement) or return dbh->errstr; + } else { + $h_old_sth = ''; + } - my $h_new_statement = $new->_h_statement('replace_new'); - warn "[debug]$me $h_new_statement\n" if $DEBUG; - my $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr; + 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 > 2; + $h_new_sth = dbh->prepare($h_new_statement) or return dbh->errstr; + } else { + $h_new_sth = ''; + } local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; @@ -641,8 +732,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; - $h_new_sth->execute or return $h_new_sth->errstr; + $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; ''; @@ -656,7 +747,7 @@ Depriciated (use replace instead). =cut sub rep { - cluck "warning: FS::Record::rep depriciated!"; + cluck "warning: FS::Record::rep deprecated!"; replace @_; #call method in this scope } @@ -689,8 +780,13 @@ sub _h_statement { =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). +B: External use is B. + +Replaces COLUMN in record with a unique number, using counters in the +filesystem. Used by the B method on single-field unique columns +(see L) and also as a fallback for primary keys +that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql). + Returns the new value. =cut @@ -699,8 +795,6 @@ sub unique { my($self,$field) = @_; my($table)=$self->table; - croak("&FS::UID::checkruid failed") unless &checkruid; - croak "Unique called on field $field, but it is ", $self->getfield($field), ", not null!" @@ -716,9 +810,8 @@ sub unique { # my($counter) = new File::CounterFile "$user/$table.$field",0; # endhack - my($index)=$counter->inc; - $index=$counter->inc - while qsearchs($table,{$field=>$index}); #just in case + my $index = $counter->inc; + $index = $counter->inc while qsearchs($table, { $field=>$index } ); $index =~ /^(\d*)$/; $index=$1; @@ -795,7 +888,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. @@ -803,8 +896,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); ''; } @@ -819,8 +916,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); ''; } @@ -875,7 +972,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); @@ -897,7 +994,7 @@ sub ut_ip { $self->getfield($field) =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/ or return "Illegal (IP address) $field: ". $self->getfield($field); for ( $1, $2, $3, $4 ) { return "Illegal (IP address) $field" if $_ > 255; } - $self->setfield($field, "$1.$2.$3.$3"); + $self->setfield($field, "$1.$2.$3.$4"); ''; } @@ -926,7 +1023,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); ''; @@ -944,7 +1041,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); ''; } @@ -959,12 +1056,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); } ''; @@ -1090,8 +1187,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"; + + unless ( exists $dbdef_cache{$file} ) { + warn "[debug]$me loading dbdef for $file\n" if $DEBUG; + $dbdef_cache{$file} = DBIx::DBSchema->load( $file ) + or die "can't load database schema from $file"; + } else { + warn "[debug]$me re-using cached dbdef for $file\n" if $DEBUG; + } + $dbdef = $dbdef_cache{$file}; } =item dbdef @@ -1115,7 +1219,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 { @@ -1125,14 +1229,14 @@ sub _quote { =item hfields TABLE -This is depriciated. Don't use it. +This is deprecated. Don't use it. It returns a hash-type list with the fields of this record's table set true. =cut sub hfields { - carp "warning: hfields is depriciated"; + carp "warning: hfields is deprecated"; my($table)=@_; my(%hash); foreach (fields($table)) { @@ -1168,7 +1272,7 @@ sub DESTROY { return; } This module should probably be renamed, since much of the functionality is of general use. It is not completely unlike Adapter::DBI (see below). -Exported qsearch and qsearchs should be depriciated in favor of method calls +Exported qsearch and qsearchs should be deprecated in favor of method calls (against an FS::Record object like the old search and searchs that qsearch and qsearchs were on top of.) @@ -1176,7 +1280,7 @@ The whole fields / hfields mess should be removed. The various WHERE clauses should be subroutined. -table string should be depriciated in favor of DBIx::DBSchema::Table. +table string should be deprecated 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.