X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=15636af9c14201926748d7afcc83dd51fa5ef925;hp=ab4ea2a5bf7b9a96dee10db2fd34a8f72485de08;hb=63973c641c4be00765fa27e55c57cc5b9aa4da19;hpb=bdfbb5a929adcaa493d046145bec6d6914e9611b diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index ab4ea2a5b..15636af9c 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -2,10 +2,12 @@ package FS::Record; use strict; use vars qw( $AUTOLOAD @ISA @EXPORT_OK $DEBUG - $conf $conf_encryption $me %virtual_fields_cache + $conf $conf_encryption $money_char $lat_lower $lon_upper + $me $nowarn_identical $nowarn_classload $no_update_diff $no_check_foreign + @encrypt_payby ); use Exporter; use Carp qw(carp cluck croak confess); @@ -16,11 +18,13 @@ 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 FS::UID qw(dbh datasrc driver_name); use FS::CurrentUser; use FS::Schema qw(dbdef); use FS::SearchCache; use FS::Msgcat qw(gettext); +use NetAddr::IP; # for validation +use Data::Dumper; #use FS::Conf; #dependency loop bs, in install_callback below instead use FS::part_virtual_field; @@ -29,9 +33,14 @@ use Tie::IxHash; @ISA = qw(Exporter); +@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 regexp_sql not_regexp_sql ); +@EXPORT_OK = qw( + dbh fields hfields qsearch qsearchs dbdef jsearch + str2time_sql str2time_sql_closing regexp_sql not_regexp_sql concat_sql + midnight_sql +); $DEBUG = 0; $me = '[FS::Record]'; @@ -49,17 +58,25 @@ my $rsa_decrypt; $conf = ''; $conf_encryption = ''; FS::UID->install_callback( sub { + eval "use FS::Conf;"; die $@ if $@; $conf = FS::Conf->new; $conf_encryption = $conf->exists('encryption'); + $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?'; }"; } + } ); =head1 NAME @@ -265,7 +282,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 +367,8 @@ sub qsearch { my @bind_type = (); my $dbh = dbh; foreach my $stable ( @stable ) { - my $record = shift @record; + #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 +389,12 @@ 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 ) { + 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)); } $statement .= " $extra_sql" if defined($extra_sql); @@ -450,23 +458,19 @@ 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; + } - # 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,28 +482,6 @@ 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; - } - } - } my @return; if ( eval 'scalar(@FS::'. $table. '::ISA);' ) { if ( eval 'FS::'. $table. '->can(\'new\')' eq \&new ) { @@ -527,6 +509,11 @@ sub qsearch { && 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))); } @@ -544,50 +531,6 @@ sub qsearch { ## makes this easier to read -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'}; - } - - # ... 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->{$_}; - - my $subq; - - $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; - - } @{ $virtual_fields } ) ; -} - sub get_real_fields { my $table = shift; my $record = shift; @@ -641,6 +584,8 @@ sub get_real_fields { qq-( $column $op "" )-; } } + } elsif ( $op eq '!=' ) { + qq-( $column IS NULL OR $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 @@ -962,10 +907,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 @@ -995,7 +942,12 @@ sub insert { && $conf->exists('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))); } } @@ -1093,34 +1045,6 @@ 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) ) { my $h_statement = $self->_h_statement('insert'); @@ -1192,17 +1116,6 @@ 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'; @@ -1214,9 +1127,6 @@ 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; @@ -1275,6 +1185,11 @@ sub replace { && scalar( eval '@FS::'. $new->table . '::encrypted_fields') ) { 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))); } @@ -1285,7 +1200,9 @@ sub replace { ? ($_, $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 ''; } @@ -1340,44 +1257,6 @@ 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'; @@ -1390,23 +1269,6 @@ 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 @@ -1448,35 +1310,49 @@ 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. +Checks custom fields. Subclasses should still provide a check method to validate +non-custom fields, foreign keys, etc., and call this method via $self->SUPER::check. + +=cut + +sub check { + my $self = shift; + foreach my $field ($self->virtual_fields) { + my $error = $self->ut_textn($field); + return $error if $error; + } + ''; +} + +=item virtual_fields [ TABLE ] -(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?) +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 check { - #confess "FS::Record::check not implemented; supply one in subclass!"; +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 process_batch_import JOB OPTIONS_HASHREF PARAMS @@ -1580,6 +1456,8 @@ 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}, #per-import job => $job, @@ -1589,6 +1467,7 @@ sub process_batch_import { params => { map { $_ => $param->{$_} } @pass_params }, #? default_csv => $opt->{default_csv}, + postinsert_callback => $opt->{postinsert_callback}, ); if ( $opt->{'batch_namecol'} ) { @@ -1627,6 +1506,8 @@ Class method for batch imports. Available params: =item fields - Alternate way to specify import, specifying import fields directly as a listref +=item preinsert_callback + =item postinsert_callback =item params @@ -1639,7 +1520,7 @@ FS::queue object, will be updated with progress =item type -csv, xls or fixedlength +csv, xls, fixedlength, xml =item empty_ok @@ -1659,8 +1540,17 @@ sub batch_import { my $file = $param->{file}; my $params = $param->{params} || {}; - my( $type, $header, $sep_char, $fixedlength_format, $row_callback, @fields ); + my( $type, $header, $sep_char, + $fixedlength_format, $xml_format, $asn_format, + $row_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'}; + if ( $param->{'format'} ) { my $format = $param->{'format'}; @@ -1685,6 +1575,16 @@ sub batch_import { ? $param->{'format_fixedlength_formats'}{ $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'} } @@ -1701,9 +1601,6 @@ sub batch_import { $row_callback = ''; @fields = @{ $param->{'fields'} }; - $postinsert_callback = $param->{'postinsert_callback'} - if $param->{'postinsert_callback'} - } else { die "neither format nor fields specified"; } @@ -1727,11 +1624,12 @@ sub batch_import { my $count; my $parser; my @buffer = (); + my $asn_header_buffer; if ( $type eq 'csv' || $type eq 'fixedlength' ) { if ( $type eq 'csv' ) { - my %attr = (); + my %attr = ( 'binary' => 1, ); $attr{sep_char} = $sep_char if $sep_char; $parser = new Text::CSV_XS \%attr; @@ -1739,9 +1637,10 @@ sub batch_import { eval "use Parse::FixedLength;"; die $@ if $@; - $parser = new Parse::FixedLength $fixedlength_format; - - } else { + $parser = Parse::FixedLength->new($fixedlength_format); + + } + else { die "Unknown file type $type\n"; } @@ -1768,6 +1667,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 die "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"; } @@ -1811,6 +1747,7 @@ sub batch_import { while (1) { my @columns = (); + my %hash = %$params; if ( $type eq 'csv' ) { last unless scalar(@buffer); @@ -1819,15 +1756,20 @@ 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' ) { @@ -1841,12 +1783,28 @@ 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 ) { @@ -1871,11 +1829,27 @@ 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} ); } next if exists( $param->{skiprow} ); + 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 $error = $record->insert; if ( $error ) { @@ -1902,9 +1876,12 @@ sub batch_import { } - $dbh->commit or die $dbh->errstr if $oldAutoCommit;; + unless ( $imported || $param->{empty_ok} ) { + $dbh->rollback if $oldAutoCommit; + return "Empty file!"; + } - return "Empty file!" unless $imported || $param->{empty_ok}; + $dbh->commit or die $dbh->errstr if $oldAutoCommit;; ''; #no error @@ -1923,7 +1900,7 @@ sub _h_statement { ; # If we're encrypting then don't store the payinfo in the history - if ( $conf && $conf->exists('encryption') ) { + if ( $conf && $conf->exists('encryption') && $self->table ne 'banned_pay' ) { @fields = grep { $_ ne 'payinfo' } @fields; } @@ -1932,7 +1909,11 @@ sub _h_statement { "INSERT INTO h_". $self->table. " ( ". join(', ', qw(history_date history_user history_action), @fields ). ") VALUES (". - join(', ', $time, dbh->quote(getotaker()), dbh->quote($action), @values). + join(', ', $time, + dbh->quote( $FS::CurrentUser::CurrentUser->username ), + dbh->quote($action), + @values + ). ")" ; } @@ -1963,11 +1944,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 } ); @@ -2122,11 +2098,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); + } + ''; } @@ -2161,7 +2144,7 @@ sub ut_text { #warn "notexist ". \¬exist. "\n"; #warn "AUTOLOAD ". \&AUTOLOAD. "\n"; $self->getfield($field) - =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>]+)$/ + =~ /^([\wô \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>$money_char]+)$/ or return gettext('illegal_or_empty_text'). " $field: ". $self->getfield($field); $self->setfield($field,$1); @@ -2171,14 +2154,14 @@ 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)=@_; - return $self->setfield($field, '') if $self-getfield($field) =~ /^$/; + return $self->setfield($field, '') if $self->getfield($field) =~ /^$/; $self->ut_text($field); } @@ -2302,6 +2285,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 @@ -2336,6 +2355,35 @@ 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->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); +} + =item ut_coord COLUMN [ LOWER [ UPPER ] ] Check/untaint coordinates. @@ -2361,11 +2409,17 @@ 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/^(-)//; @@ -2413,7 +2467,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, @_); @@ -2421,10 +2475,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 @@ -2432,11 +2485,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 @@ -2448,12 +2517,32 @@ May not be null. sub ut_name { my( $self, $field ) = @_; +# warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n"; $self->getfield($field) =~ /^([\w \,\.\-\']+)$/ 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. @@ -2487,7 +2576,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); } @@ -2549,6 +2638,36 @@ 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_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) @@ -2612,40 +2731,9 @@ 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. - -=cut - -sub virtual_fields { - 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_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; - } - - @{$virtual_fields_cache{$table}}; - -} - - =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 @@ -2659,48 +2747,9 @@ sub fields { $table = $something; $something = "FS::$table"; } - return (real_fields($table), $something->virtual_fields()); -} - -=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 } ); - } - '' + return (real_fields($table)); } -=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) @@ -2855,10 +2904,27 @@ sub scalar_sql { my $sth = dbh->prepare($sql) or die dbh->errstr; $sth->execute(@_) or die "Unexpected error executing statement $sql: ". $sth->errstr; - my $scalar = $sth->fetchrow_arrayref->[0]; + my $row = $sth->fetchrow_arrayref or return ''; + my $scalar = $row->[0]; defined($scalar) ? $scalar : ''; } +=item count [ WHERE ] + +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); +} + =back =head1 SUBROUTINES @@ -2880,6 +2946,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 @@ -3044,6 +3133,47 @@ sub not_regexp_sql { } +=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 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