SL::Helper::Csv kann mit Multiplex-Daten (mehreren Profilen) umgehen.

[mfinanz.git] / SL / Helper / Csv.pm

diff --git a/SL/Helper/Csv.pm b/SL/Helper/Csv.pm
index 5aac00b486f421939f3c4149d552cc7c5ad95ee9..4a8bc752e1c096bfa68784e1bd08fa7e9ac67f4b 100644 (file)
--- a/SL/Helper/Csv.pm
+++ b/SL/Helper/Csv.pm
@@ -3,17 +3,19 @@ package SL::Helper::Csv;
 use strict;
 use warnings;
 
 use strict;
 use warnings;
 

+use version 0.77;

 use Carp;
 use IO::File;
 use Params::Validate qw(:all);
 use Carp;
 use IO::File;
 use Params::Validate qw(:all);

-use Text::CSV;
+use Text::CSV_XS;

 use Rose::Object::MakeMethods::Generic scalar => [ qw(
 use Rose::Object::MakeMethods::Generic scalar => [ qw(

-  file encoding sep_char quote_char escape_char header profile class
-  numberformat dateformat ignore_unknown_columns _io _csv _objects _parsed
-  _data _errors
+  file encoding sep_char quote_char escape_char header profile
+  numberformat dateformat ignore_unknown_columns strict_profile is_multiplexed
+  _io _csv _objects _parsed _data _errors all_cvar_configs case_insensitive_header

 ) ];
 
 use SL::Helper::Csv::Dispatcher;
 ) ];
 
 use SL::Helper::Csv::Dispatcher;

+use SL::Helper::Csv::Error;

 
 # public interface
 
 
 # public interface
 


@@ -24,20 +26,21 @@ sub new {
     quote_char             => { default => '"' },
     escape_char            => { default => '"' },
     header                 => { type    => ARRAYREF, optional => 1 },
     quote_char             => { default => '"' },
     escape_char            => { default => '"' },
     header                 => { type    => ARRAYREF, optional => 1 },

-    profile                => { type    => HASHREF,  optional => 1 },
+    profile                => { type    => ARRAYREF, optional => 1 },

     file                   => 1,
     encoding               => 0,
     file                   => 1,
     encoding               => 0,

-    class                  => 0,

     numberformat           => 0,
     dateformat             => 0,
     ignore_unknown_columns => 0,
     numberformat           => 0,
     dateformat             => 0,
     ignore_unknown_columns => 0,

+    strict_profile         => 0,
+    case_insensitive_header => 0,

   });
   my $self = bless {}, $class;
 
   $self->$_($params{$_}) for keys %params;
 
   $self->_io(IO::File->new);
   });
   my $self = bless {}, $class;
 
   $self->$_($params{$_}) for keys %params;
 
   $self->_io(IO::File->new);

