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);
$hashref = $record->hashref;
$error = $record->insert;
- #$error = $record->add; #depriciated
$error = $record->delete;
- #$error = $record->del; #depriciated
$error = $new_record->replace($old_record);
- #$error = $new_record->rep($old_record); #depriciated
+ # external use deprecated - handled by the database (at least for Pg, mysql)
$value = $record->unique('column');
$error = $record->ut_float('column');
$quoted_value = _quote($value,'table','field');
- #depriciated
+ #deprecated
$fields = hfields('table');
if ( $fields->{Field} ) { # etc.
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') && @_;
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)!";
}
}
-=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
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 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 ?";
}
} @fields );
}
$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";
=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'};
}
=item dbdef_table
-Returns the FS::dbdef_table object for the table.
+Returns the DBIx::DBSchema::Table object for the table.
=cut
=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.
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($_), $table, $_) } @fields;
+ #eslaf
- my $statement = "INSERT INTO ". $self->table. " ( ".
- join(', ',@fields ).
+ my $statement = "INSERT INTO $table ( ".
+ join( ', ', @fields ).
") VALUES (".
- join(', ',map(_quote($self->getfield($_),$self->table,$_), @fields)).
+ 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;
local $SIG{HUP} = 'IGNORE';
local $SIG{PIPE} = 'IGNORE';
$sth->execute or return $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;
'';
=cut
sub add {
- cluck "warning: FS::Record::add depriciated!";
+ cluck "warning: FS::Record::add deprecated!";
insert @_; #call method in this scope
}
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 =~ /^Pg$/i
+ ? ( driver_name eq 'Pg'
? "$_ IS NULL"
: "( $_ IS NULL OR $_ = \"\" )"
)
? ( $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_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';
local $SIG{QUIT} = 'IGNORE';
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!
'';
}
=cut
sub del {
- cluck "warning: FS::Record::del depriciated!";
+ cluck "warning: FS::Record::del deprecated!";
&delete(@_); #call method in this scope
}
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;
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,$_)
map {
$old->getfield($_) eq ''
#? "( $_ IS NULL OR $_ = \"\" )"
- ? ( driver_name =~ /^Pg$/i
+ ? ( driver_name eq 'Pg'
? "$_ IS NULL"
: "( $_ IS NULL OR $_ = \"\" )"
)
} ( $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_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_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';
local $SIG{QUIT} = 'IGNORE';
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;
'';
=cut
sub rep {
- cluck "warning: FS::Record::rep depriciated!";
+ cluck "warning: FS::Record::rep deprecated!";
replace @_; #call method in this scope
}
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<add> method
-on primary keys and single-field unique columns (see L<DBIx::DBSchema::Table>).
+B<Warning>: External use is B<deprecated>.
+
+Replaces COLUMN in record with a unique number, using counters in the
+filesystem. Used by the B<insert> method on single-field unique columns
+(see L<DBIx::DBSchema::Table>) and also as a fallback for primary keys
+that aren't SERIAL (Pg) or AUTO_INCREMENT (mysql).
+
Returns the new value.
=cut
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!"
# 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;
=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.
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);
'';
}
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);
'';
}
} 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);
$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");
'';
}
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);
'';
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);
'';
}
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);
}
'';
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
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
-Returns the current database definition. See L<FS::dbdef>.
+Returns the current database definition. See L<DBIx::DBSchema>.
=cut
This is an internal function used to construct SQL statements. It returns
VALUE DBI-quoted (see L<DBI/"quote">) unless VALUE is a number and the column
-type (see L<FS::dbdef_column>) does not end in `char' or `binary'.
+type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
=cut
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 {
=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)) {
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.)
The various WHERE clauses should be subroutined.
-table string should be depriciated in favor of FS::dbdef_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.