summaryrefslogtreecommitdiff
path: root/FS/FS/Record.pm
diff options
context:
space:
mode:
Diffstat (limited to 'FS/FS/Record.pm')
-rw-r--r--FS/FS/Record.pm595
1 files changed, 498 insertions, 97 deletions
diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm
index e6126a1..801b89d 100644
--- a/FS/FS/Record.pm
+++ b/FS/FS/Record.pm
@@ -2,18 +2,22 @@ package FS::Record;
use strict;
use vars qw( $dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK $DEBUG
- $me %dbdef_cache );
+ $me %dbdef_cache %virtual_fields_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.23;
+use FS::UID qw(dbh getotaker datasrc driver_name);
use FS::SearchCache;
use FS::Msgcat qw(gettext);
+use FS::part_virtual_field;
+
+use Tie::IxHash;
+
@ISA = qw(Exporter);
@EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch);
@@ -60,14 +64,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');
@@ -88,7 +90,7 @@ FS::Record - Database record objects
$quoted_value = _quote($value,'table','field');
- #depriciated
+ #deprecated
$fields = hfields('table');
if ( $fields->{Field} ) { # etc.
@@ -167,7 +169,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)!";
@@ -202,45 +204,101 @@ sub qsearch {
my $dbh = dbh;
my $table = $cache ? $cache->table : $stable;
+ my $pkey = $dbdef->table($table)->primary_key;
- my @fields = grep exists($record->{$_}), fields($table);
+ my @real_fields = grep exists($record->{$_}), real_fields($table);
+ my @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
my $statement = "SELECT $select FROM $stable";
- if ( @fields ) {
- $statement .= ' WHERE '. join(' AND ', map {
+ if ( @real_fields or @virtual_fields ) {
+ $statement .= ' WHERE '. join(' AND ',
+ ( map {
my $op = '=';
+ my $column = $_;
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';
+ if ( uc($op) eq 'ILIKE' ) {
+ $op = 'LIKE';
+ $record->{$_}{'value'} = lc($record->{$_}{'value'});
+ $column = "LOWER($_)";
+ }
$record->{$_} = $record->{$_}{'value'}
}
if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
if ( $op eq '=' ) {
- if ( driver_name =~ /^Pg$/i ) {
- qq-( $_ IS NULL OR $_ = '' )-;
+ if ( driver_name eq 'Pg' ) {
+ my $type = $dbdef->table($table)->column($column)->type;
+ if ( $type =~ /(int|serial)/i ) {
+ qq-( $column IS NULL )-;
+ } else {
+ qq-( $column IS NULL OR $column = '' )-;
+ }
} else {
- qq-( $_ IS NULL OR $_ = "" )-;
+ qq-( $column IS NULL OR $column = "" )-;
}
} elsif ( $op eq '!=' ) {
- if ( driver_name =~ /^Pg$/i ) {
- qq-( $_ IS NOT NULL AND $_ != '' )-;
+ if ( driver_name eq 'Pg' ) {
+ my $type = $dbdef->table($table)->column($column)->type;
+ if ( $type =~ /(int|serial)/i ) {
+ qq-( $column IS NOT NULL )-;
+ } else {
+ qq-( $column IS NOT NULL AND $column != '' )-;
+ }
} else {
- qq-( $_ IS NOT NULL AND $_ != "" )-;
+ qq-( $column IS NOT NULL AND $column != "" )-;
}
} else {
- if ( driver_name =~ /^Pg$/i ) {
- qq-( $_ $op '' )-;
+ if ( driver_name eq 'Pg' ) {
+ qq-( $column $op '' )-;
} else {
- qq-( $_ $op "" )-;
+ qq-( $column $op "" )-;
}
}
} else {
- "$_ $op ?";
+ "$column $op ?";
}
- } @fields );
+ } @real_fields ),
+ ( map {
+ my $op = '=';
+ my $column = $_;
+ if ( ref($record->{$_}) ) {
+ $op = $record->{$_}{'op'} if $record->{$_}{'op'};
+ if ( uc($op) eq 'ILIKE' ) {
+ $op = 'LIKE';
+ $record->{$_}{'value'} = lc($record->{$_}{'value'});
+ $column = "LOWER($_)";
+ }
+ $record->{$_} = $record->{$_}{'value'};
+ }
+
+ # ... EXISTS ( SELECT name, value FROM part_virtual_field
+ # JOIN virtual_field
+ # ON part_virtual_field.vfieldpart = virtual_field.vfieldpart
+ # WHERE recnum = svc_acct.svcnum
+ # AND (name, value) = ('egad', 'brain') )
+
+ my $value = $record->{$_};
+
+ my $subq;
+
+ $subq = ($value ? 'EXISTS ' : 'NOT EXISTS ') .
+ "( SELECT part_virtual_field.name, virtual_field.value ".
+ "FROM part_virtual_field JOIN virtual_field ".
+ "ON part_virtual_field.vfieldpart = virtual_field.vfieldpart ".
+ "WHERE virtual_field.recnum = ${table}.${pkey} ".
+ "AND part_virtual_field.name = '${column}'".
+ ($value ?
+ " AND virtual_field.value ${op} '${value}'"
+ : "") . ")";
+ $subq;
+
+ } @virtual_fields ) );
+
}
+
$statement .= " $extra_sql" if defined($extra_sql);
warn "[debug]$me $statement\n" if $DEBUG > 1;
@@ -250,10 +308,10 @@ sub qsearch {
my $bind = 1;
foreach my $field (
- grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
+ grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields
) {
if ( $record->{$field} =~ /^\d+(\.\d+)?$/
- && $dbdef->table($table)->column($field)->type =~ /(int)/i
+ && $dbdef->table($table)->column($field)->type =~ /(int|serial)/i
) {
$sth->bind_param($bind++, $record->{$field}, { TYPE => SQL_INTEGER } );
} else {
@@ -267,31 +325,64 @@ sub qsearch {
$sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
- $dbh->commit or croak $dbh->errstr if $FS::UID::AutoCommit;
+ my %result;
+ tie %result, "Tie::IxHash";
+ @virtual_fields = "FS::$table"->virtual_fields;
+ my @stuff = @{ $sth->fetchall_arrayref( {} ) };
+ if($pkey) {
+ %result = map { $_->{$pkey}, $_ } @stuff;
+ } else {
+ @result{@stuff} = @stuff;
+ }
+
+ $sth->finish;
+ if ( keys(%result) and @virtual_fields ) {
+ $statement =
+ "SELECT virtual_field.recnum, part_virtual_field.name, ".
+ "virtual_field.value ".
+ "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ".
+ "WHERE part_virtual_field.dbtable = '$table' AND ".
+ "virtual_field.recnum IN (".
+ join(',', keys(%result)). ") AND part_virtual_field.name IN ('".
+ join(q!', '!, @virtual_fields) . "')";
+ warn "[debug]$me $statement\n" if $DEBUG > 1;
+ $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement";
+ $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
+
+ foreach (@{ $sth->fetchall_arrayref({}) }) {
+ my $recnum = $_->{recnum};
+ my $name = $_->{name};
+ my $value = $_->{value};
+ if (exists($result{$recnum})) {
+ $result{$recnum}->{$name} = $value;
+ }
+ }
+ }
+
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
if ( $cache ) {
map {
new_or_cached( "FS::$table", { %{$_} }, $cache )
- } @{$sth->fetchall_arrayref( {} )};
+ } values(%result);
} else {
map {
new( "FS::$table", { %{$_} } )
- } @{$sth->fetchall_arrayref( {} )};
+ } values(%result);
}
} else {
warn "untested code (class FS::$table uses custom new method)";
map {
eval 'FS::'. $table. '->new( { %{$_} } )';
- } @{$sth->fetchall_arrayref( {} )};
+ } values(%result);
}
} else {
cluck "warning: FS::$table not loaded; returning FS::Record objects";
map {
FS::Record->new( $table, { %{$_} } );
- } @{$sth->fetchall_arrayref( {} )};
+ } values(%result);
}
}
@@ -326,9 +417,11 @@ for a single item, or your data is corrupted.
=cut
sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
+ my $table = $_[0];
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?
+ carp "warning: Multiple records in scalar search ($table)"
+ if scalar(@result) > 1;
+ #should warn more vehemently if the search was on a primary key?
scalar(@result) ? ($result[0]) : ();
}
@@ -345,7 +438,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'};
}
@@ -412,11 +505,11 @@ sub AUTOLOAD {
$field =~ s/.*://;
if ( defined($value) ) {
confess "errant AUTOLOAD $field for $self (arg $value)"
- unless $self->can('setfield');
+ unless ref($self) && $self->can('setfield');
$self->setfield($field,$value);
} else {
confess "errant AUTOLOAD $field for $self (no args)"
- unless $self->can('getfield');
+ unless ref($self) && $self->can('getfield');
$self->getfield($field);
}
}
@@ -472,25 +565,41 @@ 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 =
+ my @real_fields =
grep defined($self->getfield($_)) && $self->getfield($_) ne "",
- $self->fields
+ real_fields($table)
;
- my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
+ my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields;
#eslaf
- my $statement = "INSERT INTO ". $self->table. " ( ".
- join( ', ', @fields ).
+ my $statement = "INSERT INTO $table ( ".
+ join( ', ', @real_fields ).
") VALUES (".
join( ', ', @values ).
")"
@@ -498,15 +607,6 @@ sub insert {
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('insert');
- 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';
@@ -515,7 +615,92 @@ sub insert {
local $SIG{PIPE} = 'IGNORE';
$sth->execute or return $sth->errstr;
+
+ my $insertid = '';
+ if ( $db_seq ) { # get inserted id from the database, if applicable
+ warn "[debug]$me retreiving sequence from database\n" if $DEBUG;
+ 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 @virtual_fields =
+ grep defined($self->getfield($_)) && $self->getfield($_) ne "",
+ $self->virtual_fields;
+ if (@virtual_fields) {
+ my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
+
+ my $vfieldpart = $self->vfieldpart_hashref;
+
+ my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
+ "VALUES (?, ?, ?)";
+
+ my $v_sth = dbh->prepare($v_statement) or do {
+ dbh->rollback if $FS::UID::AutoCommit;
+ return dbh->errstr;
+ };
+
+ foreach (keys(%v_values)) {
+ $v_sth->execute($self->getfield($primary_key),
+ $vfieldpart->{$_},
+ $v_values{$_})
+ or do {
+ dbh->rollback if $FS::UID::AutoCommit;
+ return $v_sth->errstr;
+ };
+ }
+ }
+
+
+ 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;
'';
@@ -528,7 +713,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
}
@@ -546,14 +731,14 @@ sub delete {
map {
$self->getfield($_) eq ''
#? "( $_ IS NULL OR $_ = \"\" )"
- ? ( driver_name =~ /^Pg$/i
+ ? ( driver_name eq 'Pg'
? "$_ IS NULL"
: "( $_ IS NULL OR $_ = \"\" )"
)
: "$_ = ". _quote($self->getfield($_),$self->table,$_)
} ( $self->dbdef_table->primary_key )
? ( $self->dbdef_table->primary_key)
- : $self->fields
+ : real_fields($self->table)
);
warn "[debug]$me $statement\n" if $DEBUG > 1;
my $sth = dbh->prepare($statement) or return dbh->errstr;
@@ -567,6 +752,19 @@ sub delete {
$h_sth = '';
}
+ my $primary_key = $self->dbdef_table->primary_key;
+ my $v_sth;
+ my @del_vfields;
+ my $vfp = $self->vfieldpart_hashref;
+ foreach($self->virtual_fields) {
+ next if $self->getfield($_) eq '';
+ unless(@del_vfields) {
+ my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?";
+ $v_sth = dbh->prepare($st) or return dbh->errstr;
+ }
+ push @del_vfields, $_;
+ }
+
local $SIG{HUP} = 'IGNORE';
local $SIG{INT} = 'IGNORE';
local $SIG{QUIT} = 'IGNORE';
@@ -577,6 +775,10 @@ 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;
+ $v_sth->execute($self->getfield($primary_key), $vfp->{$_})
+ or return $v_sth->errstr
+ foreach (@del_vfields);
+
dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
#no need to needlessly destoy the data either (causes problems actually)
@@ -592,7 +794,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
}
@@ -604,7 +806,24 @@ returns the error, otherwise returns false.
=cut
sub replace {
- my ( $new, $old ) = ( shift, shift );
+ my $new = shift;
+
+ my $old;
+ if ( @_ ) {
+ $old = shift;
+ } else {
+ warn "[debug]$me replace called with no arguments; autoloading old record\n"
+ if $DEBUG;
+ my $primary_key = $new->dbdef_table->primary_key;
+ if ( $primary_key ) {
+ $old = qsearchs($new->table, { $primary_key => $new->$primary_key() } )
+ or croak "can't find ". $new->table. ".$primary_key ".
+ $new->$primary_key();
+ } else {
+ croak $new->table. " has no primary key; pass old record as argument";
+ }
+ }
+
warn "[debug]$me $new ->replace $old\n" if $DEBUG;
return "Records not in same table!" unless $new->table eq $old->table;
@@ -617,8 +836,11 @@ sub replace {
my $error = $new->check;
return $error if $error;
- my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
- unless ( @diff ) {
+ #my @diff = grep $new->getfield($_) ne $old->getfield($_), $old->fields;
+ my %diff = map { ($new->getfield($_) ne $old->getfield($_))
+ ? ($_, $new->getfield($_)) : () } $old->fields;
+
+ unless ( keys(%diff) ) {
carp "[warning]$me $new -> replace $old: records identical";
return '';
}
@@ -626,18 +848,18 @@ sub replace {
my $statement = "UPDATE ". $old->table. " SET ". join(', ',
map {
"$_ = ". _quote($new->getfield($_),$old->table,$_)
- } @diff
+ } real_fields($old->table)
). ' WHERE '.
join(' AND ',
map {
$old->getfield($_) eq ''
#? "( $_ IS NULL OR $_ = \"\" )"
- ? ( driver_name =~ /^Pg$/i
- ? "$_ IS NULL"
+ ? ( driver_name eq 'Pg'
+ ? "( $_ IS NULL OR $_ = '' )"
: "( $_ IS NULL OR $_ = \"\" )"
)
: "$_ = ". _quote($old->getfield($_),$old->table,$_)
- } ( $primary_key ? ( $primary_key ) : $old->fields )
+ } ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
)
;
warn "[debug]$me $statement\n" if $DEBUG > 1;
@@ -661,6 +883,44 @@ sub replace {
$h_new_sth = '';
}
+ # For virtual fields we have three cases with different SQL
+ # statements: add, replace, delete
+ my $v_add_sth;
+ my $v_rep_sth;
+ my $v_del_sth;
+ my (@add_vfields, @rep_vfields, @del_vfields);
+ my $vfp = $old->vfieldpart_hashref;
+ foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
+ if($diff{$_} eq '') {
+ # Delete
+ unless(@del_vfields) {
+ my $st = "DELETE FROM virtual_field WHERE recnum = ? ".
+ "AND vfieldpart = ?";
+ warn "[debug]$me $st\n" if $DEBUG > 2;
+ $v_del_sth = dbh->prepare($st) or return dbh->errstr;
+ }
+ push @del_vfields, $_;
+ } elsif($old->getfield($_) eq '') {
+ # Add
+ unless(@add_vfields) {
+ my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ".
+ "VALUES (?, ?, ?)";
+ warn "[debug]$me $st\n" if $DEBUG > 2;
+ $v_add_sth = dbh->prepare($st) or return dbh->errstr;
+ }
+ push @add_vfields, $_;
+ } else {
+ # Replace
+ unless(@rep_vfields) {
+ my $st = "UPDATE virtual_field SET value = ? ".
+ "WHERE recnum = ? AND vfieldpart = ?";
+ warn "[debug]$me $st\n" if $DEBUG > 2;
+ $v_rep_sth = dbh->prepare($st) or return dbh->errstr;
+ }
+ push @rep_vfields, $_;
+ }
+ }
+
local $SIG{HUP} = 'IGNORE';
local $SIG{INT} = 'IGNORE';
local $SIG{QUIT} = 'IGNORE';
@@ -672,6 +932,24 @@ sub replace {
#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;
+
+ $v_del_sth->execute($old->getfield($primary_key),
+ $vfp->{$_})
+ or return $v_del_sth->errstr
+ foreach(@del_vfields);
+
+ $v_add_sth->execute($new->getfield($_),
+ $old->getfield($primary_key),
+ $vfp->{$_})
+ or return $v_add_sth->errstr
+ foreach(@add_vfields);
+
+ $v_rep_sth->execute($new->getfield($_),
+ $old->getfield($primary_key),
+ $vfp->{$_})
+ or return $v_rep_sth->errstr
+ foreach(@rep_vfields);
+
dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
'';
@@ -685,18 +963,34 @@ 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
}
=item check
-Not yet implemented, croaks. Derived classes should provide a check method.
+Checks virtual fields (using check_blocks). Subclasses should still provide
+a check method to validate real fields, foreign keys, etc., and call this
+method via $self->SUPER::check.
+
+(FIXME: Should this method try to make sure that it I<is> being called from
+a subclass's check method, to keep the current semantics as far as possible?)
=cut
sub check {
- confess "FS::Record::check not implemented; supply one in subclass!";
+ #confess "FS::Record::check not implemented; supply one in subclass!";
+ my $self = shift;
+
+ foreach my $field ($self->virtual_fields) {
+ for ($self->getfield($field)) {
+ # See notes on check_block in FS::part_virtual_field.
+ eval $self->pvf($field)->check_block;
+ return $@ if $@;
+ $self->setfield($field, $_);
+ }
+ }
+ '';
}
sub _h_statement {
@@ -704,7 +998,7 @@ sub _h_statement {
my @fields =
grep defined($self->getfield($_)) && $self->getfield($_) ne "",
- $self->fields
+ real_fields($self->table);
;
my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields;
@@ -718,8 +1012,13 @@ sub _h_statement {
=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
@@ -728,8 +1027,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!"
@@ -745,9 +1042,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;
@@ -774,6 +1070,21 @@ sub ut_float {
'';
}
+=item ut_snumber COLUMN
+
+Check/untaint signed numeric data (whole numbers). May not be null. If there
+is an error, returns the error, otherwise returns false.
+
+=cut
+
+sub ut_snumber {
+ my($self, $field) = @_;
+ $self->getfield($field) =~ /^(-?)\s*(\d+)$/
+ or return "Illegal or empty (numeric) $field: ". $self->getfield($field);
+ $self->setfield($field, "$1$2");
+ '';
+}
+
=item ut_number COLUMN
Check/untaint simple numeric data (whole numbers). May not be null. If there
@@ -930,7 +1241,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");
'';
}
@@ -1083,36 +1394,94 @@ sub ut_foreign_keyn {
: '';
}
+
+=item virtual_fields [ TABLE ]
+
+Returns a list of virtual fields defined for the table. This should not
+be exported, and should only be called as an instance or class method.
+
+=cut
+
+sub virtual_fields {
+ my $self = shift;
+ my $table;
+ $table = $self->table or confess "virtual_fields called on non-table";
+
+ confess "Unknown table $table" unless $dbdef->table($table);
+
+ return () unless $self->dbdef->table('part_virtual_field');
+
+ unless ( $virtual_fields_cache{$table} ) {
+ my $query = 'SELECT name from part_virtual_field ' .
+ "WHERE dbtable = '$table'";
+ my $dbh = dbh;
+ my $result = $dbh->selectcol_arrayref($query);
+ confess $dbh->errstr if $dbh->err;
+ $virtual_fields_cache{$table} = $result;
+ }
+
+ @{$virtual_fields_cache{$table}};
+
+}
+
+
=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<DBIx::DBSchema::Table>).
+This is a wrapper for real_fields and virtual_fields. Code that called
+fields before should probably continue to call fields.
=cut
-# Usage: @fields = fields($table);
-# @fields = $record->fields;
sub fields {
my $something = shift;
my $table;
- if ( ref($something) ) {
+ if($something->isa('FS::Record')) {
$table = $something->table;
} else {
$table = $something;
+ $something = "FS::$table";
}
- #croak "Usage: \@fields = fields(\$table)\n or: \@fields = \$record->fields" unless $table;
- my($table_obj) = $dbdef->table($table);
- confess "Unknown table $table" unless $table_obj;
- $table_obj->columns;
+ return (real_fields($table), $something->virtual_fields());
}
=back
+=item pvf FIELD_NAME
+
+Returns the FS::part_virtual_field object corresponding to a field in the
+record (specified by FIELD_NAME).
+
+=cut
+
+sub pvf {
+ my ($self, $name) = (shift, shift);
+
+ if(grep /^$name$/, $self->virtual_fields) {
+ return qsearchs('part_virtual_field', { dbtable => $self->table,
+ name => $name } );
+ }
+ ''
+}
+
=head1 SUBROUTINES
=over 4
+=item real_fields [ TABLE ]
+
+Returns a list of the real columns in the specified table. Called only by
+fields() and other subroutines elsewhere in FS::Record.
+
+=cut
+
+sub real_fields {
+ my $table = shift;
+
+ my($table_obj) = $dbdef->table($table);
+ confess "Unknown table $table" unless $table_obj;
+ $table_obj->columns;
+}
+
=item reload_dbdef([FILENAME])
Load a database definition (see L<DBIx::DBSchema>), optionally from a
@@ -1151,28 +1520,60 @@ type (see L<DBIx::DBSchema::Column>) does not end in `char' or `binary'.
=cut
sub _quote {
- my($value,$table,$field)=@_;
- my($dbh)=dbh;
- if ( $value =~ /^\d+(\.\d+)?$/ &&
-# ! ( datatype($table,$field) =~ /^char/ )
- ! $dbdef->table($table)->column($field)->type =~ /(char|binary|text)$/i
- ) {
+ my($value, $table, $column) = @_;
+ my $column_obj = $dbdef->table($table)->column($column);
+ my $column_type = $column_obj->type;
+
+ if ( $value eq '' && $column_type =~ /^int/ ) {
+ if ( $column_obj->null ) {
+ 'NULL';
+ } else {
+ cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
+ "using 0 instead";
+ 0;
+ }
+ } elsif ( $value =~ /^\d+(\.\d+)?$/ &&
+ ! $column_type =~ /(char|binary|text)$/i ) {
$value;
} else {
- $dbh->quote($value);
+ dbh->quote($value);
}
}
+=item vfieldpart_hashref TABLE
+
+Returns a hashref of virtual field names and vfieldparts applicable to the given
+TABLE.
+
+=cut
+
+sub vfieldpart_hashref {
+ my $self = shift;
+ my $table = $self->table;
+
+ return {} unless $self->dbdef->table('part_virtual_field');
+
+ my $dbh = dbh;
+ my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
+ "dbtable = '$table'";
+ my $sth = $dbh->prepare($statement);
+ $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr;
+ return { map { $_->{name}, $_->{vfieldpart} }
+ @{$sth->fetchall_arrayref({})} };
+
+}
+
+
=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)) {
@@ -1208,7 +1609,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.)
@@ -1216,7 +1617,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.
generated by cgit v1.1 at 2024-06-23 13:17:09 +0000