$conf $conf_encryption $money_char $lat_lower $lon_upper
$me
$nowarn_identical $nowarn_classload
- $no_update_diff $no_check_foreign
+ $no_update_diff $no_history $no_check_foreign
@encrypt_payby
);
use Exporter;
$nowarn_identical = 0;
$nowarn_classload = 0;
$no_update_diff = 0;
+$no_history = 0;
$no_check_foreign = 0;
my $rsa_module;
# grep defined( $record->{$_} ) && $record->{$_} ne '', @fields
# ) or croak "Error executing \"$statement\": ". $sth->errstr;
- $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr;
+ my $ok = $sth->execute;
+ if (!$ok) {
+ my $error = "Error executing \"$statement\"";
+ $error .= ' (' . join(', ', map {"'$_'"} @value) . ')' if @value;
+ $error .= ': '. $sth->errstr;
+ croak $error;
+ }
my $table = $stable[0];
my $pkey = '';
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 'defined(@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 {
}
my $h_sth;
- if ( defined dbdef->table('h_'. $table) ) {
+ if ( defined( dbdef->table('h_'. $table) ) && ! $no_history ) {
my $h_statement = $self->_h_statement('insert');
warn "[debug]$me $h_statement\n" if $DEBUG > 2;
$h_sth = dbh->prepare($h_statement) or do {
my $file = $param->{file};
my $params = $param->{params} || {};
+ my $custnum_prefix = $conf->config('cust_main-custnum-display_prefix');
+ my $custnum_length = $conf->config('cust_main-custnum-display_length') || 8;
+
my( $type, $header, $sep_char,
$fixedlength_format, $xml_format, $asn_format,
- $row_callback, @fields );
+ $parser_opt, $row_callback, @fields );
my $postinsert_callback = '';
$postinsert_callback = $param->{'postinsert_callback'}
? $param->{'format_fixedlength_formats'}{ $param->{'format'} }
: '';
+ $parser_opt =
+ $param->{'format_parser_opts'}
+ ? $param->{'format_parser_opts'}{ $param->{'format'} }
+ : {};
+
$xml_format =
$param->{'format_xml_formats'}
? $param->{'format_xml_formats'}{ $param->{'format'} }
if ( $type eq 'csv' ) {
- my %attr = ( 'binary' => 1, );
- $attr{sep_char} = $sep_char if $sep_char;
- $parser = new Text::CSV_XS \%attr;
+ $parser_opt->{'binary'} = 1;
+ $parser_opt->{'sep_char'} = $sep_char if $sep_char;
+ $parser = Text::CSV_XS->new($parser_opt);
} elsif ( $type eq 'fixedlength' ) {
eval "use Parse::FixedLength;";
die $@ if $@;
- $parser = Parse::FixedLength->new($fixedlength_format);
+ $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt);
- }
- else {
+ } else {
die "Unknown file type $type\n";
}
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 );
last unless scalar(@buffer);
my $row = shift @buffer;
+ &{ $asn_format->{row_callback} }( $row, $asn_header_buffer )
+ if $asn_format->{row_callback};
foreach my $key ( keys %{ $asn_format->{map} } ) {
$hash{$key} = &{ $asn_format->{map}{$key} }( $row, $asn_header_buffer );
}
}
+ if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/
+ && length($1) == $custnum_length ) {
+ $hash{custnum} = $2;
+ }
+
#my $table = $param->{table};
my $class = "FS::$table";
return "Empty file!";
}
- $dbh->commit or die $dbh->errstr if $oldAutoCommit;;
+ $dbh->commit or die $dbh->errstr if $oldAutoCommit;
''; #no error
#warn "msgcat ". \&msgcat. "\n";
#warn "notexist ". \¬exist. "\n";
#warn "AUTOLOAD ". \&AUTOLOAD. "\n";
+ # \p{Word} = alphanumerics, marks (diacritics), and connectors
+ # see perldoc perluniprops
$self->getfield($field)
- =~ /^([\wô \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
+ =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/
or return gettext('illegal_or_empty_text'). " $field: ".
$self->getfield($field);
$self->setfield($field,$1);
sub ut_name {
my( $self, $field ) = @_;
# warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
- $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
+ $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/
or return gettext('illegal_name'). " $field: ". $self->getfield($field);
my $name = $1;
$name =~ s/^\s+//;
sub encrypt {
my ($self, $value) = @_;
- my $encrypted;
+ my $encrypted = $value;
if ($conf->exists('encryption')) {
if ($self->is_encrypted($value)) {
my $column_type = $column_obj->type;
my $nullable = $column_obj->null;
+ utf8::upgrade($value);
+
warn " $table.$column: $value ($column_type".
( $nullable ? ' NULL' : ' NOT NULL' ).
")\n" if $DEBUG > 2;
projects / freeside.git / blobdiff