-  $self->_csv(Text::CSV->new({
+  $self->_csv(Text::CSV_XS->new({

     binary => 1,
     sep_char    => $self->sep_char,
     quote_char  => $self->quote_char,
     binary => 1,
     sep_char    => $self->sep_char,
     quote_char  => $self->quote_char,


@@ -53,6 +56,7 @@ sub parse {
   my ($self, %params) = @_;
 
   $self->_open_file;
   my ($self, %params) = @_;
 
   $self->_open_file;

+  return if ! $self->_check_multiplexed;

   return if ! $self->_check_header;
   return if ! $self->dispatcher->parse_profile;
   return if ! $self->_parse_data;
   return if ! $self->_check_header;
   return if ! $self->dispatcher->parse_profile;
   return if ! $self->_parse_data;


@@ -67,7 +71,6 @@ sub get_data {
 
 sub get_objects {
   my ($self, %params) = @_;
 
 sub get_objects {
   my ($self, %params) = @_;

-  croak 'no class given'   unless $self->class;

   croak 'must parse first' unless $self->_parsed;
 
   $self->_make_objects unless $self->_objects;
   croak 'must parse first' unless $self->_parsed;
 
   $self->_make_objects unless $self->_objects;


@@ -95,41 +98,136 @@ sub _open_file {
   return $self->_io;
 }
 
   return $self->_io;
 }
 

+# check, if data is multiplexed and if all nessesary infos are given
+sub _check_multiplexed {
+  my ($self, %params) = @_;
+
+  $self->is_multiplexed(0);
+
+  # If more than one profile is given, it is multiplexed.
+  if ($self->profile) {
+    my @profile = @{ $self->profile };
+    if (scalar @profile > 1) {
+      my $info_ok = 1;
+      # Each profile needs a class and a row_ident
+      foreach my $p (@profile) {
+        if ( !defined $p->{class} || !defined $p->{row_ident} ) {
+          $info_ok = 0;
+          last;
+        }
+      }
+
+      # If header is given, there need to be a header for each profile
+      if ($info_ok && $self->header) {
+        my @header = @{ $self->header };
+        if (scalar @profile != scalar @header) {
+          $info_ok = 0;
+        }
+      }
+      $self->is_multiplexed($info_ok);
+      return $info_ok;
+    }
+  }
+
+  # ok, if not multiplexed
+  return 1;
+}
+

 sub _check_header {
   my ($self, %params) = @_;
 sub _check_header {
   my ($self, %params) = @_;

-  return $self->header if $self->header;
+  my $header;
+
+  $header = $self->header;
+  if (!$header) {
+    my $n_header = ($self->is_multiplexed)? scalar @{ $self->profile } : 1;
+    foreach my $p_num (0..$n_header - 1) {
+      my $h = $self->_csv->getline($self->_io);

 
 

-  my $header = $self->_csv->getline($self->_io);
+      $self->_push_error([
+        $self->_csv->error_input,
+        $self->_csv->error_diag,
+        0,
+      ]) unless $h;

 
 

-  $self->_push_error([
-    $self->_csv->error_input,
-    $self->_csv->error_diag,
-    0,
-  ]) unless $header;
+      push @{ $header }, $h;
+    }
+  }

 
 

-  $self->header($header);
+  # Special case: utf8 BOM.
+  # certain software (namely MS Office and notepad.exe insist on prefixing
+  # data with a discouraged but valid byte order mark
+  # if not removed, the first header field will not be recognized
+  if ($header) {
+    foreach my $h (@{ $header }) {
+      if ($h && $h->[0] && $self->encoding =~ /utf-?8/i) {
+        $h->[0] =~ s/^\x{FEFF}//;
+      }
+    }
+  }
+
+  # check, if all header fields are parsed well
+  my $all_ok = 1;
+  if ($header) {
+    foreach my $h (@{ $header }) {
+      if (!$h) {
+        $all_ok = 0;
+        last;
+      }
+    }
+  } else {
+    $all_ok = 0;
+  }
+  return unless $all_ok;
+
+  # Special case: human stupidity
+  # people insist that case sensitivity doesn't exist and try to enter all
+  # sorts of stuff. at this point we've got a profile (with keys that represent
+  # valid methods), and a header full of strings. if two of them match, the user
+  # mopst likely meant that field, so rewrite the header
+  if ($self->case_insensitive_header) {
+    die 'case_insensitive_header is only possible with profile' unless $self->profile;
+    my @names = (
+      keys %{ $self->profile || {} },
+    );
+    for my $name (@names) {
+      for my $i (0..$#$header) {
+        $header->[$i] = $name if lc $header->[$i] eq lc $name;
+      }
+    }
+  }
+
+  return $self->header($header);

 }
 
 sub _parse_data {
   my ($self, %params) = @_;
   my (@data, @errors);
 
 }
 
 sub _parse_data {
   my ($self, %params) = @_;
   my (@data, @errors);
 

-  $self->_csv->column_names(@{ $self->header });
-

   while (1) {
     my $row = $self->_csv->getline($self->_io);
   while (1) {
     my $row = $self->_csv->getline($self->_io);

-    last if $self->_csv->eof;

     if ($row) {
     if ($row) {

+      my $header = $self->_header_by_row($row);
+      $self->_csv->column_names(@{ $header });

       my %hr;
       my %hr;

-      @hr{@{ $self->header }} = @$row;
+      @hr{@{ $header }} = @$row;

       push @data, \%hr;
     } else {
       push @data, \%hr;
     } else {

-      push @errors, [
-        $self->_csv->error_input,
-        $self->_csv->error_diag,
-        $self->_io->input_line_number,
-      ];
+      last if $self->_csv->eof;
+      # Text::CSV_XS 0.89 added record number to error_diag
+      if (qv(Text::CSV_XS->VERSION) >= qv('0.89')) {
+        push @errors, [
+          $self->_csv->error_input,
+          $self->_csv->error_diag,
+        ];
+      } else {
+        push @errors, [
+          $self->_csv->error_input,
+          $self->_csv->error_diag,
+          $self->_io->input_line_number,
+        ];
+      }

     }
     }

+    last if $self->_csv->eof;

   }
 
   $self->_data(\@data);
   }
 
   $self->_data(\@data);


@@ -138,6 +236,23 @@ sub _parse_data {
   return ! @errors;
 }
 
   return ! @errors;
 }
 

+sub _header_by_row {
+  my ($self, $row) = @_;
+
+  my @header = @{ $self->header };
+  if ($self->is_multiplexed) {
+    my $i = 0;
+    foreach my $profile (@{ $self->profile }) {
+      if (@{ $row }[0] eq $profile->{row_ident}) {
+        return $header[$i];
+      }
+      $i++;
+    }
+  } else {
+    return $header[0];
+  }
+}
+

 sub _encode_layer {
   ':encoding(' . $_[0]->encoding . ')';
 }
 sub _encode_layer {
   ':encoding(' . $_[0]->encoding . ')';
 }


@@ -146,13 +261,11 @@ sub _make_objects {
   my ($self, %params) = @_;
   my @objs;
 
   my ($self, %params) = @_;
   my @objs;
 

-  eval "require " . $self->class;

   local $::myconfig{numberformat} = $self->numberformat if $self->numberformat;
   local $::myconfig{dateformat}   = $self->dateformat   if $self->dateformat;
 
   for my $line (@{ $self->_data }) {
   local $::myconfig{numberformat} = $self->numberformat if $self->numberformat;
   local $::myconfig{dateformat}   = $self->dateformat   if $self->dateformat;
 
   for my $line (@{ $self->_data }) {

-    my $tmp_obj = $self->class->new;
-    $self->dispatcher->dispatch($tmp_obj, $line);
+    my $tmp_obj = $self->dispatcher->dispatch($line);

     push @objs, $tmp_obj;
   }
 
     push @objs, $tmp_obj;
   }
 


@@ -180,7 +293,7 @@ sub _guess_encoding {
 
 sub _push_error {
   my ($self, @errors) = @_;
 
 sub _push_error {
   my ($self, @errors) = @_;

-  my @new_errors = ($self->errors, @errors);
+  my @new_errors = ($self->errors, map { SL::Helper::Csv::Error->new(@$_) } @errors);

   $self->_errors(\@new_errors);
 }
 
   $self->_errors(\@new_errors);
 }
 


@@ -205,9 +318,9 @@ SL::Helper::Csv - take care of csv file uploads
     sep_char    => ',',     # default ';'
     quote_char  => '\'',    # default '"'
     escape_char => '"',     # default '"'
     sep_char    => ',',     # default ';'
     quote_char  => '\'',    # default '"'
     escape_char => '"',     # default '"'

-    header      => [qw(id text sellprice word)], # see later
-    profile     => { sellprice => 'sellprice_as_number' },
-    class       => 'SL::DB::CsvLine',   # if present, map lines to this
+    header      => [ [qw(id text sellprice word)] ], # see later
+    profile     => [ { profile => { sellprice => 'sellprice_as_number'},
+                       class   => 'SL::DB::Part' } ],

   );
 
   my $status  = $csv->parse;
   );
 
   my $status  = $csv->parse;


@@ -238,7 +351,7 @@ it. You provide valid header columns and their mapping to the objects.
 =item You do NOT know if the csv provider yields to your expectations.
 
 Stuff that does not work with what you expect should not crash anything, but
 =item You do NOT know if the csv provider yields to your expectations.
 
 Stuff that does not work with what you expect should not crash anything, but

-give you a hint what went wrong. As a result, if you remeber to check for
+give you a hint what went wrong. As a result, if you remember to check for

 errors after each step, you should be fine.
 
 =item Data does not make sense. It's just data.
 errors after each step, you should be fine.
 
 =item Data does not make sense. It's just data.


@@ -248,6 +361,13 @@ unique, other data needs to be connected to existing data sets. This will not
 happen here. You will receive a plain mapping of the data into the class tree,
 nothing more.
 
 happen here. You will receive a plain mapping of the data into the class tree,
 nothing more.
 

+=item Multiplex data
+
+This module can handle multiplexed data of different class types. In that case
+multiple profiles with classes and row identifiers must be given. Multiple
+headers may also be given or read from csv data. Data must contain the row
+identifier in the first column and it's field name must be 'datatype'.
+

 =back
 
 =head1 METHODS
 =back
 
 =head1 METHODS


@@ -301,16 +421,33 @@ guessing. Know what your data is. Defaults to utf-8.
 
 Same as in L<Text::CSV>
 
 
 Same as in L<Text::CSV>
 

-=item C<header> \@FIELDS
+=item C<header> \@HEADERS
+
+If given, it contains an ARRAYREF for each different class type (i.e. one
+ARRAYREF if the data is only of one class type). These ARRAYREFS are the header
+fields which are an array of columns. In this case the first lines are not used
+as a header. Empty header fields will be ignored in objects.
+
+If not given, headers are taken from the first n lines of data, where n is the
+number of different class types.
+
+Examples:
+
+  classic data of one type:
+  [ [ 'name', 'street', 'zipcode', 'city' ] ]

 
 

-Can be an array of columns, in this case the first line is not used as a
-header. Empty header fields will be ignored in objects.
+  multiplexed data with two different types
+  [ [ 'ordernumber', 'customer', 'transdate' ], [ 'partnumber', 'qty', 'sellprice' ] ]

 
 

-=item C<profile> \%ACCESSORS
+=item C<profile> [{profile => \%ACCESSORS, class => class, row_ident => ri},]

 
 

-May be used to map header fields to custom accessors. Example:
+This is an ARRAYREF to HASHREFs which may contain the keys C<profile>, C<class>
+and C<row_ident>.

 
 

-  { listprice => listprice_as_number }
+The C<profile> is a HASHREF which may be used to map header fields to custom
+accessors. Example:
+
+  [ {profile => { listprice => listprice_as_number }} ]

 
 In this case C<listprice_as_number> will be used to read in values from the
 C<listprice> column.
 
 In this case C<listprice_as_number> will be used to read in values from the
 C<listprice> column.


@@ -318,7 +455,7 @@ C<listprice> column.
 In case of a One-To-One relationsship these can also be set over
 relationsships by sparating the steps with a dot (C<.>). This will work:
 
 In case of a One-To-One relationsship these can also be set over
 relationsships by sparating the steps with a dot (C<.>). This will work:
 

-  { customer => 'customer.name' }
+  [ {profile => { customer => 'customer.name' }} ]

 
 And will result in something like this:
 
 
 And will result in something like this:
 


@@ -331,31 +468,59 @@ these information are unique, and should be connected to preexisting data, you
 will have to do that for yourself. Since you provided the profile, it is
 assumed you know what to do in this case.
 
 will have to do that for yourself. Since you provided the profile, it is
 assumed you know what to do in this case.
 

-=item C<class>
-
-If present, the line will be handed to the new sub of this class,
+If C<class> is present, the line will be handed to the new sub of this class,

 and the return value used instead of the line itself.
 
 and the return value used instead of the line itself.
 

+C<row_ident> is a string to recognize the right profile and class for each data
+line in multiplexed data.
+
+In case of multiplexed data, C<class> and C<row_ident> must be given.
+Example:
+  [ {
+      class     => 'SL::DB::Order',
+      row_ident => 'O'
+    },
+    {
+      class     => 'SL::DB::OrderItem',
+      row_ident => 'I',
+      profile   => {sellprice => sellprice_as_number}
+    } ]
+

 =item C<ignore_unknown_columns>
 
 If set, the import will ignore unkown header columns. Useful for lazy imports,
 but deactivated by default.
 
 =item C<ignore_unknown_columns>
 
 If set, the import will ignore unkown header columns. Useful for lazy imports,
 but deactivated by default.
 

+=item C<case_insensitive_header>
+
+If set, header columns will be matched against profile entries case
+insensitive, and on match the profile name will be taken.
+
+Only works if a profile is given, will die otherwise.
+
+If both C<case_insensitive_header> and C<strict_profile> is set, matched header
+columns will be accepted.
+
+=item C<strict_profile>
+
+If set, all columns to be parsed must be specified in C<profile>. Every header
+field not listed there will be treated like an unknown column.
+
+If both C<case_insensitive_header> and C<strict_profile> is set, matched header
+columns will be accepted.
+

 =back
 
 =head1 ERROR HANDLING
 
 After parsing a file all errors will be accumulated into C<errors>.
 =back
 
 =head1 ERROR HANDLING
 
 After parsing a file all errors will be accumulated into C<errors>.

+Each entry is an object with the following attributes:

 
 

-Each entry is an arrayref with the following structure:
-
- [
- 0  offending raw input,
- 1  Text::CSV error code if Text:CSV signalled an error, 0 else,
- 2  error diagnostics,
- 3  position in line,
- 4  estimated line in file,
- ]
+ raw_input:  offending raw input,
+ code:   Text::CSV error code if Text:CSV signalled an error, 0 else,
+ diag:   error diagnostics,
+ line:   position in line,
+ col:    estimated line in file,

 
 Note that the last entry can be off, but will give an estimate.
 
 
 Note that the last entry can be off, but will give an estimate.
 


@@ -379,18 +544,20 @@ Encoding errors are not dealt with properly.
 Dispatch to child objects, like this:
 
  $csv = SL::Helper::Csv->new(
 Dispatch to child objects, like this:
 
  $csv = SL::Helper::Csv->new(

-   file  => ...
-   class => SL::DB::Part,
-   profile => [
-     makemodel => {
-       make_1  => make,
-       model_1 => model,
-     },
-     makemodel => {
-       make_2  => make,
-       model_2 => model,
-     },
-   ]
+   file    => ...
+   profile => [ {
+     profile => [
+       makemodel => {
+         make_1  => make,
+         model_1 => model,
+       },
+       makemodel => {
+         make_2  => make,
+         model_2 => model,
+       },
+     ],
+     class   => SL::DB::Part,
+   } ]

  );
 
 =head1 AUTHOR
  );
 
 =head1 AUTHOR