package FS::Record;
use strict;
-use vars qw($dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK);
+use vars qw($dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK $DEBUG);
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);
-use FS::dbdef;
+use Locale::Country;
+use DBIx::DBSchema;
+use FS::UID qw(dbh checkruid getotaker datasrc driver_name);
@ISA = qw(Exporter);
@EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef);
+$DEBUG = 0;
+
#ask FS::UID to run this stuff for us later
$FS::UID::callback{'FS::Record'} = sub {
$File::CounterFile::DEFAULT_DIR = "/usr/local/etc/freeside/counters.". datasrc;
$value = $record->ut_alpha('column');
$value = $record->ut_alphan('column');
$value = $record->ut_phonen('column');
- $value = $record->ut_anythingn('column');
+ $value = $record->ut_anything('column');
+ $value = $record->ut_name('column');
$dbdef = reload_dbdef;
$dbdef = reload_dbdef "/non/standard/filename";
$hashref->{$field}='' unless defined $hashref->{$field};
#trim the '$' and ',' from money fields for Pg (belong HERE?)
#(what about Pg i18n?)
- if ( datasrc =~ m/Pg/
+ if ( driver_name =~ /^Pg$/i
&& $self->dbdef_table->column($field)->type eq 'money' ) {
${$hashref}{$field} =~ s/^\$//;
${$hashref}{$field} =~ s/\,//;
}
}
-=item qsearch TABLE, HASHREF
+=item qsearch TABLE, HASHREF, SELECT, EXTRA_SQL
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
module is loaded (i.e. via `use FS::cust_main;'), otherwise returns FS::Record
objects.
+###oops, argh, FS::Record::new only lets us create database fields.
+#Normal behaviour if SELECT is not specified is `*', as in
+#C<SELECT * FROM table WHERE ...>. However, there is an experimental new
+#feature where you can specify SELECT - remember, the objects returned,
+#although blessed into the appropriate `FS::TABLE' package, will only have the
+#fields you specify. This might have unwanted results if you then go calling
+#regular FS::TABLE methods
+#on it.
+
=cut
sub qsearch {
- my($table,$record) = @_;
- my($dbh) = dbh;
+ my($table, $record, $select, $extra_sql ) = @_;
+ $table =~ /^([\w\_]+)$/ or die "Illegal table: $table";
+ $table = $1;
+ $select ||= '*';
+ my $dbh = dbh;
+
+ my @fields = grep exists($record->{$_}), fields($table);
+
+ my $statement = "SELECT $select FROM $table";
+ if ( @fields ) {
+ $statement .= ' WHERE '. join(' AND ', map {
+ if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
+ if ( driver_name =~ /^Pg$/i ) {
+ "$_ IS NULL";
+ } else {
+ qq-( $_ IS NULL OR $_ = "" )-;
+ }
+ } else {
+ "$_ = ?";
+ }
+ } @fields );
+ }
+ $statement .= " $extra_sql" if defined($extra_sql);
- my(@fields)=grep exists($record->{$_}), fields($table);
+ warn $statement if $DEBUG;
+ my $sth = $dbh->prepare($statement)
+ or croak "$dbh->errstr doing $statement";
- my($sth);
- my($statement) = "SELECT * FROM $table". ( @fields
- ? " WHERE ". join(' AND ',
- map {
- $record->{$_} eq ''
- ? ( datasrc =~ m/Pg/
- ? "$_ IS NULL"
- : "( $_ IS NULL OR $_ = \"\" )"
- )
- : "$_ = ". _quote($record->{$_},$table,$_)
- } @fields
- ) : ''
- );
- $sth=$dbh->prepare($statement)
- or croak $dbh->errstr; #is that a little too harsh? hmm.
- #warn $statement #if $debug # or some such;
+ $sth->execute( map $record->{$_},
+ grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
+ ) or croak "Error executing \"$statement\": ". $dbh->errstr;
+ $dbh->commit or croak $dbh->errstr if $FS::UID::AutoCommit;
- if ( eval ' scalar(@FS::'. $table. '::ISA);' ) {
- map {
- eval 'new FS::'. $table. ' ( $sth->fetchrow_hashref );';
- } ( 1 .. $sth->execute );
+ 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( {} )};
+ } else {
+ warn "untested code (class FS::$table uses custom new method)";
+ map {
+ eval 'FS::'. $table. '->new( { %{$_} } )';
+ } @{$sth->fetchall_arrayref( {} )};
+ }
} else {
- cluck "qsearch: warning: FS::$table not loaded; returning generic FS::Record objects";
+ cluck "warning: FS::$table not loaded; returning FS::Record objects";
map {
- new FS::Record ($table,$sth->fetchrow_hashref);
- } ( 1 .. $sth->execute );
+ FS::Record->new( $table, { %{$_} } );
+ } @{$sth->fetchall_arrayref( {} )};
}
}
my(@result) = qsearch(@_);
carp "warning: Multiple records in scalar search!" if scalar(@result) > 1;
#should warn more vehemently if the search was on a primary key?
- $result[0];
+ scalar(@result) ? ($result[0]) : ();
}
=back
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 {
$self->getfield($field);
local $SIG{PIPE} = 'IGNORE';
$sth->execute or return $sth->errstr;
+ dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
'';
}
map {
$self->getfield($_) eq ''
#? "( $_ IS NULL OR $_ = \"\" )"
- ? ( datasrc =~ m/Pg/
+ ? ( driver_name =~ /^Pg$/i
? "$_ IS NULL"
: "( $_ IS NULL OR $_ = \"\" )"
)
my $rc = $sth->execute or return $sth->errstr;
#not portable #return "Record not found, statement:\n$statement" if $rc eq "0E0";
+ dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
undef $self; #no need to keep object!
map {
$old->getfield($_) eq ''
#? "( $_ IS NULL OR $_ = \"\" )"
- ? ( datasrc =~ m/Pg/
+ ? ( driver_name =~ /^Pg$/i
? "$_ IS NULL"
: "( $_ IS NULL OR $_ = \"\" )"
)
my $rc = $sth->execute or return $sth->errstr;
#not portable #return "Record not found (or records identical)." if $rc eq "0E0";
+ dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
'';
=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<FS::dbdef_table>).
+on primary keys and single-field unique columns (see L<DBIx::DBSchema::Table>).
Returns the new value.
=cut
#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;
'';
}
-=item ut_phonen COLUMN
+=item ut_phonen COLUMN [ COUNTRY ]
Check/untaint phone numbers. May be null. If there is an error, returns
the error, otherwise returns false.
+Takes an optional two-letter ISO country code; without it or with unsupported
+countries, ut_phonen simply calls ut_alphan.
+
=cut
sub ut_phonen {
- my($self,$field)=@_;
+ my( $self, $field, $country ) = @_;
+ return $self->ut_alphan($field) unless defined $country;
my $phonen = $self->getfield($field);
if ( $phonen eq '' ) {
$self->setfield($field,'');
- } else {
+ } 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 = "$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_textn($field);
+ }
+ '';
+}
+
+=item ut_ip COLUMN
+
+Check/untaint ip addresses. IPv4 only for now.
+
+=cut
+
+sub ut_ip {
+ my( $self, $field ) = @_;
+ $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");
+ '';
+}
+
+=item ut_ipn COLUMN
+
+Check/untaint ip addresses. IPv4 only for now. May be null.
+
+=cut
+
+sub ut_ipn {
+ my( $self, $field ) = @_;
+ if ( $self->getfield($field) =~ /^()$/ ) {
+ $self->setfield($field,'');
+ '';
+ } else {
+ $self->ut_ip($field);
+ }
+}
+
+=item ut_domain COLUMN
+
+Check/untaint host and domain names.
+
+=cut
+
+sub ut_domain {
+ my( $self, $field ) = @_;
+ #$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 "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 ) = @_;
+ $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));
'';
}
sub ut_anything {
my($self,$field)=@_;
- $self->getfield($field) =~ /^(.*)$/
+ $self->getfield($field) =~ /^(.*)$/s
or return "Illegal $field: ". $self->getfield($field);
$self->setfield($field,$1);
'';
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<dbdef_table>).
+(See L<DBIx::DBSchema::Table>).
=cut
$table_obj->columns;
}
+=back
+
=head1 SUBROUTINES
=over 4
=item reload_dbdef([FILENAME])
-Load a database definition (see L<FS::dbdef>), 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<DBIx::DBSchema>), 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 = load DBIx::DBSchema $file;
}
=item dbdef
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<dbdef_column>) does not end in `char' or `binary'.
+type (see L<FS::dbdef_column>) does not end in `char' or `binary'.
=cut
# } (fields($self->table)) );
#}
+sub DESTROY { return; }
+
#sub DESTROY {
# my $self = shift;
# #use Carp qw(cluck);
=head1 VERSION
-$Id: Record.pm,v 1.1 1999-08-04 09:03:53 ivan Exp $
+$Id: Record.pm,v 1.25 2001-08-21 09:34:13 ivan Exp $
=head1 BUGS
ut_sqltype (like ut_varchar) should all be defined
-A fallback check method should be provided whith uses the dbdef.
+A fallback check method should be provided which uses the dbdef.
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.
Probably should borrow/use some dbdef methods where appropriate (like sub
fields)
+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<FS::dbdef>, L<FS::UID>, L<DBI>
+L<DBIx::DBSchema>, L<FS::UID>, L<DBI>
Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
projects / freeside.git / blobdiff