my $profile = $self->profile;
$self->csv(SL::Helper::Csv->new(file => $self->file->file_name,
encoding => $self->controller->profile->get('charset'),
- profile => { profile => $profile, class => $self->class },
+ profile => [{ profile => $profile, class => $self->class }],
ignore_unknown_columns => 1,
strict_profile => 1,
case_insensitive_header => 1,
$self->controller->track_progress(progress => 50);
+ if ($self->csv->is_multiplexed) {
+ die "controller for multiplex data is not implemented yet";
+ }
+
$self->controller->errors([ $self->csv->errors ]) if $self->csv->errors;
return if ( !$self->csv->header || $self->csv->errors );
- my $headers = { headers => [ grep { $profile->{$_} } @{ $self->csv->header } ] };
+ my $headers = { headers => [ grep { $profile->{$_} } @{ $self->csv->header->[0] } ] };
$headers->{methods} = [ map { $profile->{$_} } @{ $headers->{headers} } ];
$headers->{used} = { map { ($_ => 1) } @{ $headers->{headers} } };
$self->controller->headers($headers);
use Text::CSV_XS;
use Rose::Object::MakeMethods::Generic scalar => [ qw(
file encoding sep_char quote_char escape_char header profile
- numberformat dateformat ignore_unknown_columns strict_profile _io _csv
- _objects _parsed _data _errors all_cvar_configs case_insensitive_header
+ 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;
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,
numberformat => 0,
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 $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) = @_;
- my $header = $self->header;
+ my $header;
- if (! $header) {
- $header = $self->_csv->getline($self->_io);
+ $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);
- $self->_push_error([
- $self->_csv->error_input,
- $self->_csv->error_diag,
- 0,
- ]) unless $header;
+ $self->_push_error([
+ $self->_csv->error_input,
+ $self->_csv->error_diag,
+ 0,
+ ]) unless $h;
+
+ push @{ $header }, $h;
+ }
}
# 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 && $header->[0] && $self->encoding =~ /utf-?8/i) {
- $header->[0] =~ s/^\x{FEFF}//;
+ if ($header) {
+ foreach my $h (@{ $header }) {
+ if ($h && $h->[0] && $self->encoding =~ /utf-?8/i) {
+ $h->[0] =~ s/^\x{FEFF}//;
+ }
+ }
}
- return unless $header;
+ # 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
my ($self, %params) = @_;
my (@data, @errors);
- $self->_csv->column_names(@{ $self->header });
-
while (1) {
my $row = $self->_csv->getline($self->_io);
if ($row) {
+ my $header = $self->_header_by_row($row);
+ $self->_csv->column_names(@{ $header });
my %hr;
- @hr{@{ $self->header }} = @$row;
+ @hr{@{ $header }} = @$row;
push @data, \%hr;
} else {
last if $self->_csv->eof;
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 . ')';
}
sep_char => ',', # default ';'
quote_char => '\'', # default '"'
escape_char => '"', # default '"'
- header => [qw(id text sellprice word)], # see later
- profile => { profile => { sellprice => 'sellprice_as_number'}, class => SL::DB::Part },
+ header => [ [qw(id text sellprice word)] ], # see later
+ profile => [ { profile => { sellprice => 'sellprice_as_number'},
+ class => 'SL::DB::Part' } ],
);
my $status = $csv->parse;
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
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.
-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.
+Examples:
-=item C<profile> {profile => \%ACCESSORS, class => class}
+ classic data of one type:
+ [ [ 'name', 'street', 'zipcode', 'city' ] ]
-This is a HASHREF to hash which may contain the keys C<profile> and C<class>.
+ multiplexed data with two different types
+ [ [ 'ordernumber', 'customer', 'transdate' ], [ 'partnumber', 'qty', 'sellprice' ] ]
+
+=item C<profile> [{profile => \%ACCESSORS, class => class, row_ident => ri},]
+
+This is an ARRAYREF to HASHREFs which may contain the keys C<profile>, C<class>
+and C<row_ident>.
The C<profile> is a HASHREF which may be used to map header fields to custom
accessors. Example:
- {profile => { listprice => listprice_as_number }}
+ [ {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 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:
- {profile => { customer => 'customer.name' }}
+ [ {profile => { customer => 'customer.name' }} ]
And will result in something like this:
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.
+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,
$csv = SL::Helper::Csv->new(
file => ...
- profile => {
+ profile => [ {
profile => [
makemodel => {
make_1 => make,
},
],
class => SL::DB::Part,
- }
+ } ]
);
=head1 AUTHOR
sub dispatch {
my ($self, $line) = @_;
- eval "require " . $self->_csv->profile->{class};
- my $obj = $self->_csv->profile->{class}->new;
+ my $class = $self->_class_by_line($line);
+ croak 'no class given' unless $class;
- for my $spec (@{ $self->_specs }) {
+ eval "require " . $class;
+ my $obj = $class->new;
+
+ my $specs = $self->_specs_by_line($line);
+ for my $spec (@{ $specs }) {
$self->apply($obj, $spec, $line->{$spec->{key}});
}
return $obj;
}
+# return class for given line
+# if only one profile is given, return this profiles class
+# if more than one profile is given, identify class by first
+# column???
+sub _class_by_line {
+ my ($self, $line) = @_;
+
+ my $class;
+ if ($self->_csv->is_multiplexed) {
+ foreach my $p (@{ $self->_csv->profile }) {
+ my $row_ident = $p->{row_ident};
+ if ($line->{datatype} eq $row_ident) {
+ $class = $p->{class};
+ last;
+ }
+ }
+ } else {
+ $class = @{ $self->_csv->profile }[0]->{class};
+ }
+
+ return $class;
+}
+
+sub _specs_by_line {
+ my ($self, $line) = @_;
+
+ my $spec;
+ my $i = 0;
+ if ($self->_csv->is_multiplexed) {
+ foreach my $p (@{ $self->_csv->profile }) {
+ my $row_ident = $p->{row_ident};
+ if ($line->{datatype} eq $row_ident) {
+ $spec = @{ $self->_specs }[$i];
+ last;
+ }
+ $i++;
+ }
+ } else {
+ $spec = @{ $self->_specs }[0];
+ }
+
+ return $spec;
+}
+
+
sub apply {
my ($self, $obj, $spec, $value) = @_;
return unless $value;
sub parse_profile {
my ($self, %params) = @_;
- my $header = $self->_csv->header;
- my $profile = $self->_csv->profile->{profile};
+ my $profile;
+ my $class;
+ my $header;
+ my @specs;
+
+ my $i = 0;
+ foreach my $h (@{ $self->_csv->header }) {
+ $header = $h;
+ if ($self->_csv->profile) {
+ $profile = @{ $self->_csv->profile }[$i]->{profile};
+ $class = @{ $self->_csv->profile }[$i]->{class};
+ }
+
+ my $spec = $self->_parse_profile(profile => $profile,
+ class => $class,
+ header => $header);
+ push @specs, $spec;
+ $i++;
+ }
+
+ $self->_specs(\@specs);
+
+ return ! $self->errors;
+}
+
+sub _parse_profile {
+ my ($self, %params) = @_;
+
+ my $profile = $params{profile};
+ my $class = $params{class};
+ my $header = $params{header};
+
my @specs;
for my $col (@$header) {
next unless $col;
if ($self->_csv->strict_profile) {
if (exists $profile->{$col}) {
- push @specs, $self->make_spec($col, $profile->{$col});
+ push @specs, $self->make_spec($col, $profile->{$col}, $class);
} else {
$self->unknown_column($col, undef);
}
} else {
if (exists $profile->{$col}) {
- push @specs, $self->make_spec($col, $profile->{$col});
+ push @specs, $self->make_spec($col, $profile->{$col}, $class);
} else {
- push @specs, $self->make_spec($col, $col);
+ push @specs, $self->make_spec($col, $col, $class);
}
}
}
- $self->_specs(\@specs);
$self->_csv->_push_error($self->errors);
- return ! $self->errors;
+
+ return \@specs;
}
sub make_spec {
- my ($self, $col, $path) = @_;
+ my ($self, $col, $path, $cur_class) = @_;
my $spec = { key => $col, steps => [] };
return unless $path;
- my $cur_class = $self->_csv->profile->{class};
-
return unless $cur_class;
for my $step_index ( split /\.(?!\d)/, $path ) {
-use Test::More tests => 47;
+use Test::More tests => 56;
use lib 't';
use utf8;
Support::TestSetup::login();
my $csv = SL::Helper::Csv->new(
- file => \"Kaffee\n",
- header => [ 'description' ],
- profile => { class => 'SL::DB::Part', },
+ file => \"Kaffee\n", # " # make emacs happy
+ header => [[ 'description' ]],
+ profile => [{ class => 'SL::DB::Part', }],
);
isa_ok $csv->_csv, 'Text::CSV_XS';
$csv = SL::Helper::Csv->new(
file => \"Kaffee;0.12;12,2;1,5234\n",
- header => [ 'description', 'sellprice', 'lastcost_as_number', 'listprice' ],
- profile => {profile => { listprice => 'listprice_as_number' },
- class => 'SL::DB::Part',},
+ header => [[ 'description', 'sellprice', 'lastcost_as_number', 'listprice' ]],
+ profile => [{profile => { listprice => 'listprice_as_number' },
+ class => 'SL::DB::Part',}],
);
$csv->parse;
EOL
sep_char => ',',
quote_char => "'",
- profile => {profile => { listprice => 'listprice_as_number' },
- class => 'SL::DB::Part',}
+ profile => [{profile => { listprice => 'listprice_as_number' },
+ class => 'SL::DB::Part',}]
);
$csv->parse;
is scalar @{ $csv->get_objects }, 1, 'auto header works';
;;description;sellprice;lastcost_as_number;
#####;Puppy;Kaffee;0.12;12,2;1,5234
EOL
- profile => {class => 'SL::DB::Part'},
+ profile => [{class => 'SL::DB::Part'}],
);
$csv->parse;
is scalar @{ $csv->get_objects }, 1, 'bozo header doesn\'t blow things up';
Kaffee;;0.12;12,2;1,5234
Beer;1123245;0.12;12,2;1,5234
EOL
- profile => {class => 'SL::DB::Part'},
+ profile => [{class => 'SL::DB::Part'}],
);
$csv->parse;
is scalar @{ $csv->get_objects }, 2, 'multiple objects work';
Beer;1123245;0.12;1.5234
EOL
numberformat => '1,000.00',
- profile => {class => 'SL::DB::Part'},
+ profile => [{class => 'SL::DB::Part'}],
);
$csv->parse;
is $csv->get_objects->[0]->lastcost, '1221.52', 'formatnumber';
Beer;1123245;0.12;1.5234
EOL
numberformat => '1,000.00',
- profile => {class => 'SL::DB::Part'},
+ profile => [{class => 'SL::DB::Part'}],
);
is $csv->parse, undef, 'broken csv header won\'t get parsed';
Beer;1123245;0.12;1.5234
EOL
numberformat => '1,000.00',
- profile => {class => 'SL::DB::Part'},
+ profile => [{class => 'SL::DB::Part'}],
);
is $csv->parse, undef, 'broken csv content won\'t get parsed';
is_deeply $csv->errors, [ '"Kaf"fee";;0.12;1,221.52'."\n", 2023, 'EIQ - QUO character not allowed', 5, 2 ], 'error';
EOL
numberformat => '1,000.00',
ignore_unknown_columns => 1,
- profile => {class => 'SL::DB::Part'},
+ profile => [{class => 'SL::DB::Part'}],
);
$csv->parse;
is $csv->get_objects->[0]->lastcost, '1221.52', 'ignore_unkown_columns works';
Beer;1123245;0.12;1.5234;16 %
EOL
numberformat => '1,000.00',
- profile => {
+ profile => [{
profile => {buchungsgruppe => "buchungsgruppen.description"},
class => 'SL::DB::Part',
- }
+ }]
);
$csv->parse;
isa_ok $csv->get_objects->[0]->buchungsgruppe, 'SL::DB::Buchungsgruppe', 'deep dispatch auto vivify works';
Beer;1123245;0.12;1.5234;
EOL
numberformat => '1,000.00',
- profile => {
+ profile => [{
profile => {
make_1 => "makemodels.0.make",
model_1 => "makemodels.0.model",
},
class => 'SL::DB::Part',
- },
+ }],
);
$csv->parse;
my @mm = $csv->get_objects->[0]->makemodel;
Kaffee;;0.12;1,221.52;213;Chair 0815;523;Table 15
EOL
numberformat => '1,000.00',
- profile => {
+ profile => [{
profile => {
make_1 => "makemodels.0.make",
model_1 => "makemodels.0.model",
model_2 => "makemodels.1.model",
},
class => 'SL::DB::Part',
- }
+ }]
);
$csv->parse;
description;partnumber;sellprice;lastcost_as_number;buchungsgruppe;
EOL
numberformat => '1,000.00',
- profile => {
+ profile => [{
profile => {buchungsgruppe => "buchungsgruppen.1.description"},
class => 'SL::DB::Part',
- }
+ }]
);
is $csv->parse, undef, 'wrong profile gets rejected';
is_deeply $csv->errors, [ 'buchungsgruppen.1.description', undef, "Profile path error. Indexed relationship is not OneToMany around here: 'buchungsgruppen.1'", undef ,0 ], 'error indicates wrong header';
numberformat => '1,000.00',
ignore_unknown_columns => 1,
strict_profile => 1,
- profile => {
+ profile => [{
profile => {lastcost => 'lastcost_as_number'},
class => 'SL::DB::Part',
- }
+ }]
);
$csv->parse;
is $csv->get_objects->[0]->lastcost, '1221.52', 'strict_profile with ignore';
EOL
numberformat => '1,000.00',
strict_profile => 1,
- profile => {
+ profile => [{
profile => {lastcost => 'lastcost_as_number'},
class => 'SL::DB::Part',
- }
+ }]
);
$csv->parse;
$csv = SL::Helper::Csv->new(
file => \"Kaffee",
- header => [ 'description' ],
- profile => {class => 'SL::DB::Part'},
+ header => [[ 'description' ]],
+ profile => [{class => 'SL::DB::Part'}],
);
$csv->parse;
is_deeply $csv->get_data, [ { description => 'Kaffee' } ], 'eol bug at the end of files';
$csv = SL::Helper::Csv->new(
file => \"\x{EF}\x{BB}\x{BF}description\nKaffee",
- profile => {class => 'SL::DB::Part'},
+ profile => [{class => 'SL::DB::Part'}],
encoding => 'utf8',
);
$csv->parse;
$csv = SL::Helper::Csv->new(
file => \"Kaffee",
header => [ 'Description' ],
- class => 'SL::DB::Part',
+ profile => [{class => 'SL::DB::Part'}],
);
$csv->parse;
is_deeply $csv->get_data, undef, 'case insensitive header without flag ignores';
is_deeply $csv->get_data, [ { description => 'Kaffee' } ], 'without profile and class works';
# vim: ft=perl
+# set emacs to perl mode
+# Local Variables:
+# mode: perl
+# End:
projects / kivitendo-erp.git / commitdiff