X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=5c8a322c92af34fe9c8bdaee139a07d7efa2666e;hp=c3d783232413b1ab52e336d71a8b4de6d92979fa;hb=c2146ae32fdef80049abfa13098db2d45f3ebdd5;hpb=4d80033767fa916faa15709e69bafaf9a939a5a1 diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index c3d783232..5c8a322c9 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -2,17 +2,18 @@ package FS::Record; use strict; use vars qw( $dbdef_file $dbdef $setup_hack $AUTOLOAD @ISA @EXPORT_OK $DEBUG - $me %dbdef_cache %virtual_fields_cache ); + $me %dbdef_cache %virtual_fields_cache $nowarn_identical ); 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.23; +use DBIx::DBSchema 0.25; use FS::UID qw(dbh getotaker datasrc driver_name); use FS::SearchCache; use FS::Msgcat qw(gettext); +use FS::Conf; use FS::part_virtual_field; @@ -24,8 +25,17 @@ use Tie::IxHash; $DEBUG = 0; $me = '[FS::Record]'; +$nowarn_identical = 0; + +my $conf; +my $rsa_module; +my $rsa_loaded; +my $rsa_encrypt; +my $rsa_decrypt; + #ask FS::UID to run this stuff for us later $FS::UID::callback{'FS::Record'} = 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? @@ -131,14 +141,18 @@ sub new { $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; } @@ -176,7 +190,7 @@ sub create { } } -=item qsearch TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ +=item qsearch 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 @@ -195,7 +209,7 @@ objects. =cut sub qsearch { - my($stable, $record, $select, $extra_sql, $cache ) = @_; + my($stable, $record, $select, $extra_sql, $cache, $addl_from ) = @_; #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table"; #for jsearch $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable"; @@ -210,9 +224,16 @@ sub qsearch { 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 { @@ -328,10 +349,15 @@ sub qsearch { $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; @@ -340,6 +366,7 @@ sub qsearch { } $sth->finish; + if ( keys(%result) and @virtual_fields ) { $statement = "SELECT virtual_field.recnum, part_virtual_field.name, ". @@ -362,32 +389,42 @@ sub qsearch { } } } - + 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 jsearch TABLE, HASHREF, SELECT, EXTRA_SQL, PRIMARY_TABLE, PRIMARY_KEY @@ -411,7 +448,7 @@ sub jsearch { ); } -=item qsearchs TABLE, HASHREF +=item qsearchs TABLE, HASHREF, SELECT, EXTRA_SQL, CACHE_OBJ, ADDL_FROM Same as qsearch, except that if more than one record matches, it Bs but returns the first. If this happens, you either made a logic error in asking @@ -422,7 +459,7 @@ for a single item, or your data is corrupted. 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]) : (); @@ -486,6 +523,7 @@ Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE. sub set { my($self,$field,$value) = @_; + $self->{'modified'} = 1; $self->{'Hash'}->{$field} = $value; } sub setfield { @@ -547,7 +585,9 @@ sub 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 @@ -556,6 +596,19 @@ sub hashref { $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, @@ -565,6 +618,7 @@ otherwise returns false. sub insert { my $self = shift; + my $saved = {}; my $error = $self->check; return $error if $error; @@ -595,6 +649,17 @@ sub insert { } 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 "", @@ -708,6 +773,12 @@ sub insert { 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}); + } + ''; } @@ -812,11 +883,9 @@ returns the error, otherwise returns false. sub replace { my $new = shift; + my $old = shift; - my $old; - if ( @_ ) { - $old = shift; - } else { + 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; @@ -834,19 +903,31 @@ sub replace { 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 ''; } @@ -857,13 +938,25 @@ sub replace { ). ' WHERE '. join(' AND ', map { - $old->getfield($_) eq '' - #? "( $_ IS NULL OR $_ = \"\" )" - ? ( driver_name eq 'Pg' - ? "( $_ IS NULL OR $_ = '' )" - : "( $_ 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) ) ) ; @@ -957,6 +1050,12 @@ sub replace { 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}); + } + ''; } @@ -1006,7 +1105,9 @@ sub check { } sub _h_statement { - my( $self, $action ) = @_; + my( $self, $action, $time ) = @_; + + $time ||= time; my @fields = grep defined($self->getfield($_)) && $self->getfield($_) ne "", @@ -1017,7 +1118,7 @@ sub _h_statement { "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). ")" ; } @@ -1392,7 +1493,7 @@ on the column first. 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"; ''; } @@ -1539,9 +1640,14 @@ sub _quote { my($value, $table, $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; ". @@ -1605,6 +1711,79 @@ sub _dump { } (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 { @@ -1669,6 +1848,8 @@ L, L, L Adapter::DBI from Ch. 11 of Advanced Perl Programming by Sriram Srinivasan. +http://poop.sf.net/ + =cut 1;