X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=f4bf2a21c6339bc270e3ff84acc58c782f2d8951;hp=92fb89665f9adf0d74c1df45558104700ed82c4f;hb=ffa18709ee8a4d05e18d2d406cf73afe79e52524;hpb=ec7e8155fce544f19f2b6734476ed6db8c200aa9 diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index 92fb89665..f4bf2a21c 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -2,9 +2,11 @@ package FS::Record; use base qw( Exporter ); use strict; +use charnames ':full'; use vars qw( $AUTOLOAD - %virtual_fields_cache %fk_method_cache - $money_char $lat_lower $lon_upper + %virtual_fields_cache %fk_method_cache $fk_table_cache + %virtual_fields_hash_cache $money_char $lat_lower $lon_upper + $use_placeholders ); use Carp qw(carp cluck croak confess); use Scalar::Util qw( blessed ); @@ -16,12 +18,14 @@ use DBIx::DBSchema 0.43; #0.43 for foreign keys use Locale::Country; use Locale::Currency; use NetAddr::IP; # for validation +use Crypt::OpenSSL::RSA; 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 FS::Conf; #dependency loop bs, in install_callback below instead +use Email::Valid; use FS::part_virtual_field; @@ -34,12 +38,14 @@ our @EXPORT_OK = qw( dbh fields hfields qsearch qsearchs dbdef jsearch str2time_sql str2time_sql_closing regexp_sql not_regexp_sql concat_sql group_concat_sql - midnight_sql + midnight_sql fk_methods_init ); our $DEBUG = 0; our $me = '[FS::Record]'; +$use_placeholders = 0; + our $nowarn_identical = 0; our $nowarn_classload = 0; our $no_update_diff = 0; @@ -49,19 +55,23 @@ our $qsearch_qualify_columns = 1; our $no_check_foreign = 1; #well, not inefficiently in perl by default anymore -my $rsa_module; -my $rsa_loaded; my $rsa_encrypt; my $rsa_decrypt; our $conf = ''; our $conf_encryption = ''; +our $conf_encryptionmodule = ''; +our $conf_encryptionpublickey = ''; +our $conf_encryptionprivatekey = ''; FS::UID->install_callback( sub { eval "use FS::Conf;"; die $@ if $@; - $conf = FS::Conf->new; - $conf_encryption = $conf->exists('encryption'); + $conf = FS::Conf->new; + $conf_encryption = $conf->exists('encryption'); + $conf_encryptionmodule = $conf->config('encryptionmodule'); + $conf_encryptionpublickey = join("\n",$conf->config('encryptionpublickey')); + $conf_encryptionprivatekey = join("\n",$conf->config('encryptionprivatekey')); $money_char = $conf->config('money_char') || '$'; my $nw_coords = $conf->exists('geocode-require_nw_coordinates'); $lat_lower = $nw_coords ? 1 : -90; @@ -76,9 +86,7 @@ FS::UID->install_callback( sub { eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }"; } - foreach my $table ( dbdef->tables ) { - $fk_method_cache{$table} = fk_methods($table); - } + #fk_methods_init(); } ); @@ -96,7 +104,7 @@ FS::Record - Database record objects $record = qsearchs FS::Record 'table', \%hash; $record = qsearchs FS::Record 'table', { 'column' => 'value', ... }; - @records = qsearch FS::Record 'table', \%hash; + @records = qsearch FS::Record 'table', \%hash; @records = qsearch FS::Record 'table', { 'column' => 'value', ... }; $table = $record->table; @@ -166,14 +174,14 @@ Creates a new record. It doesn't store it in the database, though. See L<"insert"> for that. Note that the object stores this hash reference, not a distinct copy of the -hash it points to. You can ask the object for a copy with the I +hash it points to. You can ask the object for a copy with the I method. TABLE can only be omitted when a dervived class overrides the table method. =cut -sub new { +sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = {}; @@ -184,10 +192,10 @@ sub new { carp "warning: FS::Record::new called with table name ". $self->{'Table'} unless $nowarn_classload; } - + $self->{'Hash'} = shift; - foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) { + foreach my $field ( grep !defined($self->{'Hash'}{$_}), $self->fields ) { $self->{'Hash'}{$field}=''; } @@ -195,6 +203,7 @@ sub new { $self->{'modified'} = 0; + $self->_simplecache($self->{'Hash'}) if $self->can('_simplecache'); $self->_cache($self->{'Hash'}, shift) if $self->can('_cache') && @_; $self; @@ -278,6 +287,11 @@ the individual PARAMS_HASHREF queries #regular FS::TABLE methods #on it. +C<$FS::Record::qsearch_qualify_columns> package global is enabled by default. +When enabled, the WHERE clause generated from the 'hashref' parameter has +the table name prepended to each column name. WHERE column = 'value' becomes +WHERE table.coumn = 'value' + =cut my %TYPE = (); #for debugging @@ -399,10 +413,17 @@ sub qsearch { my @real_fields = grep exists($record->{$_}), real_fields($table); my $statement .= "SELECT $select FROM $stable"; - $statement .= " $addl_from" if $addl_from; + my $alias_main; + if ( $addl_from ) { + $statement .= " $addl_from"; + # detect aliasing of the main table + if ( $addl_from =~ /^\s*AS\s+(\w+)/i ) { + $alias_main = $1; + } + } if ( @real_fields ) { $statement .= ' WHERE '. join(' AND ', - get_real_fields($table, $record, \@real_fields)); + get_real_fields($table, $record, \@real_fields, $alias_main)); } $statement .= " $extra_sql" if defined($extra_sql); @@ -473,6 +494,26 @@ sub qsearch { croak $error; } + + # Determine how to format rows returned form a union query: + # + # * When all queries involved in the union are from the same table: + # Return an array of FS::$table_name objects + # + # * When union query is performed on multiple tables, + # Return an array of FS::Record objects + # ! Note: As far as I can tell, this functionality was broken, and + # ! actually results in a crash. Behavior is left intact + # ! as-is, in case the results are in use somewhere + # + # * Union query is performed on multiple table, + # and $union_options{classname_from_column} = 1 + # Return an array of FS::$classname objects, where $classname is + # derived for each row from a static field inserted each returned + # row of data. + # e.g.: SELECT custnum,first,last,'cust_main' AS `__classname`'. + + my $table = $stable[0]; my $pkey = ''; $table = '' if grep { $_ ne $table } @stable; @@ -489,8 +530,24 @@ sub qsearch { $sth->finish; + #below was refactored out to _from_hashref, this should use it at some point + my @return; - if ( eval 'scalar(@FS::'. $table. '::ISA);' ) { + if ($union_options{classname_from_column}) { + + # todo + # I'm not implementing the cache for this use case, at least not yet + # -mjackson + + for my $row (@stuff) { + my $table_class = $row->{__classname} + or die "`__classname` column must be set when ". + "using \$union_options{classname_from_column}"; + push @return, new("FS::$table_class",$row); + } + + } + elsif ( 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 ) { @@ -512,12 +569,13 @@ sub qsearch { # Check for encrypted fields and decrypt them. ## only in the local copy, not the cached object - if ( $conf_encryption + no warnings 'deprecated'; # XXX silence the warning for now + 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') + next if $field eq 'payinfo' + && ($record->isa('FS::payinfo_transaction_Mixin') || $record->isa('FS::payinfo_Mixin') ) && $record->payby && !grep { $record->payby eq $_ } @encrypt_payby; @@ -638,7 +696,7 @@ sub _query { push @statement, $statement; warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug; - + foreach my $field ( grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields @@ -721,12 +779,12 @@ sub _from_hashref { # Check for encrypted fields and decrypt them. ## only in the local copy, not the cached object - if ( $conf_encryption + 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') + next if $field eq 'payinfo' + && ($record->isa('FS::payinfo_transaction_Mixin') || $record->isa('FS::payinfo_Mixin') ) && $record->payby && !grep { $record->payby eq $_ } @encrypt_payby; @@ -749,14 +807,16 @@ sub get_real_fields { my $table = shift; my $record = shift; my $real_fields = shift; + my $alias_main = shift; # defaults to undef + $alias_main ||= $table; ## could be optimized more for readability - return ( + return ( map { my $op = '='; my $column = $_; - my $table_column = $qsearch_qualify_columns ? "$table.$column" : $column; + my $table_column = $qsearch_qualify_columns ? "$alias_main.$column" : $column; my $type = dbdef->table($table)->column($column)->type; my $value = $record->{$column}; $value = $value->{'value'} if ref($value); @@ -812,7 +872,7 @@ sub get_real_fields { } } @{ $real_fields } - ); + ); } =item by_key PRIMARY_KEY_VALUE @@ -850,7 +910,7 @@ single SELECT spanning multiple tables, and cache the results for subsequent method calls. Interface will almost definately change in an incompatible fashion. -Arguments: +Arguments: =cut @@ -934,7 +994,7 @@ sub get { # to avoid "Use of unitialized value" errors if ( defined ( $self->{Hash}->{$field} ) ) { $self->{Hash}->{$field}; - } else { + } else { ''; } } @@ -949,7 +1009,7 @@ Sets the value of the column/field/key COLUMN to VALUE. Returns VALUE. =cut -sub set { +sub set { my($self,$field,$value) = @_; $self->{'modified'} = 1; $self->{'Hash'}->{$field} = $value; @@ -970,7 +1030,7 @@ sub exists { exists($self->{Hash}->{$field}); } -=item AUTLOADED METHODS +=item AUTOLOADED METHODS $record->column is a synonym for $record->get('column'); @@ -992,10 +1052,8 @@ sub AUTOLOAD { confess "errant AUTOLOAD $field for $self (arg $value)" unless blessed($self) && $self->can('setfield'); - #$fk_method_cache{$self->table} ||= fk_methods($self->table); - if ( exists($fk_method_cache{$self->table}->{$field}) ) { + if ( my $fk_info = get_fk_method($self->table, $field) ) { - my $fk_info = $fk_method_cache{$self->table}->{$field}; my $method = $fk_info->{method} || 'qsearchs'; my $table = $fk_info->{table} || $field; my $column = $fk_info->{column}; @@ -1010,7 +1068,7 @@ sub AUTOLOAD { my %search = ( $foreign_column => $pkey_value ); # FS::Record->$method() ? they're actually just subs :/ - if ( $method eq 'qsearchs' ) { + if ( $method eq 'qsearchs' ) { return $pkey_value ? qsearchs( $table, \%search ) : ''; } elsif ( $method eq 'qsearch' ) { return $pkey_value ? qsearch( $table, \%search ) : (); @@ -1024,7 +1082,7 @@ sub AUTOLOAD { $self->setfield($field,$value); } else { $self->getfield($field); - } + } } # efficient (also, old, doesn't support FK stuff) @@ -1035,9 +1093,40 @@ sub AUTOLOAD { # $_[0]->setfield($field, $_[1]); # } else { # $_[0]->getfield($field); -# } +# } #} +# get_fk_method(TABLE, FIELD) +# Internal subroutine for fetching the foreign key descriptor for TABLE.FIELD +# if there is one. If not, returns undef. +# This will initialize fk_method_cache if it hasn't happened yet. It is the +# _only_ allowed way to access the contents of %fk_method_cache. + +# if we wanted to be even more efficient we'd create the fk methods in the +# symbol table instead of relying on AUTOLOAD every time + +sub get_fk_method { + my ($table, $field) = @_; + + # maybe should only load one table at a time? + fk_methods_init() unless exists($fk_method_cache{$table}); + + if ( exists($fk_method_cache{$table}) and + exists($fk_method_cache{$table}{$field}) ) { + return $fk_method_cache{$table}{$field}; + } else { + return undef; + } + +} + +sub fk_methods_init { + warn "[fk_methods_init]\n" if $DEBUG; + foreach my $table ( dbdef->tables ) { + $fk_method_cache{$table} = fk_methods($table); + } +} + sub fk_methods { my $table = shift; @@ -1075,11 +1164,15 @@ sub fk_methods { # (alas. why we're cached. still, might this loop better be done once at # schema load time insetad of every time we AUTOLOAD a method on a new # class?) - foreach my $f_table ( dbdef->tables ) { - foreach my $fk (dbdef->table($f_table)->foreign_keys) { - - next unless $fk->table eq $table; - + if (! defined $fk_table_cache) { + foreach my $f_table ( dbdef->tables ) { + foreach my $fk (dbdef->table($f_table)->foreign_keys) { + push @{$fk_table_cache->{$fk->table}},[$f_table,$fk]; + } + } + } + foreach my $fks (@{$fk_table_cache->{$table}}) { + my ($f_table,$fk) = @$fks; my $method = ''; if ( scalar( @{$fk->columns} ) == 1 ) { if ( ! defined($fk->references) @@ -1102,9 +1195,6 @@ sub fk_methods { } } - - } - } \%hash; @@ -1124,7 +1214,7 @@ sub hash { my($self) = @_; confess $self. ' -> hash: Hash attribute is undefined' unless defined($self->{'Hash'}); - %{ $self->{'Hash'} }; + %{ $self->{'Hash'} }; } =item hashref @@ -1280,15 +1370,14 @@ sub insert { } my $table = $self->table; - + # Encrypt before the database - if ( defined(eval '@FS::'. $table . '::encrypted_fields') - && scalar( eval '@FS::'. $table . '::encrypted_fields') - && $conf->exists('encryption') + if ( scalar( eval '@FS::'. $table . '::encrypted_fields') + && $conf_encryption ) { foreach my $field (eval '@FS::'. $table . '::encrypted_fields') { - next if $field eq 'payinfo' - && ($self->isa('FS::payinfo_transaction_Mixin') + next if $field eq 'payinfo' + && ($self->isa('FS::payinfo_transaction_Mixin') || $self->isa('FS::payinfo_Mixin') ) && $self->payby && !grep { $self->payby eq $_ } @encrypt_payby; @@ -1302,37 +1391,60 @@ sub insert { grep { defined($self->getfield($_)) && $self->getfield($_) ne "" } real_fields($table) ; - my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields; - #eslaf my $statement = "INSERT INTO $table "; - if ( @real_fields ) { - $statement .= - "( ". - join( ', ', @real_fields ). - ") VALUES (". - join( ', ', @values ). - ")" - ; - } else { + my @bind_values = (); + + if ( ! @real_fields ) { + $statement .= 'DEFAULT VALUES'; + + } else { + + if ( $use_placeholders ) { + + @bind_values = map $self->getfield($_), @real_fields; + + $statement .= + "( ". + join( ', ', @real_fields ). + ") VALUES (". + join( ', ', map '?', @real_fields ). # @bind_values ). + ")" + ; + + } else { + + my @values = map { _quote( $self->getfield($_), $table, $_) } @real_fields; + + $statement .= + "( ". + join( ', ', @real_fields ). + ") VALUES (". + join( ', ', @values ). + ")" + ; + + } + } + warn "[debug]$me $statement\n" if $DEBUG > 1; my $sth = dbh->prepare($statement) or return dbh->errstr; local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; local $SIG{TERM} = 'IGNORE'; local $SIG{TSTP} = 'IGNORE'; local $SIG{PIPE} = 'IGNORE'; - $sth->execute or return $sth->errstr; + $sth->execute(@bind_values) or return $sth->errstr; # get inserted id from the database, if applicable & needed if ( $db_seq && ! $self->getfield($primary_key) ) { warn "[debug]$me retreiving sequence from database\n" if $DEBUG; - + my $insertid = ''; if ( driver_name eq 'Pg' ) { @@ -1381,7 +1493,7 @@ sub insert { } else { dbh->rollback if $FS::UID::AutoCommit; - return "don't know how to retreive inserted ids from ". driver_name. + return "don't know how to retreive inserted ids from ". driver_name. ", try using counterfiles (maybe run dbdef-create?)"; } @@ -1405,7 +1517,7 @@ 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 + # 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}); @@ -1464,7 +1576,7 @@ sub delete { local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; local $SIG{TERM} = 'IGNORE'; local $SIG{TSTP} = 'IGNORE'; local $SIG{PIPE} = 'IGNORE'; @@ -1472,7 +1584,7 @@ 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; - + dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit; #no need to needlessly destoy the data either (causes problems actually) @@ -1522,16 +1634,15 @@ sub replace { my $error = $new->check; return $error if $error; - + # Encrypt for replace my $saved = {}; - if ( $conf->exists('encryption') - && defined(eval '@FS::'. $new->table . '::encrypted_fields') - && scalar( eval '@FS::'. $new->table . '::encrypted_fields') + if ( scalar( eval '@FS::'. $new->table . '::encrypted_fields') + && $conf_encryption ) { foreach my $field (eval '@FS::'. $new->table . '::encrypted_fields') { - next if $field eq 'payinfo' - && ($new->isa('FS::payinfo_transaction_Mixin') + next if $field eq 'payinfo' + && ($new->isa('FS::payinfo_transaction_Mixin') || $new->isa('FS::payinfo_Mixin') ) && $new->payby && !grep { $new->payby eq $_ } @encrypt_payby; @@ -1543,7 +1654,7 @@ sub replace { #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) || $no_update_diff ) { carp "[warning]$me ". ref($new)."->replace ". ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ). @@ -1554,7 +1665,7 @@ sub replace { my $statement = "UPDATE ". $old->table. " SET ". join(', ', map { - "$_ = ". _quote($new->getfield($_),$old->table,$_) + "$_ = ". _quote($new->getfield($_),$old->table,$_) } real_fields($old->table) ). ' WHERE '. join(' AND ', @@ -1604,7 +1715,7 @@ sub replace { local $SIG{HUP} = 'IGNORE'; local $SIG{INT} = 'IGNORE'; - local $SIG{QUIT} = 'IGNORE'; + local $SIG{QUIT} = 'IGNORE'; local $SIG{TERM} = 'IGNORE'; local $SIG{TSTP} = 'IGNORE'; local $SIG{PIPE} = 'IGNORE'; @@ -1616,7 +1727,7 @@ 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 + # 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}); @@ -1660,7 +1771,7 @@ non-custom fields, etc., and call this method via $self->SUPER::check. =cut -sub check { +sub check { my $self = shift; foreach my $field ($self->virtual_fields) { my $error = $self->ut_textn($field); @@ -1671,7 +1782,7 @@ sub check { =item virtual_fields [ TABLE ] -Returns a list of virtual fields defined for the table. This should not +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 @@ -1700,6 +1811,41 @@ sub virtual_fields { } +=item virtual_fields_hash [ TABLE ] + +Returns a list of virtual field records as a hash defined for the table. This should not +be exported, and should only be called as an instance or class method. + +=cut + +sub virtual_fields_hash { + 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 dbdef->table('part_virtual_field'); + + unless ( $virtual_fields_hash_cache{$table} ) { + $virtual_fields_hash_cache{$table} = []; + my $concat = [ "'cf_'", "name" ]; + my $select = concat_sql($concat).' as name, label, length'; + my @vfields = qsearch({ + select => $select, + table => 'part_virtual_field', + hashref => { 'dbtable' => $table, }, + }); + + foreach (@vfields) { + push @{ $virtual_fields_hash_cache{$table} }, $_->{Hash}; + } + } + + @{$virtual_fields_hash_cache{$table}}; + +} + =item process_batch_import JOB OPTIONS_HASHREF PARAMS Processes a batch import as a queued JSRPC job @@ -1765,8 +1911,8 @@ format_types). =back -PARAMS is a hashref (or base64-encoded Storable hashref) containing the -POSTed data. It must contain the field "uploaded files", generated by +PARAMS is a hashref (or base64-encoded Storable hashref) containing the +POSTed data. It must contain the field "uploaded files", generated by /elements/file-upload.html and containing the list of uploaded files. Currently only supports a single file named "file". @@ -1781,7 +1927,7 @@ sub process_batch_import { my %formats = %{ $opt->{formats} }; warn Dumper($param) if $DEBUG; - + my $files = $param->{'uploaded_files'} or die "No files provided.\n"; @@ -1801,6 +1947,7 @@ sub process_batch_import { format_xml_formats => $opt->{format_xml_formats}, format_asn_formats => $opt->{format_asn_formats}, format_row_callbacks => $opt->{format_row_callbacks}, + format_hash_callbacks => $opt->{format_hash_callbacks}, #per-import job => $job, file => $file, @@ -1809,6 +1956,7 @@ sub process_batch_import { params => { map { $_ => $param->{$_} } @pass_params }, #? default_csv => $opt->{default_csv}, + preinsert_callback => $opt->{preinsert_callback}, postinsert_callback => $opt->{postinsert_callback}, insert_args_callback => $opt->{insert_args_callback}, ); @@ -1847,6 +1995,8 @@ Class method for batch imports. Available params: =item format_row_callbacks +=item format_hash_callbacks - After parsing, before object creation + =item fields - Alternate way to specify import, specifying import fields directly as a listref =item preinsert_callback @@ -1889,7 +2039,7 @@ sub batch_import { my( $type, $header, $sep_char, $fixedlength_format, $xml_format, $asn_format, - $parser_opt, $row_callback, @fields ); + $parser_opt, $row_callback, $hash_callback, @fields ); my $postinsert_callback = ''; $postinsert_callback = $param->{'postinsert_callback'} @@ -1945,6 +2095,11 @@ sub batch_import { ? $param->{'format_row_callbacks'}{ $param->{'format'} } : ''; + $hash_callback = + $param->{'format_hash_callbacks'} + ? $param->{'format_hash_callbacks'}{ $param->{'format'} } + : ''; + @fields = @{ $formats->{ $format } }; } elsif ( $param->{'fields'} ) { @@ -1954,6 +2109,7 @@ sub batch_import { $sep_char = ','; $fixedlength_format = ''; $row_callback = ''; + $hash_callback = ''; @fields = @{ $param->{'fields'} }; } else { @@ -2097,6 +2253,7 @@ sub batch_import { #my $job = $param->{job}; my $line; my $imported = 0; + my $unique_skip = 0; #lines skipped because they're already in the system my( $last, $min_sec ) = ( time, 5 ); #progressbar foo while (1) { @@ -2110,7 +2267,7 @@ sub batch_import { next if $line =~ /^\s*$/; #skip empty lines $line = &{$row_callback}($line) if $row_callback; - + next if $line =~ /^\s*$/; #skip empty lines $parser->parse($line) or do { @@ -2163,7 +2320,7 @@ sub batch_import { foreach my $field ( @fields ) { my $value = shift @columns; - + if ( ref($field) eq 'CODE' ) { #&{$field}(\%hash, $value); push @later, $field, $value; @@ -2179,6 +2336,8 @@ sub batch_import { $hash{custnum} = $2; } + %hash = &{$hash_callback}(%hash) if $hash_callback; + #my $table = $param->{table}; my $class = "FS::$table"; @@ -2197,6 +2356,7 @@ sub batch_import { } last if exists( $param->{skiprow} ); } + $unique_skip++ if $param->{unique_skip}; #line is already in the system next if exists( $param->{skiprow} ); if ( $preinsert_callback ) { @@ -2242,7 +2402,8 @@ sub batch_import { unless ( $imported || $param->{empty_ok} ) { $dbh->rollback if $oldAutoCommit; - return "Empty file!"; + # freeside-cdr-conexiant-import is sensitive to the text of this message + return $unique_skip ? "All records in file were previously imported" : "Empty file!"; } $dbh->commit or die $dbh->errstr if $oldAutoCommit; @@ -2264,7 +2425,7 @@ sub _h_statement { ; # If we're encrypting then don't store the payinfo in the history - if ( $conf && $conf->exists('encryption') && $self->table ne 'banned_pay' ) { + if ( $conf_encryption && $self->table ne 'banned_pay' ) { @fields = grep { $_ ne 'payinfo' } @fields; } @@ -2284,7 +2445,7 @@ sub _h_statement { =item unique COLUMN -B: External use is B. +B: External use is B. Replaces COLUMN in record with a unique number, using counters in the filesystem. Used by the B method on single-field unique columns @@ -2455,7 +2616,7 @@ sub ut_numbern { =item ut_decimal COLUMN[, DIGITS] -Check/untaint decimal numbers (up to DIGITS decimal places. If there is an +Check/untaint decimal numbers (up to DIGITS decimal places. If there is an error, returns the error, otherwise returns false. =item ut_decimaln COLUMN[, DIGITS] @@ -2560,7 +2721,7 @@ sub ut_currency { =item ut_text COLUMN Check/untaint text. Alphanumerics, spaces, and the following punctuation -symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < > +symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < > ~ May not be null. If there is an error, returns the error, otherwise returns false. @@ -2574,7 +2735,7 @@ sub ut_text { # \p{Word} = alphanumerics, marks (diacritics), and connectors # see perldoc perluniprops $self->getfield($field) - =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/ + =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>\~$money_char]+)$/ or return gettext('illegal_or_empty_text'). " $field: ". $self->getfield($field); $self->setfield($field,$1); @@ -2620,7 +2781,7 @@ error, returns the error, otherwise returns false. sub ut_alphan { my($self,$field)=@_; - $self->getfield($field) =~ /^(\w*)$/ + $self->getfield($field) =~ /^(\w*)$/ or return "Illegal (alphanumeric) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; @@ -2635,7 +2796,7 @@ an error, returns the error, otherwise returns false. sub ut_alphasn { my($self,$field)=@_; - $self->getfield($field) =~ /^([\w ]*)$/ + $self->getfield($field) =~ /^([\w ]*)$/ or return "Illegal (alphanumeric) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; @@ -2761,11 +2922,9 @@ to 127.0.0.1. sub ut_ip { my( $self, $field ) = @_; $self->setfield($field, '127.0.0.1') if $self->getfield($field) eq '::1'; - $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.$4"); - ''; + return "Illegal (IP address) $field: ".$self->getfield($field) + unless $self->getfield($field) =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/; + $self->ut_ip46($field); } =item ut_ipn COLUMN @@ -2793,8 +2952,9 @@ Check/untaint IPv4 or IPv6 address. sub ut_ip46 { my( $self, $field ) = @_; - my $ip = NetAddr::IP->new($self->getfield($field)) - or return "Illegal (IP address) $field: ".$self->getfield($field); + my $ip = NetAddr::IP->new( + $self->_ut_ip_strip_leading_zeros( $self->getfield( $field ) ) + ) or return "Illegal (IP address) $field: ".$self->getfield($field); $self->setfield($field, lc($ip->addr)); return ''; } @@ -2814,6 +2974,21 @@ sub ut_ip46n { $self->ut_ip46($field); } +sub _ut_ip_strip_leading_zeros { + # strip user-entered leading 0's from IP addresses + # so parsers like NetAddr::IP don't mangle the address + # e.g. NetAddr::IP converts 10.0.022.220 into 10.0.18.220 + + my ( $self, $ip ) = @_; + + return join '.', map int, split /\./, $ip + if $ip + && $ip =~ /\./ + && $ip =~ /[\.^]0/; + $ip; +} + + =item ut_coord COLUMN [ LOWER [ UPPER ] ] Check/untaint coordinates. @@ -2853,6 +3028,10 @@ sub ut_coord { my $coord = $self->getfield($field); my $neg = $coord =~ s/^(-)//; + # ignore degree symbol at the end, + # but not otherwise supporting degree/minutes/seconds symbols + $coord =~ s/\N{DEGREE SIGN}\s*$//; + my ($d, $m, $s) = (0, 0, 0); if ( @@ -2947,12 +3126,11 @@ May not be null. sub ut_name { my( $self, $field ) = @_; -# warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n"; $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/ or return gettext('illegal_name'). " $field: ". $self->getfield($field); my $name = $1; - $name =~ s/^\s+//; - $name =~ s/\s+$//; + $name =~ s/^\s+//; + $name =~ s/\s+$//; $name =~ s/\s+/ /g; $self->setfield($field, $name); ''; @@ -2998,6 +3176,13 @@ sub ut_zip { $self->getfield($field); $self->setfield($field, "$1 $2"); + } elsif ( $country eq 'AU' ) { + + $self->getfield($field) =~ /^\s*(\d{4})\s*$/ + or return gettext('illegal_zip'). " $field for country $country: ". + $self->getfield($field); + $self->setfield($field, $1); + } else { if ( $self->getfield($field) =~ /^\s*$/ @@ -3026,7 +3211,7 @@ see L. sub ut_country { my( $self, $field ) = @_; unless ( $self->getfield($field) =~ /^(\w\w)$/ ) { - if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/ + if ( $self->getfield($field) =~ /^([\w \,\.\(\)\']+)$/ && country2code($1) ) { $self->setfield($field,uc(country2code($1))); } @@ -3081,6 +3266,60 @@ sub ut_enumn { : ''; } +=item ut_date COLUMN + +Check/untaint a column containing a date string. + +Date will be normalized to YYYY-MM-DD format + +=cut + +sub ut_date { + my ( $self, $field ) = @_; + my $value = $self->getfield( $field ); + + my @date = split /[\-\/]/, $value; + if ( scalar(@date) == 3 ) { + @date = @date[2,0,1] if $date[2] >= 1900; + + local $@; + my $ymd; + eval { + # DateTime will die given invalid date + $ymd = DateTime->new( + year => $date[0], + month => $date[1], + day => $date[2], + )->ymd('-'); + }; + + unless( $@ ) { + $self->setfield( $field, $ymd ) unless $value eq $ymd; + return ''; + } + + } + return "Illegal (date) field $field: $value"; +} + +=item ut_daten COLUMN + +Check/untaint a column containing a date string. + +Column may be null. + +Date will be normalized to YYYY-MM-DD format + +=cut + +sub ut_daten { + my ( $self, $field ) = @_; + + $self->getfield( $field ) =~ /^()$/ + ? $self->setfield( $field, '' ) + : $self->ut_date( $field ); +} + =item ut_flag COLUMN Check/untaint a column if it contains either an empty string or 'Y'. This @@ -3161,6 +3400,52 @@ sub ut_agentnum_acl { } + +=item ut_email COLUMN + +Check column contains a valid E-Mail address + +=cut + +sub ut_email { + my ( $self, $field ) = @_; + Email::Valid->address( $self->getfield( $field ) ) + ? '' + : "Illegal (email) field $field: ". $self->getfield( $field ); +} + +=item ut_emailn COLUMN + +Check column contains a valid E-Mail address + +May be null + +=cut + +sub ut_emailn { + my ( $self, $field ) = @_; + + $self->getfield( $field ) =~ /^$/ + ? $self->getfield( $field, '' ) + : $self->ut_email( $field ); +} + +=item trim_whitespace FIELD[, FIELD ... ] + +Strip leading and trailing spaces from the value in the named FIELD(s). + +=cut + +sub trim_whitespace { + my $self = shift; + foreach my $field (@_) { + my $value = $self->get($field); + $value =~ s/^\s+//; + $value =~ s/\s+$//; + $self->set($field, $value); + } +} + =item fields [ TABLE ] This is a wrapper for real_fields. Code that called @@ -3195,7 +3480,7 @@ sub encrypt { my ($self, $value) = @_; my $encrypted = $value; - if ($conf->exists('encryption')) { + if ($conf_encryption) { if ($self->is_encrypted($value)) { # Return the original value if it isn't plaintext. $encrypted = $value; @@ -3238,7 +3523,7 @@ You should generally not have to worry about calling this, as the system handles 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)) { + if ($conf_encryption && $self->is_encrypted($value)) { $self->loadRSA; if (ref($rsa_decrypt) =~ /::RSA/) { my $encrypted = unpack ("u*", $value); @@ -3250,29 +3535,19 @@ sub decrypt { } sub loadRSA { - my $self = shift; - #Initialize the Module - $rsa_module = 'Crypt::OpenSSL::RSA'; # The Default + my $self = shift; - if ($conf->exists('encryptionmodule') && $conf->config('encryptionmodule') ne '') { - $rsa_module = $conf->config('encryptionmodule'); - } + my $rsa_module = $conf_encryptionmodule || 'Crypt::OpenSSL::RSA'; - 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); - } + # Initialize Encryption + if ($conf_encryptionpublickey && $conf_encryptionpublickey ne '') { + $rsa_encrypt = $rsa_module->new_public_key($conf_encryptionpublickey); + } - # 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); - } + # Intitalize Decryption + if ($conf_encryptionprivatekey && $conf_encryptionprivatekey ne '') { + $rsa_decrypt = $rsa_module->new_private_key($conf_encryptionprivatekey); + } } =item h_search ACTION @@ -3336,8 +3611,8 @@ sub scalar_sql { =item count [ WHERE [, PLACEHOLDER ...] ] -Convenience method for the common case of "SELECT COUNT(*) FROM table", -with optional WHERE. Must be called as method on a class with an +Convenience method for the common case of "SELECT COUNT(*) FROM table", +with optional WHERE. Must be called as method on a class with an associated table. =cut @@ -3374,7 +3649,7 @@ sub row_exists { =item real_fields [ TABLE ] -Returns a list of the real columns in the specified table. Called only by +Returns a list of the real columns in the specified table. Called only by fields() and other subroutines elsewhere in FS::Record. =cut @@ -3389,7 +3664,7 @@ sub real_fields { =item pvf FIELD_NAME -Returns the FS::part_virtual_field object corresponding to a field in the +Returns the FS::part_virtual_field object corresponding to a field in the record (specified by FIELD_NAME). =cut @@ -3402,7 +3677,7 @@ sub pvf { my $concat = [ "'cf_'", "name" ]; return qsearchs({ table => 'part_virtual_field', hashref => { dbtable => $self->table, - name => $name + name => $name }, select => 'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name', }); @@ -3436,18 +3711,26 @@ sub _quote { cluck "WARNING: Attempting to set non-null integer $table.$column null; ". "using 0 instead"; 0; - } elsif ( $value =~ /^\d+(\.\d+)?$/ && + } elsif ( $value =~ /^\d+(\.\d+)?$/ && ! $column_type =~ /(char|binary|text)$/i ) { $value; } elsif (( $column_type =~ /^bytea$/i || $column_type =~ /(blob|varbinary)/i ) && driver_name eq 'Pg' ) { - no strict 'subs'; -# dbh->quote($value, { pg_type => PG_BYTEA() }); # doesn't work right - # Pg binary string quoting: convert each character to 3-digit octal prefixed with \\, - # single-quote the whole mess, and put an "E" in front. - return ("E'" . join('', map { sprintf('\\\\%03o', ord($_)) } split(//, $value) ) . "'"); + local $@; + + eval { $value = dbh->quote($value, { pg_type => PG_BYTEA() }); }; + + if ( $@ && $@ =~ /Wide character/i ) { + warn 'Correcting malformed UTF-8 string for binary quote()' + if $DEBUG; + utf8::decode($value); + utf8::encode($value); + $value = dbh->quote($value, { pg_type => PG_BYTEA() }); + } + + $value; } else { dbh->quote($value); } @@ -3504,7 +3787,7 @@ the current database. =cut -sub str2time_sql { +sub str2time_sql { my $driver = shift || driver_name; return 'UNIX_TIMESTAMP(' if $driver =~ /^mysql/i; @@ -3527,7 +3810,7 @@ the current database. =cut -sub str2time_sql_closing { +sub str2time_sql_closing { my $driver = shift || driver_name; return ' )::INTEGER ' if $driver =~ /^Pg/i; @@ -3601,7 +3884,7 @@ sub concat_sql { =item group_concat_sql COLUMN, DELIMITER -Returns an SQL expression to concatenate an aggregate column, using +Returns an SQL expression to concatenate an aggregate column, using GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg. =cut @@ -3619,7 +3902,7 @@ sub group_concat_sql { =item midnight_sql DATE -Returns an SQL expression to convert DATE (a unix timestamp) to midnight +Returns an SQL expression to convert DATE (a unix timestamp) to midnight on that day in the system timezone, using the default driver name. =cut @@ -3691,4 +3974,3 @@ http://poop.sf.net/ =cut 1; -