X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=fd035249be39bf9c351067093a28a9030156aafd;hb=4d10679f7b649d9343f74503b14d17fc2831c40f;hp=bdf3bcf3a1dc915ecf4844c2792e58e6e0e05ad2;hpb=196d15248930f3e54811a8b46b5ede47db678e19;p=freeside.git diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index bdf3bcf3a..fd035249b 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -12,19 +12,19 @@ use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG use Exporter; use Carp qw(carp cluck croak confess); use Scalar::Util qw( blessed ); +use File::Slurp qw( slurp ); use File::CounterFile; -use Locale::Country; use Text::CSV_XS; -use File::Slurp qw( slurp ); use DBI qw(:sql_types); use DBIx::DBSchema 0.38; -use FS::UID qw(dbh getotaker datasrc driver_name); +use Locale::Country; +use Locale::Currency; +use NetAddr::IP; # for validation +use FS::UID qw(dbh datasrc driver_name); use FS::CurrentUser; use FS::Schema qw(dbdef); use FS::SearchCache; use FS::Msgcat qw(gettext); -use NetAddr::IP; # for validation -use Data::Dumper; #use FS::Conf; #dependency loop bs, in install_callback below instead use FS::part_virtual_field; @@ -506,7 +506,7 @@ sub qsearch { # Check for encrypted fields and decrypt them. ## only in the local copy, not the cached object if ( $conf_encryption - && eval 'defined(@FS::'. $table . '::encrypted_fields)' ) { + && eval '@FS::'. $table . '::encrypted_fields' ) { foreach my $record (@return) { foreach my $field (eval '@FS::'. $table . '::encrypted_fields') { next if $field eq 'payinfo' @@ -529,6 +529,215 @@ sub qsearch { return @return; } +=item _query + +Construct the SQL statement and parameter-binding list for qsearch. Takes +the qsearch parameters. + +Returns a hash containing: +'table': The primary table name (if there is one). +'statement': The SQL statement itself. +'bind_type': An arrayref of bind types. +'value': An arrayref of parameter values. +'cache': The cache object, if one was passed. + +=cut + +sub _query { + my( @stable, @record, @cache ); + my( @select, @extra_sql, @extra_param, @order_by, @addl_from ); + my @debug = (); + my $cursor = ''; + my %union_options = (); + if ( ref($_[0]) eq 'ARRAY' ) { + my $optlist = shift; + %union_options = @_; + foreach my $href ( @$optlist ) { + push @stable, ( $href->{'table'} or die "table name is required" ); + push @record, ( $href->{'hashref'} || {} ); + push @select, ( $href->{'select'} || '*' ); + push @extra_sql, ( $href->{'extra_sql'} || '' ); + push @extra_param, ( $href->{'extra_param'} || [] ); + push @order_by, ( $href->{'order_by'} || '' ); + push @cache, ( $href->{'cache_obj'} || '' ); + push @addl_from, ( $href->{'addl_from'} || '' ); + push @debug, ( $href->{'debug'} || '' ); + } + die "at least one hashref is required" unless scalar(@stable); + } elsif ( ref($_[0]) eq 'HASH' ) { + my $opt = shift; + $stable[0] = $opt->{'table'} or die "table name is required"; + $record[0] = $opt->{'hashref'} || {}; + $select[0] = $opt->{'select'} || '*'; + $extra_sql[0] = $opt->{'extra_sql'} || ''; + $extra_param[0] = $opt->{'extra_param'} || []; + $order_by[0] = $opt->{'order_by'} || ''; + $cache[0] = $opt->{'cache_obj'} || ''; + $addl_from[0] = $opt->{'addl_from'} || ''; + $debug[0] = $opt->{'debug'} || ''; + } else { + ( $stable[0], + $record[0], + $select[0], + $extra_sql[0], + $cache[0], + $addl_from[0] + ) = @_; + $select[0] ||= '*'; + } + my $cache = $cache[0]; + + my @statement = (); + my @value = (); + my @bind_type = (); + + my $result_table = $stable[0]; + foreach my $stable ( @stable ) { + #stop altering the caller's hashref + my $record = { %{ shift(@record) || {} } };#and be liberal in receipt + my $select = shift @select; + my $extra_sql = shift @extra_sql; + my $extra_param = shift @extra_param; + my $order_by = shift @order_by; + my $cache = shift @cache; + my $addl_from = shift @addl_from; + my $debug = shift @debug; + + #$stable =~ /^([\w\_]+)$/ or die "Illegal table: $table"; + #for jsearch + $stable =~ /^([\w\s\(\)\.\,\=]+)$/ or die "Illegal table: $stable"; + $stable = $1; + + $result_table = '' if $result_table ne $stable; + + my $table = $cache ? $cache->table : $stable; + my $dbdef_table = dbdef->table($table) + or die "No schema for table $table found - ". + "do you need to run freeside-upgrade?"; + my $pkey = $dbdef_table->primary_key; + + my @real_fields = grep exists($record->{$_}), real_fields($table); + + my $statement .= "SELECT $select FROM $stable"; + $statement .= " $addl_from" if $addl_from; + if ( @real_fields ) { + $statement .= ' WHERE '. join(' AND ', + get_real_fields($table, $record, \@real_fields)); + } + + $statement .= " $extra_sql" if defined($extra_sql); + $statement .= " $order_by" if defined($order_by); + + push @statement, $statement; + + warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug; + + + foreach my $field ( + grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields + ) { + + my $value = $record->{$field}; + my $op = (ref($value) && $value->{op}) ? $value->{op} : '='; + $value = $value->{'value'} if ref($value); + my $type = dbdef->table($table)->column($field)->type; + + my $bind_type = _bind_type($type, $value); + + #if ( $DEBUG > 2 ) { + # no strict 'refs'; + # %TYPE = map { &{"DBI::$_"}() => $_ } @{ $DBI::EXPORT_TAGS{sql_types} } + # unless keys %TYPE; + # warn " bind_param $bind (for field $field), $value, TYPE $TYPE{$TYPE}\n"; + #} + + push @value, $value; + push @bind_type, $bind_type; + + } + + foreach my $param ( @$extra_param ) { + my $bind_type = { TYPE => SQL_VARCHAR }; + my $value = $param; + if ( ref($param) ) { + $value = $param->[0]; + my $type = $param->[1]; + $bind_type = _bind_type($type, $value); + } + push @value, $value; + push @bind_type, $bind_type; + } + } + + my $statement = join( ' ) UNION ( ', @statement ); + $statement = "( $statement )" if scalar(@statement) > 1; + $statement .= " $union_options{order_by}" if $union_options{order_by}; + + return { + statement => $statement, + bind_type => \@bind_type, + value => \@value, + table => $result_table, + cache => $cache, + }; +} + +# qsearch should eventually use this +sub _from_hashref { + my ($table, $cache, @hashrefs) = @_; + my @return; + # XXX get rid of these string evals at some point + # (when we have time to test it) + # my $class = "FS::$table" if $table; + # if ( $class and $class->isa('FS::Record') ) + # if ( $class->can('new') eq \&new ) + # + if ( $table && 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 ) { + @return = map { + new_or_cached( "FS::$table", { %{$_} }, $cache ) + } @hashrefs; + } else { + @return = map { + new( "FS::$table", { %{$_} } ) + } @hashrefs; + } + } else { + #okay, its been tested + # warn "untested code (class FS::$table uses custom new method)"; + @return = map { + eval 'FS::'. $table. '->new( { %{$_} } )'; + } @hashrefs; + } + + # Check for encrypted fields and decrypt them. + ## only in the local copy, not the cached object + if ( $conf_encryption + && eval '@FS::'. $table . '::encrypted_fields' ) { + foreach my $record (@return) { + foreach my $field (eval '@FS::'. $table . '::encrypted_fields') { + next if $field eq 'payinfo' + && ($record->isa('FS::payinfo_transaction_Mixin') + || $record->isa('FS::payinfo_Mixin') ) + && $record->payby + && !grep { $record->payby eq $_ } @encrypt_payby; + # 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" + unless $nowarn_classload; + @return = map { + FS::Record->new( $table, { %{$_} } ); + } @hashrefs; + } + return @return; +} + ## makes this easier to read sub get_real_fields { @@ -1528,6 +1737,7 @@ csv, xls, fixedlength, xml =cut +use Data::Dumper; sub batch_import { my $param = shift; @@ -1697,7 +1907,7 @@ sub batch_import { my $data = slurp($file); my $asn_output = $parser->decode( $data ) - or die "No ". $asn_format->{'macro'}. " found\n"; + or return "No ". $asn_format->{'macro'}. " found\n"; $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output ); @@ -1881,7 +2091,7 @@ sub batch_import { return "Empty file!"; } - $dbh->commit or die $dbh->errstr if $oldAutoCommit;; + $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; #no error @@ -1907,9 +2117,13 @@ sub _h_statement { my @values = map { _quote( $self->getfield($_), $self->table, $_) } @fields; "INSERT INTO h_". $self->table. " ( ". - join(', ', qw(history_date history_user history_action), @fields ). + join(', ', qw(history_date history_usernum history_action), @fields ). ") VALUES (". - join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values). + join(', ', $time, + $FS::CurrentUser::CurrentUser->usernum, + dbh->quote($action), + @values + ). ")" ; } @@ -1940,11 +2154,6 @@ sub unique { #warn "field $field is tainted" if is_tainted($field); my($counter) = new File::CounterFile "$table.$field",0; -# hack for web demo -# getotaker() =~ /^([\w\-]{1,16})$/ or die "Illegal CGI REMOTE_USER!"; -# my($user)=$1; -# my($counter) = new File::CounterFile "$user/$table.$field",0; -# endhack my $index = $counter->inc; $index = $counter->inc while qsearchs($table, { $field=>$index } ); @@ -2130,6 +2339,41 @@ sub ut_moneyn { $self->ut_money($field); } +=item ut_currencyn COLUMN + +Check/untaint currency indicators, such as USD or EUR. May be null. If there +is an error, returns the error, otherwise returns false. + +=cut + +sub ut_currencyn { + my($self, $field) = @_; + if ($self->getfield($field) eq '') { #can be null + $self->setfield($field, ''); + return ''; + } + $self->ut_currency($field); +} + +=item ut_currency COLUMN + +Check/untaint currency indicators, such as USD or EUR. May not be null. If +there is an error, returns the error, otherwise returns false. + +=cut + +sub ut_currency { + my($self, $field) = @_; + my $value = uc( $self->getfield($field) ); + if ( code2currency($value) ) { + $self->setfield($value); + } else { + return "Unknown currency $value"; + } + + ''; +} + =item ut_text COLUMN Check/untaint text. Alphanumerics, spaces, and the following punctuation