import torrus 1.0.9

[freeside.git] / FS / FS / Record.pm

diff --git a/FS/FS/Record.pm b/FS/FS/Record.pm
index ab4ea2a..2e2612e 100644 (file)
--- a/FS/FS/Record.pm
+++ b/FS/FS/Record.pm
@@ -350,7 +350,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;
@@ -1580,6 +1581,7 @@ 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_row_callbacks       => $opt->{format_row_callbacks},
     #per-import
     job                        => $job,
@@ -1639,7 +1641,7 @@ FS::queue object, will be updated with progress
 
 =item type
 
-csv, xls or fixedlength
+csv, xls, fixedlength, xml
 
 =item empty_ok
 
@@ -1659,7 +1661,8 @@ 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, $row_callback, @fields );
   my $postinsert_callback = '';
   if ( $param->{'format'} ) {
 
@@ -1685,6 +1688,11 @@ sub batch_import {
         ? $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'} }
@@ -1740,8 +1748,9 @@ sub batch_import {
       eval "use Parse::FixedLength;";
       die $@ if $@;
       $parser = new Parse::FixedLength $fixedlength_format;
- 
-    } else {
+
+    }
+    else {
       die "Unknown file type $type\n";
     }
 
@@ -1767,7 +1776,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";
   }
@@ -1841,6 +1865,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";
     }
@@ -1871,7 +1900,13 @@ 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} );
@@ -1902,9 +1937,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
 
@@ -2161,7 +2199,7 @@ sub ut_text {
   #warn "notexist ". \&notexist. "\n";
   #warn "AUTOLOAD ". \&AUTOLOAD. "\n";
   $self->getfield($field)
-    =~ /^([\w \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>]+)$/
+    =~ /^([µ_0123456789aAáÁàÀâÂåÅäÄãêæÆbBcCçÇdDðÐeEéÉèÈêÊëËfFgGhHiIíÍìÌîÎïÏjJkKlLmMnNñÑoOóÓòÒôÔöÖõÕøغpPqQrRsSßtTuUúÚùÙûÛüÜvVwWxXyYýÝÿzZþÞ \!\@\#\$\%\&\(\)\-\+\;\:\'\"\,\.\?\/\=\[\]\<\>]+)$/
       or return gettext('illegal_or_empty_text'). " $field: ".
                  $self->getfield($field);
   $self->setfield($field,$1);
@@ -2178,7 +2216,7 @@ May be null.  If there is an error, returns the error, otherwise returns false.
 
 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);
 }
 
@@ -2448,7 +2486,9 @@ May not be null.
 
 sub ut_name {
   my( $self, $field ) = @_;
-  $self->getfield($field) =~ /^([\w \,\.\-\']+)$/
+#  warn "ut_name allowed alphanumerics: +(sort grep /\w/, map { chr() } 0..255), "\n";
+  #$self->getfield($field) =~ /^([\w \,\.\-\']+)$/
+  $self->getfield($field) =~ /^([µ_0123456789aAáÁàÀâÂåÅäÄãêæÆbBcCçÇdDðÐeEéÉèÈêÊëËfFgGhHiIíÍìÌîÎïÏjJkKlLmMnNñÑoOóÓòÒôÔöÖõÕøغpPqQrRsSßtTuUúÚùÙûÛüÜvVwWxXyYýÝÿzZþÞ \,\.\-\']+)$/
     or return gettext('illegal_name'). " $field: ". $self->getfield($field);
   $self->setfield($field,$1);
   '';
@@ -2549,6 +2589,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)