package FS::Record;
use strict;
-use vars qw( $dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK $DEBUG
- $me %dbdef_cache );
-use subs qw(reload_dbdef);
+use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG
+ $me %virtual_fields_cache $nowarn_identical );
use Exporter;
use Carp qw(carp cluck croak confess);
use File::CounterFile;
use Locale::Country;
use DBI qw(:sql_types);
-use DBIx::DBSchema 0.21;
+use DBIx::DBSchema 0.25;
use FS::UID qw(dbh getotaker datasrc driver_name);
+use FS::Schema qw(dbdef);
use FS::SearchCache;
use FS::Msgcat qw(gettext);
+use FS::Conf;
use FS::part_virtual_field;
use Tie::IxHash;
@ISA = qw(Exporter);
+
+#export dbdef for now... everything else expects to find it here
@EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch);
-$DEBUG = 2;
+$DEBUG = 0;
$me = '[FS::Record]';
-#ask FS::UID to run this stuff for us later
-$FS::UID::callback{'FS::Record'} = sub {
+$nowarn_identical = 0;
+
+my $conf;
+my $rsa_module;
+my $rsa_loaded;
+my $rsa_encrypt;
+my $rsa_decrypt;
+
+FS::UID->install_callback( sub {
+ $conf = new FS::Conf;
$File::CounterFile::DEFAULT_DIR = "/usr/local/etc/freeside/counters.". datasrc;
- $dbdef_file = "/usr/local/etc/freeside/dbdef.". datasrc;
- &reload_dbdef unless $setup_hack; #$setup_hack needed now?
-};
+} );
=head1 NAME
=head1 SYNOPSIS
use FS::Record;
- use FS::Record qw(dbh fields qsearch qsearchs dbdef);
+ use FS::Record qw(dbh fields qsearch qsearchs);
$record = new FS::Record 'table', \%hash;
$record = new FS::Record 'table', { 'column' => 'value', ... };
$error = $record->ut_anything('column');
$error = $record->ut_name('column');
- $dbdef = reload_dbdef;
- $dbdef = reload_dbdef "/non/standard/filename";
- $dbdef = dbdef;
-
$quoted_value = _quote($value,'table','field');
#deprecated
$self->{'Table'} = shift;
carp "warning: FS::Record::new called with table name ". $self->{'Table'};
}
+
+ $self->{'Hash'} = shift;
- my $hashref = $self->{'Hash'} = shift;
-
- foreach my $field ( grep !defined($hashref->{$_}), $self->fields ) {
- $hashref->{$field}='';
+ foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) {
+ $self->{'Hash'}{$field}='';
}
- $self->_cache($hashref, shift) if $self->can('_cache') && @_;
+ $self->_rebless if $self->can('_rebless');
+
+ $self->{'modified'} = 0;
+
+ $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_;
$self;
}
}
}
-=item qsearch TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ
+=item qsearch PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
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.
+The preferred usage is to pass a hash reference of named parameters:
+
+ my @records = qsearch( {
+ 'table' => 'table_name',
+ 'hashref' => { 'field' => 'value'
+ 'field' => { 'op' => '<',
+ 'value' => '420',
+ },
+ },
+
+ #these are optional...
+ 'select' => '*',
+ 'extra_sql' => 'AND field ',
+ #'cache_obj' => '', #optional
+ 'addl_from' => 'LEFT JOIN othtable USING ( field )',
+ }
+ );
+
+Much code still uses old-style positional parameters, this is also probably
+fine in the common case where there are only two parameters:
+
+ my @records = qsearch( 'table', { 'field' => 'value' } );
+
###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
=cut
sub qsearch {
- my($stable, $record, $select, $extra_sql, $cache ) = @_;
+ my($stable, $record, $select, $extra_sql, $cache, $addl_from );
+ if ( ref($_[0]) ) { #hashref for now, eventually maybe accept a list too
+ my $opt = shift;
+ $stable = $opt->{'table'} or die "table name is required";
+ $record = $opt->{'hashref'} || {};
+ $select = $opt->{'select'} || '*';
+ $extra_sql = $opt->{'extra_sql'} || '';
+ $cache = $opt->{'cache_obj'} || '';
+ $addl_from = $opt->{'addl_from'} || '';
+ } else {
+ ($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_;
+ $select ||= '*';
+ }
+
#$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 $pkey = $dbdef->table($table)->primary_key;
+ my $dbdef_table = dbdef->table($table)
+ or die "No schema for table $table found - ".
+ "do you need to create it or run dbdef-create?";
+ my $pkey = $dbdef_table->primary_key;
my @real_fields = grep exists($record->{$_}), real_fields($table);
- my @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
+ my @virtual_fields;
+ if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
+ @virtual_fields = grep exists($record->{$_}), "FS::$table"->virtual_fields;
+ } else {
+ cluck "warning: FS::$table not loaded; virtual fields not searchable";
+ @virtual_fields = ();
+ }
my $statement = "SELECT $select FROM $stable";
+ $statement .= " $addl_from" if $addl_from;
if ( @real_fields or @virtual_fields ) {
$statement .= ' WHERE '. join(' AND ',
( map {
if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) {
if ( $op eq '=' ) {
if ( driver_name eq 'Pg' ) {
- if ( $dbdef->table($table)->column($column)->type =~ /(int)/i ) {
+ my $type = dbdef->table($table)->column($column)->type;
+ if ( $type =~ /(int|serial)/i ) {
qq-( $column IS NULL )-;
} else {
qq-( $column IS NULL OR $column = '' )-;
}
} elsif ( $op eq '!=' ) {
if ( driver_name eq 'Pg' ) {
- if ( $dbdef->table($table)->column($column)->type =~ /(int)/i ) {
+ 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 != '' )-;
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 {
$sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
+ if ( eval 'scalar(@FS::'. $table. '::ISA);' ) {
+ @virtual_fields = "FS::$table"->virtual_fields;
+ } else {
+ cluck "warning: FS::$table not loaded; virtual fields not returned either";
+ @virtual_fields = ();
+ }
+
my %result;
tie %result, "Tie::IxHash";
- @virtual_fields = "FS::$table"->virtual_fields;
-
my @stuff = @{ $sth->fetchall_arrayref( {} ) };
if($pkey) {
%result = map { $_->{$pkey}, $_ } @stuff;
}
$sth->finish;
+
if ( keys(%result) and @virtual_fields ) {
$statement =
"SELECT virtual_field.recnum, part_virtual_field.name, ".
}
}
}
-
+ my @return;
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 {
+ @return = map {
new_or_cached( "FS::$table", { %{$_} }, $cache )
} values(%result);
} else {
- map {
+ @return = map {
new( "FS::$table", { %{$_} } )
} values(%result);
}
} else {
warn "untested code (class FS::$table uses custom new method)";
- map {
+ @return = map {
eval 'FS::'. $table. '->new( { %{$_} } )';
} values(%result);
}
+
+ # Check for encrypted fields and decrypt them.
+ if ($conf->exists('encryption') && eval 'defined(@FS::'. $table . '::encrypted_fields)') {
+ foreach my $record (@return) {
+ foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
+ # Set it directly... This may cause a problem in the future...
+ $record->setfield($field, $record->decrypt($record->getfield($field)));
+ }
+ }
+ }
} else {
cluck "warning: FS::$table not loaded; returning FS::Record objects";
- map {
+ @return = map {
FS::Record->new( $table, { %{$_} } );
} values(%result);
}
+ return @return;
+}
+
+=item by_key PRIMARY_KEY_VALUE
+
+This is a class method that returns the record with the given primary key
+value. This method is only useful in FS::Record subclasses. For example:
+ my $cust_main = FS::cust_main->by_key(1); # retrieve customer with custnum 1
+
+is equivalent to:
+
+ my $cust_main = qsearchs('cust_main', { 'custnum' => 1 } );
+
+=cut
+
+sub by_key {
+ my ($class, $pkey_value) = @_;
+
+ my $table = $class->table
+ or croak "No table for $class found";
+
+ my $dbdef_table = dbdef->table($table)
+ or die "No schema for table $table found - ".
+ "do you need to create it or run dbdef-create?";
+ my $pkey = $dbdef_table->primary_key
+ or die "No primary key for table $table";
+
+ return qsearchs($table, { $pkey => $pkey_value });
}
=item jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY
);
}
-=item qsearchs TABLE, HASHREF
+=item qsearchs PARAMS_HASHREF | TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM
Same as qsearch, except that if more than one record matches, it B<carp>s but
returns the first. If this happens, you either made a logic error in asking
sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash);
my $table = $_[0];
my(@result) = qsearch(@_);
- carp "warning: Multiple records in scalar search ($table)"
+ cluck "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]) : ();
sub dbdef_table {
my($self)=@_;
my($table)=$self->table;
- $dbdef->table($table);
+ dbdef->table($table);
}
=item get, getfield COLUMN
sub set {
my($self,$field,$value) = @_;
+ $self->{'modified'} = 1;
$self->{'Hash'}->{$field} = $value;
}
sub setfield {
sub hash {
my($self) = @_;
+ confess $self. ' -> hash: Hash attribute is undefined'
+ unless defined($self->{'Hash'});
%{ $self->{'Hash'} };
}
=item hashref
-Returns a reference to the column/value hash.
+Returns a reference to the column/value hash. This may be deprecated in the
+future; if there's a reason you can't just use the autoloaded or get/set
+methods, speak up.
=cut
$self->{'Hash'};
}
+=item modified
+
+Returns true if any of this object's values have been modified with set (or via
+an autoloaded method). Doesn't yet recognize when you retreive a hashref and
+modify that.
+
+=cut
+
+sub modified {
+ my $self = shift;
+ $self->{'modified'};
+}
+
=item insert
Inserts this record to the database. If there is an error, returns the error,
sub insert {
my $self = shift;
+ my $saved = {};
my $error = $self->check;
return $error if $error;
}
my $table = $self->table;
+
+
+ # Encrypt before the database
+ if ($conf->exists('encryption') && defined(eval '@FS::'. $table . 'encrypted_fields')) {
+ foreach my $field (eval '@FS::'. $table . '::encrypted_fields') {
+ $self->{'saved'} = $self->getfield($field);
+ $self->setfield($field, $self->enrypt($self->getfield($field)));
+ }
+ }
+
+
#false laziness w/delete
my @real_fields =
grep defined($self->getfield($_)) && $self->getfield($_) ne "",
if (@virtual_fields) {
my %v_values = map { $_, $self->getfield($_) } @virtual_fields;
- my $vfieldpart = vfieldpart_hashref($table);
+ my $vfieldpart = $self->vfieldpart_hashref;
my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ".
"VALUES (?, ?, ?)";
my $h_sth;
- if ( defined $dbdef->table('h_'. $table) ) {
+ 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->commit or croak dbh->errstr if $FS::UID::AutoCommit;
+ # Now that it has been saved, reset the encrypted fields so that $new
+ # can still be used.
+ foreach my $field (keys %{$saved}) {
+ $self->setfield($field, $saved->{$field});
+ }
+
'';
}
my $sth = dbh->prepare($statement) or return dbh->errstr;
my $h_sth;
- if ( defined $dbdef->table('h_'. $self->table) ) {
+ 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;
my $primary_key = $self->dbdef_table->primary_key;
my $v_sth;
my @del_vfields;
- my $vfp = vfieldpart_hashref($self->table);
+ my $vfp = $self->vfieldpart_hashref;
foreach($self->virtual_fields) {
next if $self->getfield($_) eq '';
unless(@del_vfields) {
=cut
sub replace {
- my ( $new, $old ) = ( shift, shift );
+ my $new = shift;
+ my $old = shift;
+
+ if (!defined($old)) {
+ 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;
my $primary_key = $old->dbdef_table->primary_key;
- return "Can't change $primary_key"
+ return "Can't change primary key $primary_key ".
+ 'from '. $old->getfield($primary_key).
+ ' to ' . $new->getfield($primary_key)
if $primary_key
&& ( $old->getfield($primary_key) ne $new->getfield($primary_key) );
my $error = $new->check;
return $error if $error;
+
+ # Encrypt for replace
+ my $saved = {};
+ if ($conf->exists('encryption') && defined(eval '@FS::'. $new->table . 'encrypted_fields')) {
+ foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') {
+ $saved->{$field} = $new->getfield($field);
+ $new->setfield($field, $new->encrypt($new->getfield($field)));
+ }
+ }
#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";
+ carp "[warning]$me $new -> replace $old: records identical"
+ unless $nowarn_identical;
return '';
}
). ' WHERE '.
join(' AND ',
map {
- $old->getfield($_) eq ''
- #? "( $_ IS NULL OR $_ = \"\" )"
- ? ( driver_name eq 'Pg'
- ? "$_ IS NULL"
- : "( $_ IS NULL OR $_ = \"\" )"
- )
- : "$_ = ". _quote($old->getfield($_),$old->table,$_)
+
+ if ( $old->getfield($_) eq '' ) {
+
+ #false laziness w/qsearch
+ if ( driver_name eq 'Pg' ) {
+ my $type = $old->dbdef_table->column($_)->type;
+ if ( $type =~ /(int|serial)/i ) {
+ qq-( $_ IS NULL )-;
+ } else {
+ qq-( $_ IS NULL OR $_ = '' )-;
+ }
+ } else {
+ qq-( $_ IS NULL OR $_ = "" )-;
+ }
+
+ } else {
+ "$_ = ". _quote($old->getfield($_),$old->table,$_);
+ }
+
} ( $primary_key ? ( $primary_key ) : real_fields($old->table) )
)
;
my $sth = dbh->prepare($statement) or return dbh->errstr;
my $h_old_sth;
- if ( defined $dbdef->table('h_'. $old->table) ) {
+ 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;
}
my $h_new_sth;
- if ( defined $dbdef->table('h_'. $new->table) ) {
+ 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;
my $v_rep_sth;
my $v_del_sth;
my (@add_vfields, @rep_vfields, @del_vfields);
- my $vfp = vfieldpart_hashref($old->table);
+ my $vfp = $old->vfieldpart_hashref;
foreach(grep { exists($diff{$_}) } $new->virtual_fields) {
if($diff{$_} eq '') {
# Delete
dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit;
+ # Now that it has been saved, reset the encrypted fields so that $new
+ # can still be used.
+ foreach my $field (keys %{$saved}) {
+ $new->setfield($field, $saved->{$field});
+ }
+
'';
}
for ($self->getfield($field)) {
# See notes on check_block in FS::part_virtual_field.
eval $self->pvf($field)->check_block;
- return $@ if $@;
+ if ( $@ ) {
+ #this is bad, probably want to follow the stack backtrace up and see
+ #wtf happened
+ my $err = "Fatal error checking $field for $self";
+ cluck "$err: $@";
+ return "$err (see log for backtrace): $@";
+
+ }
$self->setfield($field, $_);
}
}
}
sub _h_statement {
- my( $self, $action ) = @_;
+ my( $self, $action, $time ) = @_;
+
+ $time ||= time;
my @fields =
grep defined($self->getfield($_)) && $self->getfield($_) ne "",
"INSERT INTO h_". $self->table. " ( ".
join(', ', qw(history_date history_user history_action), @fields ).
") VALUES (".
- join(', ', time, dbh->quote(getotaker()), dbh->quote($action), @values).
+ join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values).
")"
;
}
'';
}
+=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
$self->getfield($field);
$self->setfield($field,$1);
} else {
- $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
- or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
- $self->setfield($field,$1);
+ if ( $self->getfield($field) =~ /^\s*$/ ) {
+ $self->setfield($field,'');
+ } else {
+ $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/
+ or return gettext('illegal_zip'). " $field: ". $self->getfield($field);
+ $self->setfield($field,$1);
+ }
}
'';
}
sub ut_foreign_key {
my( $self, $field, $table, $foreign ) = @_;
qsearchs($table, { $foreign => $self->getfield($field) })
- or return "Can't find $field ". $self->getfield($field).
+ or return "Can't find ". $self->table. ".$field ". $self->getfield($field).
" in $table.$foreign";
'';
}
=cut
sub virtual_fields {
- my $something = shift;
+ my $self = shift;
my $table;
- $table = $something->table or confess "virtual_fields called on non-table";
+ $table = $self->table or confess "virtual_fields called on non-table";
- confess "Unknown table $table" unless $dbdef->table($table);
+ confess "Unknown table $table" unless dbdef->table($table);
- # This should be smart enough to cache results.
+ return () unless 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}};
- 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;
- return @$result;
}
sub real_fields {
my $table = shift;
- my($table_obj) = $dbdef->table($table);
+ 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
-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;
-
- 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<DBIx::DBSchema>.
-
-=cut
-
-sub dbdef { $dbdef; }
-
=item _quote VALUE, TABLE, COLUMN
This is an internal function used to construct SQL statements. It returns
sub _quote {
my($value, $table, $column) = @_;
- my $column_obj = $dbdef->table($table)->column($column);
+ my $column_obj = dbdef->table($table)->column($column);
my $column_type = $column_obj->type;
+ my $nullable = $column_obj->null;
+
+ warn " $table.$column: $value ($column_type".
+ ( $nullable ? ' NULL' : ' NOT NULL' ).
+ ")\n" if $DEBUG > 2;
if ( $value eq '' && $column_type =~ /^int/ ) {
- if ( $column_obj->null ) {
+ if ( $nullable ) {
'NULL';
} else {
cluck "WARNING: Attempting to set non-null integer $table.$column null; ".
=cut
sub vfieldpart_hashref {
- my ($table) = @_;
+ my $self = shift;
+ my $table = $self->table;
+
+ return {} unless dbdef->table('part_virtual_field');
- return () unless $table;
my $dbh = dbh;
my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ".
"dbtable = '$table'";
} (fields($self->table)) );
}
+sub encrypt {
+ my ($self, $value) = @_;
+ my $encrypted;
+
+ if ($conf->exists('encryption')) {
+ if ($self->is_encrypted($value)) {
+ # Return the original value if it isn't plaintext.
+ $encrypted = $value;
+ } else {
+ $self->loadRSA;
+ if (ref($rsa_encrypt) =~ /::RSA/) { # We Can Encrypt
+ # RSA doesn't like the empty string so let's pack it up
+ # The database doesn't like the RSA data so uuencode it
+ my $length = length($value)+1;
+ $encrypted = pack("u*",$rsa_encrypt->encrypt(pack("Z$length",$value)));
+ } else {
+ die ("You can't encrypt w/o a valid RSA engine - Check your installation or disable encryption");
+ }
+ }
+ }
+ return $encrypted;
+}
+
+sub is_encrypted {
+ my ($self, $value) = @_;
+ # Possible Bug - Some work may be required here....
+
+ if (length($value) > 80) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub decrypt {
+ my ($self,$value) = @_;
+ my $decrypted = $value; # Will return the original value if it isn't encrypted or can't be decrypted.
+ if ($conf->exists('encryption') && $self->is_encrypted($value)) {
+ $self->loadRSA;
+ if (ref($rsa_decrypt) =~ /::RSA/) {
+ my $encrypted = unpack ("u*", $value);
+ $decrypted = unpack("Z*", $rsa_decrypt->decrypt($encrypted));
+ }
+ }
+ return $decrypted;
+}
+
+sub loadRSA {
+ my $self = shift;
+ #Initialize the Module
+ $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default
+
+ if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') {
+ $rsa_module = $conf->config('encryptionmodule');
+ }
+
+ if (!$rsa_loaded) {
+ eval ("require $rsa_module"); # No need to import the namespace
+ $rsa_loaded++;
+ }
+ # Initialize Encryption
+ if ($conf->exists('encryptionpublickey') && $conf->config('encryptionpublickey') ne '') {
+ my $public_key = join("\n",$conf->config('encryptionpublickey'));
+ $rsa_encrypt = $rsa_module->new_public_key($public_key);
+ }
+
+ # Intitalize Decryption
+ if ($conf->exists('encryptionprivatekey') && $conf->config('encryptionprivatekey') ne '') {
+ my $private_key = join("\n",$conf->config('encryptionprivatekey'));
+ $rsa_decrypt = $rsa_module->new_private_key($private_key);
+ }
+}
+
sub DESTROY { return; }
#sub DESTROY {
Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan.
+http://poop.sf.net/
+
=cut
1;
projects / freeside.git / blobdiff