X-Git-Url: http://git.freeside.biz/gitweb/?a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=f4bf2a21c6339bc270e3ff84acc58c782f2d8951;hb=ffa18709ee8a4d05e18d2d406cf73afe79e52524;hp=3b1967e429adf8e7562e4e3ebb1adf6b0512bac3;hpb=d2e5d9d1f65fc94eb87eae45b675645e92087f49;p=freeside.git diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index 3b1967e42..f4bf2a21c 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -1,65 +1,93 @@ package FS::Record; +use base qw( Exporter ); use strict; -use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG - $conf $conf_encryption $me - %virtual_fields_cache - $nowarn_identical $nowarn_classload - $no_update_diff $no_check_foreign +use charnames ':full'; +use vars qw( $AUTOLOAD + %virtual_fields_cache %fk_method_cache $fk_table_cache + %virtual_fields_hash_cache $money_char $lat_lower $lon_upper + $use_placeholders ); -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 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; use Tie::IxHash; -@ISA = qw(Exporter); +our @encrypt_payby = qw( CARD DCRD CHEK DCHK ); #export dbdef for now... everything else expects to find it here -@EXPORT_OK = qw(dbh fields hfields qsearch qsearchs dbdef jsearch - str2time_sql str2time_sql_closing ); +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 fk_methods_init +); -$DEBUG = 0; -$me = '[FS::Record]'; +our $DEBUG = 0; +our $me = '[FS::Record]'; -$nowarn_identical = 0; -$nowarn_classload = 0; -$no_update_diff = 0; -$no_check_foreign = 0; +$use_placeholders = 0; + +our $nowarn_identical = 0; +our $nowarn_classload = 0; +our $no_update_diff = 0; +our $no_history = 0; + +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; -$conf = ''; -$conf_encryption = ''; +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; + $lon_upper = $nw_coords ? -1 : 180; + $File::CounterFile::DEFAULT_DIR = $conf->base_dir . "/counters.". datasrc; + if ( driver_name eq 'Pg' ) { eval "use DBD::Pg ':pg_types'"; die $@ if $@; } else { eval "sub PG_BYTEA { die 'guru meditation #9: calling PG_BYTEA when not running Pg?'; }"; } + + #fk_methods_init(); + } ); =head1 NAME @@ -76,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; @@ -107,6 +135,8 @@ FS::Record - Database record objects $error = $record->ut_floatn('column'); $error = $record->ut_number('column'); $error = $record->ut_numbern('column'); + $error = $record->ut_decimal('column'); + $error = $record->ut_decimaln('column'); $error = $record->ut_snumber('column'); $error = $record->ut_snumbern('column'); $error = $record->ut_money('column'); @@ -144,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 = {}; @@ -162,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}=''; } @@ -173,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; @@ -256,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 @@ -265,7 +301,7 @@ sub _bind_type { my $bind_type = { TYPE => SQL_VARCHAR }; - if ( $type =~ /(big)?(int|serial)/i && $value =~ /^\d+(\.\d+)?$/ ) { + if ( $type =~ /(big)?(int|serial)/i && $value =~ /^-?\d+(\.\d+)?$/ ) { $bind_type = { TYPE => SQL_INTEGER }; @@ -350,7 +386,11 @@ sub qsearch { my @bind_type = (); my $dbh = dbh; foreach my $stable ( @stable ) { - my $record = shift @record; + + carp '->qsearch on cust_main called' if $stable eq 'cust_main' && $DEBUG; + + #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; @@ -371,22 +411,19 @@ sub qsearch { my $pkey = $dbdef_table->primary_key; my @real_fields = grep exists($record->{$_}), real_fields($table); - 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" - unless $nowarn_classload; - @virtual_fields = (); - } my $statement .= "SELECT $select FROM $stable"; - $statement .= " $addl_from" if $addl_from; - if ( @real_fields or @virtual_fields ) { + 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_virtual_fields($table, $pkey, $record, \@virtual_fields), - ); + get_real_fields($table, $record, \@real_fields, $alias_main)); } $statement .= " $extra_sql" if defined($extra_sql); @@ -395,7 +432,6 @@ sub qsearch { push @statement, $statement; warn "[debug]$me $statement\n" if $DEBUG > 1 || $debug; - foreach my $field ( grep defined( $record->{$_} ) && $record->{$_} ne '', @real_fields @@ -450,23 +486,39 @@ sub qsearch { # 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; + } + + + # 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`'. + - # virtual fields and blessings are nonsense in a heterogeneous UNION, right? my $table = $stable[0]; my $pkey = ''; $table = '' if grep { $_ ne $table } @stable; $pkey = dbdef->table($table)->primary_key if $table; - my @virtual_fields = (); - if ( eval 'scalar(@FS::'. $table. '::ISA);' ) { - @virtual_fields = "FS::$table"->virtual_fields; - } else { - cluck "warning: FS::$table not loaded; virtual fields not returned either" - unless $nowarn_classload; - @virtual_fields = (); - } - my %result; tie %result, "Tie::IxHash"; my @stuff = @{ $sth->fetchall_arrayref( {} ) }; @@ -478,30 +530,24 @@ sub qsearch { $sth->finish; - if ( keys(%result) and @virtual_fields ) { - $statement = - "SELECT virtual_field.recnum, part_virtual_field.name, ". - "virtual_field.value ". - "FROM part_virtual_field JOIN virtual_field USING (vfieldpart) ". - "WHERE part_virtual_field.dbtable = '$table' AND ". - "virtual_field.recnum IN (". - join(',', keys(%result)). ") AND part_virtual_field.name IN ('". - join(q!', '!, @virtual_fields) . "')"; - warn "[debug]$me $statement\n" if $DEBUG > 1; - $sth = $dbh->prepare($statement) or croak "$dbh->errstr doing $statement"; - $sth->execute or croak "Error executing \"$statement\": ". $sth->errstr; - - foreach (@{ $sth->fetchall_arrayref({}) }) { - my $recnum = $_->{recnum}; - my $name = $_->{name}; - my $value = $_->{value}; - if (exists($result{$recnum})) { - $result{$recnum}->{$name} = $value; - } + #below was refactored out to _from_hashref, this should use it at some point + + my @return; + 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); } + } - my @return; - if ( eval 'scalar(@FS::'. $table. '::ISA);' ) { + 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 ) { @@ -523,10 +569,16 @@ 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)' ) { + 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') + || $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))); } @@ -542,114 +594,285 @@ sub qsearch { return @return; } -## makes this easier to read +=item _query -sub get_virtual_fields { - my $table = shift; - my $pkey = shift; - my $record = shift; - my $virtual_fields = shift; - - return - ( map { - my $op = '='; - my $column = $_; - if ( ref($record->{$_}) ) { - $op = $record->{$_}{'op'} if $record->{$_}{'op'}; - if ( uc($op) eq 'ILIKE' ) { - $op = 'LIKE'; - $record->{$_}{'value'} = lc($record->{$_}{'value'}); - $column = "LOWER($_)"; - } - $record->{$_} = $record->{$_}{'value'}; - } +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 + ) { - # ... EXISTS ( SELECT name, value FROM part_virtual_field - # JOIN virtual_field - # ON part_virtual_field.vfieldpart = virtual_field.vfieldpart - # WHERE recnum = svc_acct.svcnum - # AND (name, value) = ('egad', 'brain') ) + 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; - my $value = $record->{$_}; + } + + 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}; - my $subq; + return { + statement => $statement, + bind_type => \@bind_type, + value => \@value, + table => $result_table, + cache => $cache, + }; +} - $subq = ($value ? 'EXISTS ' : 'NOT EXISTS ') . - "( SELECT part_virtual_field.name, virtual_field.value ". - "FROM part_virtual_field JOIN virtual_field ". - "ON part_virtual_field.vfieldpart = virtual_field.vfieldpart ". - "WHERE virtual_field.recnum = ${table}.${pkey} ". - "AND part_virtual_field.name = '${column}'". - ($value ? - " AND virtual_field.value ${op} '${value}'" - : "") . ")"; - $subq; +# 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; + } - } @{ $virtual_fields } ) ; + # 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; } sub get_real_fields { my $table = shift; my $record = shift; my $real_fields = shift; + my $alias_main = shift; # defaults to undef + $alias_main ||= $table; - ## this huge map was previously inline, just broke it out to help read the qsearch method, should be optimized for readability - return ( - map { + ## could be optimized more for readability + return ( + map { my $op = '='; my $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); - if ( ref($record->{$_}) ) { - $op = $record->{$_}{'op'} if $record->{$_}{'op'}; + + if ( ref($record->{$column}) ) { + $op = $record->{$column}{'op'} if $record->{$column}{'op'}; #$op = 'LIKE' if $op =~ /^ILIKE$/i && driver_name ne 'Pg'; if ( uc($op) eq 'ILIKE' ) { $op = 'LIKE'; - $record->{$_}{'value'} = lc($record->{$_}{'value'}); - $column = "LOWER($_)"; + $record->{$column}{'value'} = lc($record->{$column}{'value'}); + $table_column = "LOWER($table_column)"; } - $record->{$_} = $record->{$_}{'value'} + $record->{$column} = $record->{$column}{'value'} } - if ( ! defined( $record->{$_} ) || $record->{$_} eq '' ) { + if ( ! defined( $record->{$column} ) || $record->{$column} eq '' ) { if ( $op eq '=' ) { if ( driver_name eq 'Pg' ) { if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) { - qq-( $column IS NULL )-; + qq-( $table_column IS NULL )-; } else { - qq-( $column IS NULL OR $column = '' )-; + qq-( $table_column IS NULL OR $table_column = '' )-; } } else { - qq-( $column IS NULL OR $column = "" )-; + qq-( $table_column IS NULL OR $table_column = "" )-; } } elsif ( $op eq '!=' ) { if ( driver_name eq 'Pg' ) { if ( $type =~ /(int|numeric|real|float4|(big)?serial)/i ) { - qq-( $column IS NOT NULL )-; + qq-( $table_column IS NOT NULL )-; } else { - qq-( $column IS NOT NULL AND $column != '' )-; + qq-( $table_column IS NOT NULL AND $table_column != '' )-; } } else { - qq-( $column IS NOT NULL AND $column != "" )-; + qq-( $table_column IS NOT NULL AND $table_column != "" )-; } } else { if ( driver_name eq 'Pg' ) { - qq-( $column $op '' )-; + qq-( $table_column $op '' )-; } else { - qq-( $column $op "" )-; + qq-( $table_column $op "" )-; } } + } elsif ( $op eq '!=' ) { + qq-( $table_column IS NULL OR $table_column != ? )-; #if this needs to be re-enabled, it needs to use a custom op like #"APPROX=" or something (better name?, not '=', to avoid affecting other # searches #} elsif ( $op eq 'APPROX=' && _is_fs_float( $type, $value ) ) { - # ( "$column <= ?", "$column >= ?" ); + # ( "$table_column <= ?", "$table_column >= ?" ); } else { - "$column $op ?"; + "$table_column $op ?"; } - } @{ $real_fields } ); + + } @{ $real_fields } + ); } =item by_key PRIMARY_KEY_VALUE @@ -687,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 @@ -713,6 +936,7 @@ sub qsearchs { # $result_record = &FS::Record:qsearchs('table',\%hash); my $table = $_[0]; my(@result) = qsearch(@_); cluck "warning: Multiple records in scalar search ($table)" + #.join(' / ', map "$_=>".$_[1]->{$_}, keys %{ $_[1] } ) if scalar(@result) > 1; #should warn more vehemently if the search was on a primary key? scalar(@result) ? ($result[0]) : (); @@ -770,7 +994,7 @@ sub get { # to avoid "Use of unitialized value" errors if ( defined ( $self->{Hash}->{$field} ) ) { $self->{Hash}->{$field}; - } else { + } else { ''; } } @@ -785,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; @@ -795,12 +1019,28 @@ sub setfield { $self->set(@_); } -=item AUTLOADED METHODS +=item exists COLUMN + +Returns true if the column/field/key COLUMN exists. + +=cut + +sub exists { + my($self,$field) = @_; + exists($self->{Hash}->{$field}); +} + +=item AUTOLOADED METHODS $record->column is a synonym for $record->get('column'); $record->column('value') is a synonym for $record->set('column','value'); +$record->foreign_table_name calls qsearchs and returns a single +FS::foreign_table record (for tables referenced by a column of this table) or +qsearch and returns an array of FS::foreign_table records (for tables +referenced by a column in the foreign table). + =cut # readable/safe @@ -808,18 +1048,44 @@ sub AUTOLOAD { my($self,$value)=@_; my($field)=$AUTOLOAD; $field =~ s/.*://; + + confess "errant AUTOLOAD $field for $self (arg $value)" + unless blessed($self) && $self->can('setfield'); + + if ( my $fk_info = get_fk_method($self->table, $field) ) { + + my $method = $fk_info->{method} || 'qsearchs'; + my $table = $fk_info->{table} || $field; + my $column = $fk_info->{column}; + my $foreign_column = $fk_info->{references} || $column; + + eval "use FS::$table"; + die $@ if $@; + + carp '->cust_main called' if $table eq 'cust_main' && $DEBUG; + + my $pkey_value = $self->$column(); + my %search = ( $foreign_column => $pkey_value ); + + # FS::Record->$method() ? they're actually just subs :/ + if ( $method eq 'qsearchs' ) { + return $pkey_value ? qsearchs( $table, \%search ) : ''; + } elsif ( $method eq 'qsearch' ) { + return $pkey_value ? qsearch( $table, \%search ) : (); + } else { + die "unknown method $method"; + } + + } + if ( defined($value) ) { - confess "errant AUTOLOAD $field for $self (arg $value)" - unless blessed($self) && $self->can('setfield'); $self->setfield($field,$value); } else { - confess "errant AUTOLOAD $field for $self (no args)" - unless blessed($self) && $self->can('getfield'); $self->getfield($field); - } + } } -# efficient +# efficient (also, old, doesn't support FK stuff) #sub AUTOLOAD { # my $field = $AUTOLOAD; # $field =~ s/.*://; @@ -827,48 +1093,173 @@ sub AUTOLOAD { # $_[0]->setfield($field, $_[1]); # } else { # $_[0]->getfield($field); -# } +# } #} -=item hash +# 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. -Returns a list of the column/value pairs, usually for assigning to a new hash. +# 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 -To make a distinct duplicate of an FS::Record object, you can do: +sub get_fk_method { + my ($table, $field) = @_; - $new = new FS::Record ( $old->table, { $old->hash } ); + # maybe should only load one table at a time? + fk_methods_init() unless exists($fk_method_cache{$table}); -=cut + if ( exists($fk_method_cache{$table}) and + exists($fk_method_cache{$table}{$field}) ) { + return $fk_method_cache{$table}{$field}; + } else { + return undef; + } -sub hash { - my($self) = @_; - confess $self. ' -> hash: Hash attribute is undefined' - unless defined($self->{'Hash'}); - %{ $self->{'Hash'} }; } -=item hashref +sub fk_methods_init { + warn "[fk_methods_init]\n" if $DEBUG; + foreach my $table ( dbdef->tables ) { + $fk_method_cache{$table} = fk_methods($table); + } +} -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. +sub fk_methods { + my $table = shift; -=cut + my %hash = (); -sub hashref { - my($self) = @_; - $self->{'Hash'}; -} + # foreign keys we reference in other tables + foreach my $fk (dbdef->table($table)->foreign_keys) { -=item modified + my $method = ''; + if ( scalar( @{$fk->columns} ) == 1 ) { + if ( ! defined($fk->references) + || ! @{$fk->references} + || $fk->columns->[0] eq $fk->references->[0] + ) { + $method = $fk->table; + } else { + #some sort of hint in the table.pm or schema for methods not named + # after their foreign table (well, not a whole lot different than + # just providing a small subroutine...) + } -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. + if ( $method ) { + $hash{$method} = { #fk_info + 'method' => 'qsearchs', + 'column' => $fk->columns->[0], + #'references' => $fk->references->[0], + }; + } -=cut + } -sub modified { + } + + # foreign keys referenced in other tables to us + # (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?) + 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) + || ! @{$fk->references} + || $fk->columns->[0] eq $fk->references->[0] + ) { + $method = $f_table; + } else { + #some sort of hint in the table.pm or schema for methods not named + # after their foreign table (well, not a whole lot different than + # just providing a small subroutine...) + } + + if ( $method ) { + $hash{$method} = { #fk_info + 'method' => 'qsearch', + 'column' => $fk->columns->[0], #references||column + #'references' => $fk->column->[0], + }; + } + + } + } + + \%hash; +} + +=item hash + +Returns a list of the column/value pairs, usually for assigning to a new hash. + +To make a distinct duplicate of an FS::Record object, you can do: + + $new = new FS::Record ( $old->table, { $old->hash } ); + +=cut + +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. 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 + +sub hashref { + my($self) = @_; + $self->{'Hash'}; +} + +#fallbacks/generics + +sub API_getinfo { + my $self = shift; + +{ ( map { $_=>$self->$_ } $self->fields ), + }; +} + +sub API_insert { + my( $class, %opt ) = @_; + my $table = $class->table; + my $self = $class->new( { map { $_ => $opt{$_} } fields($table) } ); + my $error = $self->insert; + return +{ 'error' => $error } if $error; + my $pkey = $self->pkey; + return +{ 'error' => '', + 'primary_key' => $pkey, + $pkey => $self->$pkey, + }; +} + +=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'}; } @@ -951,10 +1342,12 @@ sub insert { my $error = $self->check; return $error if $error; - #single-field unique keys are given a value if false + #single-field non-null unique keys are given a value if empty #(like MySQL's AUTO_INCREMENT or Pg SERIAL) foreach ( $self->dbdef_table->unique_singles) { - $self->unique($_) unless $self->getfield($_); + next if $self->getfield($_); + next if $self->dbdef_table->column($_)->null eq 'NULL'; + $self->unique($_); } #and also the primary key, if the database isn't going to @@ -977,14 +1370,18 @@ 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') { - $self->{'saved'} = $self->getfield($field); + next if $field eq 'payinfo' + && ($self->isa('FS::payinfo_transaction_Mixin') + || $self->isa('FS::payinfo_Mixin') ) + && $self->payby + && !grep { $self->payby eq $_ } @encrypt_payby; + $saved->{$field} = $self->getfield($field); $self->setfield($field, $self->encrypt($self->getfield($field))); } } @@ -994,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' ) { @@ -1073,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?)"; } @@ -1082,36 +1502,8 @@ sub insert { } - my @virtual_fields = - grep defined($self->getfield($_)) && $self->getfield($_) ne "", - $self->virtual_fields; - if (@virtual_fields) { - my %v_values = map { $_, $self->getfield($_) } @virtual_fields; - - my $vfieldpart = $self->vfieldpart_hashref; - - my $v_statement = "INSERT INTO virtual_field(recnum, vfieldpart, value) ". - "VALUES (?, ?, ?)"; - - my $v_sth = dbh->prepare($v_statement) or do { - dbh->rollback if $FS::UID::AutoCommit; - return dbh->errstr; - }; - - foreach (keys(%v_values)) { - $v_sth->execute($self->getfield($primary_key), - $vfieldpart->{$_}, - $v_values{$_}) - or do { - dbh->rollback if $FS::UID::AutoCommit; - return $v_sth->errstr; - }; - } - } - - 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 { @@ -1125,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}); @@ -1181,21 +1573,10 @@ sub delete { } my $primary_key = $self->dbdef_table->primary_key; - my $v_sth; - my @del_vfields; - my $vfp = $self->vfieldpart_hashref; - foreach($self->virtual_fields) { - next if $self->getfield($_) eq ''; - unless(@del_vfields) { - my $st = "DELETE FROM virtual_field WHERE recnum = ? AND vfieldpart = ?"; - $v_sth = dbh->prepare($st) or return dbh->errstr; - } - push @del_vfields, $_; - } 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'; @@ -1203,10 +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; - $v_sth->execute($self->getfield($primary_key), $vfp->{$_}) - or return $v_sth->errstr - foreach (@del_vfields); - + dbh->commit or croak dbh->errstr if $FS::UID::AutoCommit; #no need to needlessly destoy the data either (causes problems actually) @@ -1256,14 +1634,18 @@ 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') + || $new->isa('FS::payinfo_Mixin') ) + && $new->payby + && !grep { $new->payby eq $_ } @encrypt_payby; $saved->{$field} = $new->getfield($field); $new->setfield($field, $new->encrypt($new->getfield($field))); } @@ -1272,16 +1654,18 @@ 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 $new -> replace $old: records identical" + carp "[warning]$me ". ref($new)."->replace ". + ( $primary_key ? "$primary_key ".$new->get($primary_key) : '' ). + ": records identical" unless $nowarn_identical; return ''; } 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 ', @@ -1329,47 +1713,9 @@ sub replace { $h_new_sth = ''; } - # For virtual fields we have three cases with different SQL - # statements: add, replace, delete - my $v_add_sth; - my $v_rep_sth; - my $v_del_sth; - my (@add_vfields, @rep_vfields, @del_vfields); - my $vfp = $old->vfieldpart_hashref; - foreach(grep { exists($diff{$_}) } $new->virtual_fields) { - if($diff{$_} eq '') { - # Delete - unless(@del_vfields) { - my $st = "DELETE FROM virtual_field WHERE recnum = ? ". - "AND vfieldpart = ?"; - warn "[debug]$me $st\n" if $DEBUG > 2; - $v_del_sth = dbh->prepare($st) or return dbh->errstr; - } - push @del_vfields, $_; - } elsif($old->getfield($_) eq '') { - # Add - unless(@add_vfields) { - my $st = "INSERT INTO virtual_field (value, recnum, vfieldpart) ". - "VALUES (?, ?, ?)"; - warn "[debug]$me $st\n" if $DEBUG > 2; - $v_add_sth = dbh->prepare($st) or return dbh->errstr; - } - push @add_vfields, $_; - } else { - # Replace - unless(@rep_vfields) { - my $st = "UPDATE virtual_field SET value = ? ". - "WHERE recnum = ? AND vfieldpart = ?"; - warn "[debug]$me $st\n" if $DEBUG > 2; - $v_rep_sth = dbh->prepare($st) or return dbh->errstr; - } - push @rep_vfields, $_; - } - } - 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'; @@ -1379,26 +1725,9 @@ sub replace { $h_old_sth->execute or return $h_old_sth->errstr if $h_old_sth; $h_new_sth->execute or return $h_new_sth->errstr if $h_new_sth; - $v_del_sth->execute($old->getfield($primary_key), - $vfp->{$_}) - or return $v_del_sth->errstr - foreach(@del_vfields); - - $v_add_sth->execute($new->getfield($_), - $old->getfield($primary_key), - $vfp->{$_}) - or return $v_add_sth->errstr - foreach(@add_vfields); - - $v_rep_sth->execute($new->getfield($_), - $old->getfield($primary_key), - $vfp->{$_}) - or return $v_rep_sth->errstr - foreach(@rep_vfields); - 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}); @@ -1437,35 +1766,84 @@ sub rep { =item check -Checks virtual fields (using check_blocks). Subclasses should still provide -a check method to validate real fields, foreign keys, etc., and call this -method via $self->SUPER::check. - -(FIXME: Should this method try to make sure that it I being called from -a subclass's check method, to keep the current semantics as far as possible?) +Checks custom fields. Subclasses should still provide a check method to validate +non-custom fields, etc., and call this method via $self->SUPER::check. =cut sub check { - #confess "FS::Record::check not implemented; supply one in subclass!"; + my $self = shift; + foreach my $field ($self->virtual_fields) { + my $error = $self->ut_textn($field); + return $error if $error; + } + ''; +} + +=item virtual_fields [ TABLE ] + +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 + +sub virtual_fields { my $self = shift; + my $table; + $table = $self->table or confess "virtual_fields called on non-table"; - foreach my $field ($self->virtual_fields) { - for ($self->getfield($field)) { - # See notes on check_block in FS::part_virtual_field. - eval $self->pvf($field)->check_block; - 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): $@"; + confess "Unknown table $table" unless dbdef->table($table); - } - $self->setfield($field, $_); + return () unless dbdef->table('part_virtual_field'); + + unless ( $virtual_fields_cache{$table} ) { + my $concat = [ "'cf_'", "name" ]; + my $query = "SELECT ".concat_sql($concat).' from part_virtual_field ' . + "WHERE dbtable = '$table'"; + my $dbh = dbh; + my $result = $dbh->selectcol_arrayref($query); + confess "Error executing virtual fields query: $query: ". $dbh->errstr + if $dbh->err; + $virtual_fields_cache{$table} = $result; + } + + @{$virtual_fields_cache{$table}}; + +} + +=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 @@ -1484,7 +1862,7 @@ Table name (required). =item params -Listref of field names for static fields. They will be given values from the +Arrayref of field names for static fields. They will be given values from the PARAMS hashref and passed as a "params" hashref to batch_import. =item formats @@ -1533,26 +1911,23 @@ format_types). =back -PARAMS is a base64-encoded Storable string containing the POSTed data as -a hash ref. It normally contains at least one field, "uploaded files", -generated by /elements/file-upload.html and containing the list of uploaded -files. Currently only supports a single file named "file". +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". =cut -use Storable qw(thaw); use Data::Dumper; -use MIME::Base64; sub process_batch_import { - my($job, $opt) = ( shift, shift ); + my($job, $opt, $param) = @_; my $table = $opt->{table}; my @pass_params = $opt->{params} ? @{ $opt->{params} } : (); my %formats = %{ $opt->{formats} }; - my $param = thaw(decode_base64(shift)); warn Dumper($param) if $DEBUG; - + my $files = $param->{'uploaded_files'} or die "No files provided.\n"; @@ -1569,6 +1944,10 @@ sub process_batch_import { format_headers => $opt->{format_headers}, format_sep_chars => $opt->{format_sep_chars}, format_fixedlength_formats => $opt->{format_fixedlength_formats}, + 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, @@ -1577,6 +1956,9 @@ 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}, ); if ( $opt->{'batch_namecol'} ) { @@ -1599,6 +1981,8 @@ Class method for batch imports. Available params: =item table +=item format - usual way to specify import, with this format string selecting data from the formats and format_* info hashes + =item formats =item format_types @@ -1609,6 +1993,16 @@ Class method for batch imports. Available params: =item format_fixedlength_formats +=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 + +=item postinsert_callback + =item params =item job @@ -1619,9 +2013,7 @@ FS::queue object, will be updated with progress =item type -csv, xls or fixedlength - -=item format +csv, xls, fixedlength, xml =item empty_ok @@ -1629,6 +2021,7 @@ csv, xls or fixedlength =cut +use Data::Dumper; sub batch_import { my $param = shift; @@ -1636,18 +2029,94 @@ sub batch_import { if $DEBUG; my $table = $param->{table}; - my $formats = $param->{formats}; my $job = $param->{job}; my $file = $param->{file}; - my $format = $param->{'format'}; my $params = $param->{params} || {}; - die "unknown format $format" unless exists $formats->{ $format }; + 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, + $parser_opt, $row_callback, $hash_callback, @fields ); + + my $postinsert_callback = ''; + $postinsert_callback = $param->{'postinsert_callback'} + if $param->{'postinsert_callback'}; + my $preinsert_callback = ''; + $preinsert_callback = $param->{'preinsert_callback'} + if $param->{'preinsert_callback'}; + my $insert_args_callback = ''; + $insert_args_callback = $param->{'insert_args_callback'} + if $param->{'insert_args_callback'}; + + if ( $param->{'format'} ) { + + my $format = $param->{'format'}; + my $formats = $param->{formats}; + die "unknown format $format" unless exists $formats->{ $format }; + + $type = $param->{'format_types'} + ? $param->{'format_types'}{ $format } + : $param->{type} || 'csv'; + + + $header = $param->{'format_headers'} + ? $param->{'format_headers'}{ $param->{'format'} } + : 0; + + $sep_char = $param->{'format_sep_chars'} + ? $param->{'format_sep_chars'}{ $param->{'format'} } + : ','; - my $type = $param->{'format_types'} - ? $param->{'format_types'}{ $format } - : $param->{type} || 'csv'; + $fixedlength_format = + $param->{'format_fixedlength_formats'} + ? $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'} } + : ''; + + $asn_format = + $param->{'format_asn_formats'} + ? $param->{'format_asn_formats'}{ $param->{'format'} } + : ''; + + $row_callback = + $param->{'format_row_callbacks'} + ? $param->{'format_row_callbacks'}{ $param->{'format'} } + : ''; + + $hash_callback = + $param->{'format_hash_callbacks'} + ? $param->{'format_hash_callbacks'}{ $param->{'format'} } + : ''; + + @fields = @{ $formats->{ $format } }; + + } elsif ( $param->{'fields'} ) { + + $type = ''; #infer from filename + $header = 0; + $sep_char = ','; + $fixedlength_format = ''; + $row_callback = ''; + $hash_callback = ''; + @fields = @{ $param->{'fields'} }; + + } else { + die "neither format nor fields specified"; + } + + #my $file = $param->{file}; unless ( $type ) { if ( $file =~ /\.(\w+)$/i ) { @@ -1661,39 +2130,26 @@ sub batch_import { if $param->{'default_csv'} && $type ne 'xls'; } - my $header = $param->{'format_headers'} - ? $param->{'format_headers'}{ $param->{'format'} } - : 0; - - my $sep_char = $param->{'format_sep_chars'} - ? $param->{'format_sep_chars'}{ $param->{'format'} } - : ','; - - my $fixedlength_format = - $param->{'format_fixedlength_formats'} - ? $param->{'format_fixedlength_formats'}{ $param->{'format'} } - : ''; - - my @fields = @{ $formats->{ $format } }; my $row = 0; my $count; my $parser; my @buffer = (); + my $asn_header_buffer; if ( $type eq 'csv' || $type eq 'fixedlength' ) { if ( $type eq 'csv' ) { - my %attr = (); - $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 = new Parse::FixedLength $fixedlength_format; - + $parser = Parse::FixedLength->new($fixedlength_format, $parser_opt); + } else { die "Unknown file type $type\n"; } @@ -1721,6 +2177,43 @@ sub batch_import { $row = $header || 0; + } elsif ( $type eq 'xml' ) { + + # FS::pay_batch + eval "use XML::Simple;"; + die $@ if $@; + my $xmlrow = $xml_format->{'xmlrow'}; + $parser = $xml_format->{'xmlkeys'}; + die 'no xmlkeys specified' unless ref $parser eq 'ARRAY'; + my $data = XML::Simple::XMLin( + $file, + 'SuppressEmpty' => '', #sets empty values to '' + 'KeepRoot' => 1, + ); + my $rows = $data; + $rows = $rows->{$_} foreach @$xmlrow; + $rows = [ $rows ] if ref($rows) ne 'ARRAY'; + $count = @buffer = @$rows; + + } elsif ( $type eq 'asn.1' ) { + + eval "use Convert::ASN1"; + die $@ if $@; + + my $asn = Convert::ASN1->new; + $asn->prepare( $asn_format->{'spec'} ) or die $asn->error; + + $parser = $asn->find( $asn_format->{'macro'} ) or die $asn->error; + + my $data = slurp($file); + my $asn_output = $parser->decode( $data ) + or return "No ". $asn_format->{'macro'}. " found\n"; + + $asn_header_buffer = &{ $asn_format->{'header_buffer'} }( $asn_output ); + + my $rows = &{ $asn_format->{'arrayref'} }( $asn_output ); + $count = @buffer = @$rows; + } else { die "Unknown file type $type\n"; } @@ -1738,6 +2231,7 @@ sub batch_import { local $FS::UID::AutoCommit = 0; my $dbh = dbh; + #my $params = $param->{params} || {}; if ( $param->{'batch_namecol'} && $param->{'batch_namevalue'} ) { my $batch_col = $param->{'batch_keycol'}; @@ -1755,13 +2249,16 @@ sub batch_import { $params->{ $batch_col } = $batch_value; } - + + #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) { my @columns = (); + my %hash = %$params; if ( $type eq 'csv' ) { last unless scalar(@buffer); @@ -1769,14 +2266,21 @@ 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 { $dbh->rollback if $oldAutoCommit; - return "can't parse: ". $parser->error_input(); + return "can't parse: ". $parser->error_input() . " " . $parser->error_diag; }; @columns = $parser->fields(); } elsif ( $type eq 'fixedlength' ) { + last unless scalar(@buffer); + $line = shift(@buffer); + @columns = $parser->parse($line); } elsif ( $type eq 'xls' ) { @@ -1790,17 +2294,33 @@ sub batch_import { #my $z = 'A'; #warn $z++. ": $_\n" for @columns; + } elsif ( $type eq 'xml' ) { + + # $parser = [ 'Column0Key', 'Column1Key' ... ] + last unless scalar(@buffer); + my $row = shift @buffer; + @columns = @{ $row }{ @$parser }; + + } elsif ( $type eq 'asn.1' ) { + + 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 ); + } + } else { die "Unknown file type $type\n"; } my @later = (); - my %hash = %$params; foreach my $field ( @fields ) { my $value = shift @columns; - + if ( ref($field) eq 'CODE' ) { #&{$field}(\%hash, $value); push @later, $field, $value; @@ -1811,6 +2331,14 @@ sub batch_import { } + if ( $custnum_prefix && $hash{custnum} =~ /^$custnum_prefix(0*([1-9]\d*))$/ + && length($1) == $custnum_length ) { + $hash{custnum} = $2; + } + + %hash = &{$hash_callback}(%hash) if $hash_callback; + + #my $table = $param->{table}; my $class = "FS::$table"; my $record = $class->new( \%hash ); @@ -1819,12 +2347,34 @@ sub batch_import { while ( scalar(@later) ) { my $sub = shift @later; my $data = shift @later; - &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf); + eval { + &{$sub}($record, $data, $conf, $param); # $record->&{$sub}($data, $conf) + }; + if ( $@ ) { + $dbh->rollback if $oldAutoCommit; + return "can't insert record". ( $line ? " for $line" : '' ). ": $@"; + } last if exists( $param->{skiprow} ); } + $unique_skip++ if $param->{unique_skip}; #line is already in the system next if exists( $param->{skiprow} ); - my $error = $record->insert; + if ( $preinsert_callback ) { + my $error = &{$preinsert_callback}($record, $param); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "preinsert_callback error". ( $line ? " for $line" : '' ). + ": $error"; + } + next if exists $param->{skiprow} && $param->{skiprow}; + } + + my @insert_args = (); + if ( $insert_args_callback ) { + @insert_args = &{$insert_args_callback}($record, $param); + } + + my $error = $record->insert(@insert_args); if ( $error ) { $dbh->rollback if $oldAutoCommit; @@ -1834,6 +2384,15 @@ sub batch_import { $row++; $imported++; + if ( $postinsert_callback ) { + my $error = &{$postinsert_callback}($record, $param); + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "postinsert_callback error". ( $line ? " for $line" : '' ). + ": $error"; + } + } + if ( $job && time - $min_sec > $last ) { #progress bar $job->update_statustext( int(100 * $imported / $count) ); $last = time; @@ -1841,9 +2400,13 @@ sub batch_import { } - $dbh->commit or die $dbh->errstr if $oldAutoCommit;; + unless ( $imported || $param->{empty_ok} ) { + $dbh->rollback if $oldAutoCommit; + # freeside-cdr-conexiant-import is sensitive to the text of this message + return $unique_skip ? "All records in file were previously imported" : "Empty file!"; + } - return "Empty file!" unless $imported || $param->{empty_ok}; + $dbh->commit or die $dbh->errstr if $oldAutoCommit; ''; #no error @@ -1862,23 +2425,27 @@ sub _h_statement { ; # If we're encrypting then don't store the payinfo in the history - if ( $conf && $conf->exists('encryption') ) { + if ( $conf_encryption && $self->table ne 'banned_pay' ) { @fields = grep { $_ ne 'payinfo' } @fields; } 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 + ). ")" ; } =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 @@ -1902,11 +2469,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 } ); @@ -2052,6 +2614,35 @@ sub ut_numbern { ''; } +=item ut_decimal COLUMN[, DIGITS] + +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] + +Check/untaint decimal numbers. May be null. If there is an error, returns +the error, otherwise returns false. + +=cut + +sub ut_decimal { + my($self, $field, $digits) = @_; + $digits ||= ''; + $self->getfield($field) =~ /^\s*(\d+(\.\d{0,$digits})?)\s*$/ + or return "Illegal or empty (decimal) $field: ".$self->getfield($field); + $self->setfield($field, $1); + ''; +} + +sub ut_decimaln { + my($self, $field, $digits) = @_; + $self->getfield($field) =~ /^\s*(\d*(\.\d{0,$digits})?)\s*$/ + or return "Illegal (decimal) $field: ".$self->getfield($field); + $self->setfield($field, $1); + ''; +} + =item ut_money COLUMN Check/untaint monetary numbers. May be negative. Set to 0 if null. If there @@ -2061,11 +2652,18 @@ is an error, returns the error, otherwise returns false. sub ut_money { my($self,$field)=@_; - $self->setfield($field, 0) if $self->getfield($field) eq ''; - $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ - or return "Illegal (money) $field: ". $self->getfield($field); - #$self->setfield($field, "$1$2$3" || 0); - $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0); + + if ( $self->getfield($field) eq '' ) { + $self->setfield($field, 0); + } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{1})\s*$/ ) { + #handle one decimal place without barfing out + $self->setfield($field, ( ($1||''). ($2||''). ($3.'0') ) || 0); + } elsif ( $self->getfield($field) =~ /^\s*(\-)?\s*(\d*)(\.\d{2})?\s*$/ ) { + $self->setfield($field, ( ($1||''). ($2||''). ($3||'') ) || 0); + } else { + return "Illegal (money) $field: ". $self->getfield($field); + } + ''; } @@ -2085,10 +2683,45 @@ sub ut_moneyn { $self->ut_money($field); } -=item ut_text COLUMN +=item ut_currencyn COLUMN -Check/untaint text. Alphanumerics, spaces, and the following punctuation -symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < > +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 +symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < > ~ May not be null. If there is an error, returns the error, otherwise returns false. @@ -2099,8 +2732,10 @@ sub ut_text { #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 \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>]+)$/ + =~ /^([\p{Word} \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>\~$money_char]+)$/ or return gettext('illegal_or_empty_text'). " $field: ". $self->getfield($field); $self->setfield($field,$1); @@ -2110,18 +2745,15 @@ sub ut_text { =item ut_textn COLUMN Check/untaint text. Alphanumerics, spaces, and the following punctuation -symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / +symbols are currently permitted: ! @ # $ % & ( ) - + ; : ' " , . ? / = [ ] < > May be null. If there is an error, returns the error, otherwise returns false. =cut sub ut_textn { my($self,$field)=@_; - $self->getfield($field) - =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]]*)$/ - or return gettext('illegal_text'). " $field: ". $self->getfield($field); - $self->setfield($field,$1); - ''; + return $self->setfield($field, '') if $self->getfield($field) =~ /^$/; + $self->ut_text($field); } =item ut_alpha COLUMN @@ -2149,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); ''; @@ -2164,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); ''; @@ -2190,8 +2822,8 @@ sub ut_alpha_lower { Check/untaint phone numbers. May be null. If there is an error, returns the error, otherwise returns false. -Takes an optional two-letter ISO country code; without it or with unsupported -countries, ut_phonen simply calls ut_alphan. +Takes an optional two-letter ISO 3166-1 alpha-2 country code; without +it or with unsupported countries, ut_phonen simply calls ut_alphan. =cut @@ -2244,6 +2876,42 @@ sub ut_hexn { $self->setfield($field, uc($1)); ''; } + +=item ut_mac_addr COLUMN + +Check/untaint mac addresses. May be null. + +=cut + +sub ut_mac_addr { + my($self, $field) = @_; + + my $mac = $self->get($field); + $mac =~ s/\s+//g; + $mac =~ s/://g; + $self->set($field, $mac); + + my $e = $self->ut_hex($field); + return $e if $e; + + return "Illegal (mac address) $field: ". $self->getfield($field) + unless length($self->getfield($field)) == 12; + + ''; + +} + +=item ut_mac_addrn COLUMN + +Check/untaint mac addresses. May be null. + +=cut + +sub ut_mac_addrn { + my($self, $field) = @_; + ($self->getfield($field) eq '') ? '' : $self->ut_mac_addr($field); +} + =item ut_ip COLUMN Check/untaint ip addresses. IPv4 only for now, though ::1 is auto-translated @@ -2254,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 @@ -2278,6 +2944,51 @@ sub ut_ipn { } } +=item ut_ip46 COLUMN + +Check/untaint IPv4 or IPv6 address. + +=cut + +sub ut_ip46 { + my( $self, $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 ''; +} + +=item ut_ip46n + +Check/untaint IPv6 or IPv6 address. May be null. + +=cut + +sub ut_ip46n { + my( $self, $field ) = @_; + if ( $self->getfield($field) =~ /^$/ ) { + $self->setfield($field, ''); + return ''; + } + $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. @@ -2303,14 +3014,24 @@ for lower and upper bounds, respectively. =cut sub ut_coord { - my ($self, $field) = (shift, shift); - my $lower = shift if scalar(@_); - my $upper = shift if scalar(@_); + my($lower, $upper); + if ( $field =~ /latitude/ ) { + $lower = $lat_lower; + $upper = 90; + } elsif ( $field =~ /longitude/ ) { + $lower = -180; + $upper = $lon_upper; + } + 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 ( @@ -2355,7 +3076,7 @@ sub ut_coordn { my ($self, $field) = (shift, shift); - if ($self->getfield($field) =~ /^$/) { + if ($self->getfield($field) =~ /^\s*$/) { return ''; } else { return $self->ut_coord($field, @_); @@ -2363,10 +3084,9 @@ sub ut_coordn { } - =item ut_domain COLUMN -Check/untaint host and domain names. +Check/untaint host and domain names. May not be null. =cut @@ -2374,11 +3094,27 @@ sub ut_domain { my( $self, $field ) = @_; #$self->getfield($field) =~/^(\w+\.)*\w+$/ $self->getfield($field) =~/^(([\w\-]+\.)*\w+)$/ - or return "Illegal (domain) $field: ". $self->getfield($field); + or return "Illegal (hostname) $field: ". $self->getfield($field); $self->setfield($field,$1); ''; } +=item ut_domainn COLUMN + +Check/untaint host and domain names. May be null. + +=cut + +sub ut_domainn { + my( $self, $field ) = @_; + if ( $self->getfield($field) =~ /^()$/ ) { + $self->setfield($field,''); + ''; + } else { + $self->ut_domain($field); + } +} + =item ut_name COLUMN Check/untaint proper names; allows alphanumerics, spaces and the following @@ -2390,12 +3126,31 @@ May not be null. sub ut_name { my( $self, $field ) = @_; - $self->getfield($field) =~ /^([\w \,\.\-\']+)$/ + $self->getfield($field) =~ /^([\p{Word} \,\.\-\']+)$/ or return gettext('illegal_name'). " $field: ". $self->getfield($field); - $self->setfield($field,$1); + my $name = $1; + $name =~ s/^\s+//; + $name =~ s/\s+$//; + $name =~ s/\s+/ /g; + $self->setfield($field, $name); ''; } +=item ut_namen COLUMN + +Check/untaint proper names; allows alphanumerics, spaces and the following +punctuation: , . - ' + +May not be null. + +=cut + +sub ut_namen { + my( $self, $field ) = @_; + return $self->setfield($field, '') if $self->getfield($field) =~ /^$/; + $self->ut_name($field); +} + =item ut_zip COLUMN Check/untaint zip codes. @@ -2421,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*$/ @@ -2429,7 +3191,7 @@ sub ut_zip { { $self->setfield($field,''); } else { - $self->getfield($field) =~ /^\s*(\w[\w\-\s]{2,8}\w)\s*$/ + $self->getfield($field) =~ /^\s*(\w[\w\-\s]{0,8}\w)\s*$/ or return gettext('illegal_zip'). " $field: ". $self->getfield($field); $self->setfield($field,$1); } @@ -2449,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))); } @@ -2491,6 +3253,90 @@ sub ut_enum { return "Illegal (enum) field $field: ". $self->getfield($field); } +=item ut_enumn COLUMN CHOICES_ARRAYREF + +Like ut_enum, except the null value is also allowed. + +=cut + +sub ut_enumn { + my( $self, $field, $choices ) = @_; + $self->getfield($field) + ? $self->ut_enum($field, $choices) + : ''; +} + +=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 +is the standard form for boolean flags in Freeside. + +=cut + +sub ut_flag { + my( $self, $field ) = @_; + my $value = uc($self->getfield($field)); + if ( $value eq '' or $value eq 'Y' ) { + $self->setfield($field, $value); + return ''; + } + return "Illegal (flag) field $field: $value"; +} + =item ut_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN Check/untaint a foreign column key. Call a regular ut_ method (like ut_number) @@ -2500,7 +3346,7 @@ on the column first. sub ut_foreign_key { my( $self, $field, $table, $foreign ) = @_; - return '' if $no_check_foreign; + return $self->ut_number($field) if $no_check_foreign; qsearchs($table, { $foreign => $self->getfield($field) }) or return "Can't find ". $self->table. ".$field ". $self->getfield($field). " in $table.$foreign"; @@ -2540,12 +3386,12 @@ sub ut_agentnum_acl { if ( $self->$field() ) { - return "Access denied" + return 'Access denied to agent '. $self->$field() unless $curuser->agentnum($self->$field()); } else { - return "Access denied" + return 'Access denied to global' unless grep $curuser->access_right($_), @$null_acl; } @@ -2554,40 +3400,55 @@ sub ut_agentnum_acl { } -=item virtual_fields [ TABLE ] -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. +=item ut_email COLUMN + +Check column contains a valid E-Mail address =cut -sub virtual_fields { - my $self = shift; - my $table; - $table = $self->table or confess "virtual_fields called on non-table"; +sub ut_email { + my ( $self, $field ) = @_; + Email::Valid->address( $self->getfield( $field ) ) + ? '' + : "Illegal (email) field $field: ". $self->getfield( $field ); +} - confess "Unknown table $table" unless dbdef->table($table); +=item ut_emailn COLUMN - return () unless dbdef->table('part_virtual_field'); +Check column contains a valid E-Mail address - 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 "Error executing virtual fields query: $query: ". $dbh->errstr - if $dbh->err; - $virtual_fields_cache{$table} = $result; - } +May be null - @{$virtual_fields_cache{$table}}; +=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 and virtual_fields. Code that called +This is a wrapper for real_fields. Code that called fields before should probably continue to call fields. =cut @@ -2599,50 +3460,11 @@ sub fields { $table = $something->table; } else { $table = $something; - $something = "FS::$table"; + #$something = "FS::$table"; } - return (real_fields($table), $something->virtual_fields()); + return (real_fields($table)); } -=item pvf FIELD_NAME - -Returns the FS::part_virtual_field object corresponding to a field in the -record (specified by FIELD_NAME). - -=cut - -sub pvf { - my ($self, $name) = (shift, shift); - - if(grep /^$name$/, $self->virtual_fields) { - return qsearchs('part_virtual_field', { dbtable => $self->table, - name => $name } ); - } - '' -} - -=item vfieldpart_hashref TABLE - -Returns a hashref of virtual field names and vfieldparts applicable to the given -TABLE. - -=cut - -sub vfieldpart_hashref { - my $self = shift; - my $table = $self->table; - - return {} unless dbdef->table('part_virtual_field'); - - my $dbh = dbh; - my $statement = "SELECT vfieldpart, name FROM part_virtual_field WHERE ". - "dbtable = '$table'"; - my $sth = $dbh->prepare($statement); - $sth->execute or croak "Execution of '$statement' failed: ".$dbh->errstr; - return { map { $_->{name}, $_->{vfieldpart} } - @{$sth->fetchall_arrayref({})} }; - -} =item encrypt($value) @@ -2656,9 +3478,9 @@ You should generally not have to worry about calling this, as the system handles sub encrypt { my ($self, $value) = @_; - my $encrypted; + 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; @@ -2686,13 +3508,8 @@ Checks to see if the string is encrypted and returns true or false (1/0) to indi sub is_encrypted { my ($self, $value) = @_; - # Possible Bug - Some work may be required here.... - - if ($value =~ /^M/ && length($value) > 80) { - return 1; - } else { - return 0; - } + # could be more precise about it, but this will do for now + $value =~ /^M/ && length($value) > 80; } =item decrypt($value) @@ -2706,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); @@ -2718,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 @@ -2780,23 +3587,58 @@ sub h_date { $h ? $h->history_date : ''; } -=item scalar_sql SQL +=item scalar_sql SQL [ PLACEHOLDER, ... ] -A class method with a propensity for becoming an instance method. This -method executes the sql statement represented by SQL and returns a scalar -representing the result. Don't ask for rows -- you get the first column -of the first row. Don't give me bogus SQL or I'll die on you. +A class or object method. Executes the sql statement represented by SQL and +returns a scalar representing the result: the first column of the first row. -Returns an empty string in the event of no rows. +Dies on bogus SQL. Returns an empty string if no row is returned. + +Typically used for statments which return a single value such as "SELECT +COUNT(*) FROM table WHERE something" OR "SELECT column FROM table WHERE key = ?" =cut sub scalar_sql { - my($self, $sql ) = ( shift, shift ); + my($self, $sql) = (shift, shift); my $sth = dbh->prepare($sql) or die dbh->errstr; - $sth->execute + $sth->execute(@_) or die "Unexpected error executing statement $sql: ". $sth->errstr; - $sth->fetchrow_arrayref->[0] || ''; + my $row = $sth->fetchrow_arrayref or return ''; + my $scalar = $row->[0]; + defined($scalar) ? $scalar : ''; +} + +=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 +associated table. + +=cut + +sub count { + my($self, $where) = (shift, shift); + my $table = $self->table or die 'count called on object of class '.ref($self); + my $sql = "SELECT COUNT(*) FROM $table"; + $sql .= " WHERE $where" if $where; + $self->scalar_sql($sql, @_); +} + +=item row_exists [ WHERE [, PLACEHOLDER ...] ] + +Convenience method for the common case of "SELECT 1 FROM table ... LIMIT 1" +with optional (but almost always needed) WHERE. + +=cut + +sub row_exists { + my($self, $where) = (shift, shift); + my $table = $self->table or die 'row_exists called on object of class '.ref($self); + my $sql = "SELECT 1 FROM $table"; + $sql .= " WHERE $where" if $where; + $sql .= " LIMIT 1"; + $self->scalar_sql($sql, @_); } =back @@ -2807,7 +3649,7 @@ sub scalar_sql { =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 @@ -2820,6 +3662,29 @@ sub real_fields { $table_obj->columns; } +=item pvf FIELD_NAME + +Returns the FS::part_virtual_field object corresponding to a field in the +record (specified by FIELD_NAME). + +=cut + +sub pvf { + my ($self, $name) = (shift, shift); + + if(grep /^$name$/, $self->virtual_fields) { + $name =~ s/^cf_//; + my $concat = [ "'cf_'", "name" ]; + return qsearchs({ table => 'part_virtual_field', + hashref => { dbtable => $self->table, + name => $name + }, + select => 'vfieldpart, dbtable, length, label, '.concat_sql($concat).' as name', + }); + } + '' +} + =item _quote VALUE, TABLE, COLUMN This is an internal function used to construct SQL statements. It returns @@ -2834,6 +3699,8 @@ sub _quote { 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; @@ -2844,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); } @@ -2912,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; @@ -2935,13 +3810,114 @@ the current database. =cut -sub str2time_sql_closing { +sub str2time_sql_closing { my $driver = shift || driver_name; return ' )::INTEGER ' if $driver =~ /^Pg/i; return ' ) '; } +=item regexp_sql [ DRIVER_NAME ] + +Returns the operator to do a regular expression comparison based on database +type, such as '~' for Pg or 'REGEXP' for mysql. + +You can pass an optional driver name such as "Pg", "mysql" or +$dbh->{Driver}->{Name} to return a function for that database instead of +the current database. + +=cut + +sub regexp_sql { + my $driver = shift || driver_name; + + return '~' if $driver =~ /^Pg/i; + return 'REGEXP' if $driver =~ /^mysql/i; + + die "don't know how to use regular expressions in ". driver_name." databases"; + +} + +=item not_regexp_sql [ DRIVER_NAME ] + +Returns the operator to do a regular expression negation based on database +type, such as '!~' for Pg or 'NOT REGEXP' for mysql. + +You can pass an optional driver name such as "Pg", "mysql" or +$dbh->{Driver}->{Name} to return a function for that database instead of +the current database. + +=cut + +sub not_regexp_sql { + my $driver = shift || driver_name; + + return '!~' if $driver =~ /^Pg/i; + return 'NOT REGEXP' if $driver =~ /^mysql/i; + + die "don't know how to use regular expressions in ". driver_name." databases"; + +} + +=item concat_sql [ DRIVER_NAME ] ITEMS_ARRAYREF + +Returns the items concatenated based on database type, using "CONCAT()" for +mysql and " || " for Pg and other databases. + +You can pass an optional driver name such as "Pg", "mysql" or +$dbh->{Driver}->{Name} to return a function for that database instead of +the current database. + +=cut + +sub concat_sql { + my $driver = ref($_[0]) ? driver_name : shift; + my $items = shift; + + if ( $driver =~ /^mysql/i ) { + 'CONCAT('. join(',', @$items). ')'; + } else { + join('||', @$items); + } + +} + +=item group_concat_sql COLUMN, DELIMITER + +Returns an SQL expression to concatenate an aggregate column, using +GROUP_CONCAT() for mysql and array_to_string() and array_agg() for Pg. + +=cut + +sub group_concat_sql { + my ($col, $delim) = @_; + $delim = dbh->quote($delim); + if ( driver_name() =~ /^mysql/i ) { + # DISTINCT(foo) is valid as $col + return "GROUP_CONCAT($col SEPARATOR $delim)"; + } else { + return "array_to_string(array_agg($col), $delim)"; + } +} + +=item midnight_sql DATE + +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 + +sub midnight_sql { + my $driver = driver_name; + my $expr = shift; + if ( $driver =~ /^mysql/i ) { + "UNIX_TIMESTAMP(DATE(FROM_UNIXTIME($expr)))"; + } + else { + "EXTRACT( EPOCH FROM DATE(TO_TIMESTAMP($expr)) )"; + } +} + =back =head1 BUGS @@ -2998,4 +3974,3 @@ http://poop.sf.net/ =cut 1; -