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 );
use subs qw(reload_dbdef);
use Exporter;
use Carp qw(carp cluck croak confess);
use File::CounterFile;
-use DBIx::DBSchema;
-use FS::UID qw(dbh checkruid swapuid getotaker datasrc driver_name);
+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;
@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 {
$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";
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;
}
}
+ $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;
}
}
-=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
=cut
sub qsearch {
- my($table, $record, $select, $extra_sql ) = @_;
- $table =~ /^([\w\_]+)$/ or die "Illegal table: $table";
- $table = $1;
+ 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 =~ /^Pg$/i ) {
- "$_ IS NULL";
+ qq-( $_ IS NULL OR $_ = '' )-;
} else {
qq-( $_ IS NULL OR $_ = "" )-;
}
} 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 {
}
+=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 B<carp>s but
=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($self,$value)=@_;
- my($field)=$AUTOLOAD;
+ my $field = $AUTOLOAD;
$field =~ s/.*://;
- if ( defined($value) ) {
- $self->setfield($field,$value);
+ if ( defined($_[1]) ) {
+ $_[0]->setfield($field, $_[1]);
} else {
- $self->getfield($field);
+ $_[0]->getfield($field);
}
}
$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';
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;
'';
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 $_ = \"\" )"
? ( $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';
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
+ #undef $self; #no need to keep object!
'';
}
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;
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,$_)
} ( $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';
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;
'';
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
#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!";
my($index)=$counter->inc;
$index=$counter->inc
while qsearchs($table,{$field=>$index}); #just in case
- &swapuid;
$index =~ /^(\d*)$/;
$index=$1;
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);
$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);
}
'';
}
'';
}
+=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 "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 "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);
+ $self->setfield($field,$1);
+ }
+ '';
+}
+
+=item ut_country COLUMN
+
+Check/untaint country codes. Country names are changed to codes, if possible -
+see L<Locale::Country>.
+
+=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.
=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
}
#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
sub reload_dbdef {
my $file = shift || $dbdef_file;
- $dbdef = load DBIx::DBSchema $file;
+ $dbdef = load DBIx::DBSchema $file
+ or die "can't load database schema from $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
\%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; }
=back
-=head1 VERSION
-
-$Id: Record.pm,v 1.16 2001-05-07 15:42:02 ivan Exp $
-
=head1 BUGS
This module should probably be renamed, since much of the functionality is
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.
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.
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<DBIx::DBSchema>, L<FS::UID>, L<DBI>