X-Git-Url: http://git.freeside.biz/gitweb/?p=freeside.git;a=blobdiff_plain;f=FS%2FFS%2FRecord.pm;h=ffeabcb17e1b011f9d3df5c38d1f0a0ffb7a1c2d;hp=88d8ca9a348b2c5cfd89cbb2e135cd3b571f5cc0;hb=7f4e4fddb595f5c825a18c88ed79029160650dc9;hpb=50a2633bf3c8e4be5bb1f6bdd4a2cc8bd6b954a9 diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm index 88d8ca9a3..ffeabcb17 100644 --- a/FS/FS/Record.pm +++ b/FS/FS/Record.pm @@ -15,12 +15,13 @@ use Locale::Country; use Text::CSV_XS; use File::Slurp qw( slurp ); use DBI qw(:sql_types); -use DBIx::DBSchema 0.33; +use DBIx::DBSchema 0.38; use FS::UID qw(dbh getotaker 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 FS::Conf; #dependency loop bs, in install_callback below instead use FS::part_virtual_field; @@ -30,8 +31,10 @@ use Tie::IxHash; @ISA = qw(Exporter); #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 ); +@EXPORT_OK = qw( + dbh fields hfields qsearch qsearchs dbdef jsearch + str2time_sql str2time_sql_closing regexp_sql not_regexp_sql concat_sql +); $DEBUG = 0; $me = '[FS::Record]'; @@ -350,7 +353,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; @@ -795,6 +799,17 @@ sub setfield { $self->set(@_); } +=item exists COLUMN + +Returns true if the column/field/key COLUMN exists. + +=cut + +sub exists { + my($self,$field) = @_; + exists($self->{Hash}->{$field}); +} + =item AUTLOADED METHODS $record->column is a synonym for $record->get('column'); @@ -962,12 +977,12 @@ sub insert { my $db_seq = 0; if ( $primary_key ) { my $col = $self->dbdef_table->column($primary_key); - + $db_seq = uc($col->type) =~ /^(BIG)?SERIAL\d?/ || ( driver_name eq 'Pg' && defined($col->default) - && $col->default =~ /^nextval\(/i + && $col->quoted_default =~ /^nextval\(/i ) || ( driver_name eq 'mysql' && defined($col->local) @@ -1032,7 +1047,7 @@ sub insert { #my $oid = $sth->{'pg_oid_status'}; #my $i_sql = "SELECT $primary_key FROM $table WHERE oid = ?"; - my $default = $self->dbdef_table->column($primary_key)->default; + my $default = $self->dbdef_table->column($primary_key)->quoted_default; unless ( $default =~ /^nextval\(\(?'"?([\w\.]+)"?'/i ) { dbh->rollback if $FS::UID::AutoCommit; return "can't parse $table.$primary_key default value". @@ -1547,7 +1562,7 @@ sub process_batch_import { my($job, $opt) = ( shift, shift ); my $table = $opt->{table}; - my @pass_params = @{ $opt->{params} }; + my @pass_params = $opt->{params} ? @{ $opt->{params} } : (); my %formats = %{ $opt->{formats} }; my $param = thaw(decode_base64(shift)); @@ -1561,24 +1576,33 @@ sub process_batch_import { my $dir = '%%%FREESIDE_CACHE%%%/cache.'. $FS::UID::datasrc. '/'; my $file = $dir. $files{'file'}; - my $error = - FS::Record::batch_import( { - #class-static - table => $table, - formats => \%formats, - format_types => $opt->{format_types}, - format_headers => $opt->{format_headers}, - format_sep_chars => $opt->{format_sep_chars}, - format_fixedlength_formats => $opt->{format_fixedlength_formats}, - #per-import - job => $job, - file => $file, - #type => $type, - format => $param->{format}, - params => { map { $_ => $param->{$_} } @pass_params }, - #? - default_csv => $opt->{default_csv}, - } ); + my %iopt = ( + #class-static + table => $table, + formats => \%formats, + format_types => $opt->{format_types}, + 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_row_callbacks => $opt->{format_row_callbacks}, + #per-import + job => $job, + file => $file, + #type => $type, + format => $param->{format}, + params => { map { $_ => $param->{$_} } @pass_params }, + #? + default_csv => $opt->{default_csv}, + postinsert_callback => $opt->{postinsert_callback}, + ); + + if ( $opt->{'batch_namecol'} ) { + $iopt{'batch_namevalue'} = $param->{ $opt->{'batch_namecol'} }; + $iopt{$_} = $opt->{$_} foreach qw( batch_keycol batch_table batch_namecol ); + } + + my $error = FS::Record::batch_import( \%iopt ); unlink $file; @@ -1593,6 +1617,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 @@ -1603,6 +1629,14 @@ Class method for batch imports. Available params: =item format_fixedlength_formats +=item format_row_callbacks + +=item fields - Alternate way to specify import, specifying import fields directly as a listref + +=item preinsert_callback + +=item postinsert_callback + =item params =item job @@ -1613,9 +1647,7 @@ FS::queue object, will be updated with progress =item type -csv, xls or fixedlength - -=item format +csv, xls, fixedlength, xml =item empty_ok @@ -1630,18 +1662,71 @@ 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( $type, $header, $sep_char, $fixedlength_format, + $xml_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 $type = $param->{'format_types'} - ? $param->{'format_types'}{ $format } - : $param->{type} || 'csv'; + 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'} } + : ','; + + $fixedlength_format = + $param->{'format_fixedlength_formats'} + ? $param->{'format_fixedlength_formats'}{ $param->{'format'} } + : ''; + + $xml_format = + $param->{'format_xml_formats'} + ? $param->{'format_xml_formats'}{ $param->{'format'} } + : ''; + + $row_callback = + $param->{'format_row_callbacks'} + ? $param->{'format_row_callbacks'}{ $param->{'format'} } + : ''; + + @fields = @{ $formats->{ $format } }; + + } elsif ( $param->{'fields'} ) { + + $type = ''; #infer from filename + $header = 0; + $sep_char = ','; + $fixedlength_format = ''; + $row_callback = ''; + @fields = @{ $param->{'fields'} }; + + } else { + die "neither format nor fields specified"; + } + + #my $file = $param->{file}; unless ( $type ) { if ( $file =~ /\.(\w+)$/i ) { @@ -1655,20 +1740,6 @@ 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; @@ -1686,9 +1757,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"; } @@ -1714,7 +1786,22 @@ sub batch_import { $count++; $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; } else { die "Unknown file type $type\n"; } @@ -1731,7 +1818,27 @@ sub batch_import { my $oldAutoCommit = $FS::UID::AutoCommit; 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'}; + + my $batch_class = 'FS::'. $param->{'batch_table'}; + my $batch = $batch_class->new({ + $param->{'batch_namecol'} => $param->{'batch_namevalue'} + }); + my $error = $batch->insert; + if ( $error ) { + $dbh->rollback if $oldAutoCommit; + return "can't insert batch record: $error"; + } + #primary key via dbdef? (so the column names don't have to match) + my $batch_value = $batch->get( $param->{'batch_keycol'} ); + + $params->{ $batch_col } = $batch_value; + } + + #my $job = $param->{job}; my $line; my $imported = 0; my( $last, $min_sec ) = ( time, 5 ); #progressbar foo @@ -1743,14 +1850,23 @@ sub batch_import { last unless scalar(@buffer); $line = shift(@buffer); + 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' ) { @@ -1764,6 +1880,11 @@ 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 }; } else { die "Unknown file type $type\n"; } @@ -1785,6 +1906,7 @@ sub batch_import { } + #my $table = $param->{table}; my $class = "FS::$table"; my $record = $class->new( \%hash ); @@ -1793,11 +1915,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 ) { @@ -1808,6 +1946,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; @@ -1815,9 +1962,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 @@ -2091,11 +2241,8 @@ May be null. If there is an error, returns the error, otherwise returns false. 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 @@ -2114,7 +2261,7 @@ sub ut_alpha { ''; } -=item ut_alpha COLUMN +=item ut_alphan COLUMN Check/untaint alphanumeric strings (no spaces). May be null. If there is an error, returns the error, otherwise returns false. @@ -2129,6 +2276,22 @@ sub ut_alphan { ''; } +=item ut_alphasn COLUMN + +Check/untaint alphanumeric strings, spaces allowed. May be null. If there is +an error, returns the error, otherwise returns false. + +=cut + +sub ut_alphasn { + my($self,$field)=@_; + $self->getfield($field) =~ /^([\w ]*)$/ + or return "Illegal (alphanumeric) $field: ". $self->getfield($field); + $self->setfield($field,$1); + ''; +} + + =item ut_alpha_lower COLUMN Check/untaint lowercase alphanumeric strings (no spaces). May not be null. If @@ -2236,6 +2399,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. @@ -2348,6 +2540,7 @@ 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); @@ -2449,6 +2642,20 @@ 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_foreign_key COLUMN FOREIGN_TABLE FOREIGN_COLUMN Check/untaint a foreign column key. Call a regular ut_ method (like ut_number) @@ -2738,6 +2945,28 @@ sub h_date { $h ? $h->history_date : ''; } +=item scalar_sql SQL [ PLACEHOLDER, ... ] + +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. + +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 $sth = dbh->prepare($sql) or die dbh->errstr; + $sth->execute(@_) + or die "Unexpected error executing statement $sql: ". $sth->errstr; + my $row = $sth->fetchrow_arrayref or return ''; + my $scalar = $row->[0]; + defined($scalar) ? $scalar : ''; +} + =back =head1 SUBROUTINES @@ -2881,6 +3110,71 @@ sub str2time_sql_closing { 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 concatendated 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); + } + +} + =back =head1 BUGS