special_chars: ø, Ø und λ ergänzt
[kivitendo-erp.git] / SL / Helper / Csv.pm
1 package SL::Helper::Csv;
2
3 use strict;
4 use warnings;
5
6 use version 0.77;
7 use Carp;
8 use IO::File;
9 use Params::Validate qw(:all);
10 use List::MoreUtils qw(all pairwise firstidx);
11 use Text::CSV_XS;
12 use Rose::Object::MakeMethods::Generic scalar => [ qw(
13   file encoding sep_char quote_char escape_char header profile
14   numberformat dateformat ignore_unknown_columns strict_profile is_multiplexed
15   _row_header _io _csv _objects _parsed _data _errors all_cvar_configs case_insensitive_header
16   _multiplex_datatype_position
17 ) ];
18
19 use SL::Helper::Csv::Dispatcher;
20 use SL::Helper::Csv::Error;
21
22 # public interface
23
24 sub new {
25   my $class  = shift;
26   my %params = validate(@_, {
27     sep_char               => { default => ';' },
28     quote_char             => { default => '"' },
29     escape_char            => { default => '"' },
30     header                 => { type    => ARRAYREF, optional => 1 },
31     profile                => { type    => ARRAYREF, optional => 1 },
32     file                   => 1,
33     encoding               => 0,
34     numberformat           => 0,
35     dateformat             => 0,
36     ignore_unknown_columns => 0,
37     strict_profile         => 0,
38     case_insensitive_header => 0,
39   });
40   my $self = bless {}, $class;
41
42   $self->$_($params{$_}) for keys %params;
43
44   $self->_io(IO::File->new);
45   $self->_csv(Text::CSV_XS->new({
46     binary => 1,
47     sep_char    => $self->sep_char,
48     quote_char  => $self->quote_char,
49     escape_char => $self->escape_char,
50
51   }));
52   $self->_errors([]);
53
54   return $self;
55 }
56
57 sub parse {
58   my ($self, %params) = @_;
59
60   $self->_open_file;
61   return if ! $self->_check_multiplexed;
62   return if ! $self->_check_header;
63   return if ! $self->_check_multiplex_datatype_position;
64   return if ! $self->dispatcher->parse_profile;
65   return if ! $self->_parse_data;
66
67   $self->_parsed(1);
68   return $self;
69 }
70
71 sub get_data {
72   $_[0]->_data;
73 }
74
75 sub get_objects {
76   my ($self, %params) = @_;
77   croak 'must parse first' unless $self->_parsed;
78
79   $self->_make_objects unless $self->_objects;
80   return $self->_objects;
81 }
82
83 sub errors {
84   @{ $_[0]->_errors }
85 }
86
87 sub check_header {
88   $_[0]->_check_header;
89 }
90
91 # private stuff
92
93 sub _open_file {
94   my ($self, %params) = @_;
95
96   $self->encoding($self->_guess_encoding) if !$self->encoding;
97
98   $self->_io->open($self->file, '<' . $self->_encode_layer)
99     or die "could not open file " . $self->file;
100
101   return $self->_io;
102 }
103
104 # check, if data is multiplexed and if all nessesary infos are given
105 sub _check_multiplexed {
106   my ($self, %params) = @_;
107
108   $self->is_multiplexed(0);
109
110   # If more than one profile is given, it is multiplexed.
111   if ($self->profile) {
112     my @profile = @{ $self->profile };
113     if (scalar @profile > 1) {
114       # Each profile needs a class and a row_ident
115       my $info_ok = all { defined $_->{class} && defined $_->{row_ident} } @profile;
116       $self->_push_error([
117         0,
118         "missing class or row_ident in one of the profiles for multiplexed data",
119         0,
120         0]) unless $info_ok;
121
122       # If header is given, there needs to be a header for each profile
123       # and no empty headers.
124       if ($info_ok && $self->header) {
125         my @header = @{ $self->header };
126         my $t_ok = scalar @profile == scalar @header;
127         $self->_push_error([
128           0,
129           "number of headers and number of profiles must be the same for multiplexed data",
130           0,
131           0]) unless $t_ok;
132         $info_ok = $info_ok && $t_ok;
133
134         $t_ok = all { scalar @$_ > 0} @header;
135         $self->_push_error([
136           0,
137           "no empty headers are allowed for multiplexed data",
138           0,
139           0]) unless $t_ok;
140         $info_ok = $info_ok && $t_ok;
141       }
142       $self->is_multiplexed($info_ok);
143       return $info_ok;
144     }
145   }
146
147   # ok, if not multiplexed
148   return 1;
149 }
150
151 sub _check_header {
152   my ($self, %params) = @_;
153   my $header;
154
155   $header = $self->header;
156   if (!$header) {
157     my $n_header = ($self->is_multiplexed)? scalar @{ $self->profile } : 1;
158     foreach my $p_num (0..$n_header - 1) {
159       my $h = $self->_csv->getline($self->_io);
160
161       my ($code, $string, $position, $record, $field) = $self->_csv->error_diag;
162
163       $self->_push_error([
164         $self->_csv->error_input,
165         $code, $string, $position, $record // 0,
166       ]) unless $h;
167
168       if ($self->is_multiplexed) {
169         push @{ $header }, $h;
170       } else {
171         $header = $h;
172       }
173     }
174   }
175
176   # Special case: utf8 BOM.
177   # certain software (namely MS Office and notepad.exe insist on prefixing
178   # data with a discouraged but valid byte order mark
179   # if not removed, the first header field will not be recognized
180   if ($header) {
181     my $h = ($self->is_multiplexed)? $header->[0] : $header;
182
183     if ($h && $h->[0] && $self->encoding =~ /utf-?8/i) {
184       $h->[0] =~ s/^\x{FEFF}//;
185     }
186   }
187
188   # check, if all header fields are parsed well
189   if ($self->is_multiplexed) {
190     return unless $header && all { $_ } @$header;
191   } else {
192     return unless $header;
193   }
194
195   # Special case: human stupidity
196   # people insist that case sensitivity doesn't exist and try to enter all
197   # sorts of stuff. at this point we've got a profile (with keys that represent
198   # valid methods), and a header full of strings. if two of them match, the user
199   # most likely meant that field, so rewrite the header
200   if ($self->case_insensitive_header) {
201     die 'case_insensitive_header is only possible with profile' unless $self->profile;
202     if ($header) {
203       my $h_aref = ($self->is_multiplexed)? $header : [ $header ];
204       my $p_num  = 0;
205       foreach my $h (@{ $h_aref }) {
206         my %names = (
207           (map { $_ => $_                                     } keys %{ $self->profile->[$p_num]->{profile} || {} }),
208           (map { $_ => $self->profile->[$p_num]{mapping}{$_}  } keys %{ $self->profile->[$p_num]->{mapping} || {} }),
209         );
210         for my $name (keys %names) {
211           for my $i (0..$#$h) {
212             $h->[$i] = $names{$name} if lc $h->[$i] eq lc $name;
213           }
214         }
215         $p_num++;
216       }
217     }
218   }
219
220   return $self->header($header);
221 }
222
223 sub _check_multiplex_datatype_position {
224   my ($self) = @_;
225
226   return 1 if !$self->is_multiplexed; # ok if not multiplexed
227
228   my @positions = map { firstidx { 'datatype' eq lc($_) } @{ $_ } } @{ $self->header };
229   my $first_pos = $positions[0];
230   if (all { $first_pos == $_ } @positions) {
231     $self->_multiplex_datatype_position($first_pos);
232     return 1;
233   } else {
234     $self->_push_error([0,
235                         "datatype field must be at the same position for all datatypes for multiplexed data",
236                         0,
237                         0]);
238     return 0;
239   }
240 }
241
242 sub _is_empty_row {
243   return !!all { !$_ } @{$_[0]};
244 }
245
246 sub _parse_data {
247   my ($self, %params) = @_;
248   my (@data, @errors);
249
250   while (1) {
251     my $row = $self->_csv->getline($self->_io);
252     if ($row) {
253       next if _is_empty_row($row);
254       my $header = $self->_header_by_row($row);
255       if (!$header) {
256         push @errors, [
257           0,
258           "Cannot get header for row. Maybe row name and datatype field not matching.",
259           0,
260           0];
261         last;
262       }
263       my %hr;
264       @hr{@{ $header }} = @$row;
265       push @data, \%hr;
266     } else {
267       last if $self->_csv->eof;
268
269       # Text::CSV_XS 0.89 added record number to error_diag
270       my ($code, $string, $position, $record, $field) = $self->_csv->error_diag;
271
272       push @errors, [
273         $self->_csv->error_input,
274         $code, $string, $position,
275         $record // $self->_io->input_line_number,
276       ];
277     }
278     last if $self->_csv->eof;
279   }
280
281   $self->_data(\@data);
282   $self->_push_error(@errors);
283
284   return ! @errors;
285 }
286
287 sub _header_by_row {
288   my ($self, $row) = @_;
289
290   # initialize lookup hash if not already done
291   if ($self->is_multiplexed && ! defined $self->_row_header ) {
292     $self->_row_header({ pairwise { no warnings 'once'; $a->{row_ident} => $b } @{ $self->profile }, @{ $self->header } });
293   }
294
295   if ($self->is_multiplexed) {
296     return $self->_row_header->{$row->[$self->_multiplex_datatype_position]}
297   } else {
298     return $self->header;
299   }
300 }
301
302 sub _encode_layer {
303   ':encoding(' . $_[0]->encoding . ')';
304 }
305
306 sub _make_objects {
307   my ($self, %params) = @_;
308   my @objs;
309
310   local $::myconfig{numberformat} = $self->numberformat if $self->numberformat;
311   local $::myconfig{dateformat}   = $self->dateformat   if $self->dateformat;
312
313   for my $line (@{ $self->_data }) {
314     my $tmp_obj = $self->dispatcher->dispatch($line);
315     push @objs, $tmp_obj;
316   }
317
318   $self->_objects(\@objs);
319 }
320
321 sub dispatcher {
322   my ($self, %params) = @_;
323
324   $self->{_dispatcher} ||= $self->_make_dispatcher;
325 }
326
327 sub _make_dispatcher {
328   my ($self, %params) = @_;
329
330   die 'need a header to make a dispatcher' unless $self->header;
331
332   return SL::Helper::Csv::Dispatcher->new($self);
333 }
334
335 sub _guess_encoding {
336   # won't fix
337   'utf-8';
338 }
339
340 sub _push_error {
341   my ($self, @errors) = @_;
342   my @new_errors = ($self->errors, map { SL::Helper::Csv::Error->new(@$_) } @errors);
343   $self->_errors(\@new_errors);
344 }
345
346 sub specs {
347   $_[0]->dispatcher->_specs
348 }
349
350 1;
351
352 __END__
353
354 =encoding utf-8
355
356 =head1 NAME
357
358 SL::Helper::Csv - take care of csv file uploads
359
360 =head1 SYNOPSIS
361
362   use SL::Helper::Csv;
363
364   my $csv = SL::Helper::Csv->new(
365     file        => \$::form->{upload_file},
366     encoding    => 'utf-8', # undef means utf8
367     sep_char    => ',',     # default ';'
368     quote_char  => '\'',    # default '"'
369     escape_char => '"',     # default '"'
370     header      => [ qw(id text sellprice word) ], # see later
371     profile     => [ { profile => { sellprice => 'sellprice_as_number'},
372                        class   => 'SL::DB::Part' } ],
373   );
374
375   my $status  = $csv->parse;
376   my $hrefs   = $csv->get_data;
377   my $objects = $csv->get_objects;
378
379   my @errors  = $csv->errors;
380
381 =head1 DESCRIPTION
382
383 See Synopsis.
384
385 Text::CSV already offers good functions to get lines out of a csv file, but in
386 most cases you will want those lines to be parsed into hashes or even objects,
387 so this model just skips ahead and gives you objects.
388
389 Its basic assumptions are:
390
391 =over 4
392
393 =item You do know what you expect to be in that csv file.
394
395 This means first and foremost that you have knowledge about encoding, number and
396 date format, csv parameters such as quoting and separation characters. You also
397 know what content will be in that csv and what L<Rose::DB> is responsible for
398 it. You provide valid header columns and their mapping to the objects.
399
400 =item You do NOT know if the csv provider yields to your expectations.
401
402 Stuff that does not work with what you expect should not crash anything, but
403 give you a hint what went wrong. As a result, if you remember to check for
404 errors after each step, you should be fine.
405
406 =item Data does not make sense. It's just data.
407
408 Almost all data imports have some type of constraints. Some data needs to be
409 unique, other data needs to be connected to existing data sets. This will not
410 happen here. You will receive a plain mapping of the data into the class tree,
411 nothing more.
412
413 =item Multiplex data
414
415 This module can handle multiplexed data of different class types. In that case
416 multiple profiles with classes and row identifiers must be given. Multiple
417 headers may also be given or read from csv data. Data must contain the row
418 identifier in the column named 'datatype'.
419
420 =back
421
422 =head1 METHODS
423
424 =over 4
425
426 =item C<new> PARAMS
427
428 Standard constructor. You can use this to set most of the data.
429
430 =item C<parse>
431
432 Do the actual work. Will return true ($self actually) if success, undef if not.
433
434 =item C<get_objects>
435
436 Parse the data into objects and return those.
437
438 This method will return an arrayref of all objects.
439
440 =item C<get_data>
441
442 Returns an arrayref of the raw lines as hashrefs.
443
444 =item C<errors>
445
446 Return all errors that came up during parsing. See error handling for detailed
447 information.
448
449 =back
450
451 =head1 PARAMS
452
453 =over 4
454
455 =item C<file>
456
457 The file which contents are to be read. Can be a name of a physical file or a
458 scalar ref for memory data.
459
460 =item C<encoding>
461
462 Encoding of the CSV file. Note that this module does not do any encoding
463 guessing. Know what your data is. Defaults to utf-8.
464
465 =item C<sep_char>
466
467 =item C<quote_char>
468
469 =item C<escape_char>
470
471 Same as in L<Text::CSV>
472
473 =item C<header> \@HEADERS
474
475 If given, it contains an ARRAY of the header fields for not multiplexed data.
476 Or an ARRAYREF for each different class type for multiplexed data. These
477 ARRAYREFS are the header fields which are an array of columns. In this case
478 the first lines are not used as a header. Empty header fields will be ignored
479 in objects.
480
481 If not given, headers are taken from the first n lines of data, where n is the
482 number of different class types.
483
484 In case of multiplexed data there must be a column named 'datatype'. This
485 column must be given in each header and must be at the same position in each
486 header.
487
488 Examples:
489
490   classic data of one type:
491   [ 'name', 'street', 'zipcode', 'city' ]
492
493   multiplexed data with two different types:
494   [ [ 'datatype', 'ordernumber', 'customer', 'transdate' ],
495     [ 'datatype', 'partnumber', 'qty', 'sellprice' ] ]
496
497 =item C<profile> PROFILE_DATA
498
499 The profile mapping csv to the objects.
500
501 See section L</PROFILE> for information on this topic.
502
503 =item C<ignore_unknown_columns>
504
505 If set, the import will ignore unknown header columns. Useful for lazy imports,
506 but deactivated by default.
507
508 =item C<case_insensitive_header>
509
510 If set, header columns will be matched against profile entries case
511 insensitive, and on match the profile name will be taken.
512
513 Only works if a profile is given, will die otherwise.
514
515 If both C<case_insensitive_header> and C<strict_profile> is set, matched header
516 columns will be accepted.
517
518 =item C<strict_profile>
519
520 If set, all columns to be parsed must be specified in C<profile>. Every header
521 field not listed there will be treated like an unknown column.
522
523 If both C<case_insensitive_header> and C<strict_profile> is set, matched header
524 columns will be accepted.
525
526 =back
527
528 =head1 PROFILE
529
530 The profile is needed for mapping csv data to the accessors in the data object.
531
532 The basic structure is:
533
534   PROFILE       := [ CLASS_PROFILE, CLASS_PROFILE* ]
535   CLASS_PROFILE := {
536                       profile   => { ACCESSORS+ },
537                       class     => $classname,
538                       row_ident => $row_ident,
539                       mapping   => { MAPPINGS* },
540                    }
541   ACCESSORS     := $field => $accessor
542   MAPPINGS      := $alias => $field
543
544 The C<ACCESSORS> may be used to map header fields to custom
545 accessors. Example:
546
547   profile => {
548     listprice => 'listprice_as_number',
549   }
550
551 In this case C<listprice_as_number> will be used to store the values from the
552 C<listprice> column.
553
554 In case of a One-To-One relationship these can also be set over
555 relationships by separating the steps with a dot (C<.>). This will work:
556
557   customer => 'customer.name',
558
559 And will result in something like this:
560
561   $obj->customer($obj->meta->relationship('customer')->class->new);
562   $obj->customer->name($csv_line->{customer})
563
564 Beware, this will not try to look up anything in the database! You will
565 simply receive objects that represent what the profile defined. If some of
566 these information are unique, or should be connected to preexisting data, you
567 will have to do that for yourself. Since you provided the profile, it is
568 assumed you know what to do in this case.
569
570 If no profile is given, any header field found will be taken as is.
571
572 If the path in a profile entry is empty, the field will be subjected to
573 C<strict_profile> and C<case_insensitive_header> checking and will be parsed
574 into C<get_data>, but will not be attempted to be dispatched into objects.
575
576 C<class> must be present. A new instance will be created for each line before
577 dispatching into it.
578
579 C<row_ident> is used to determine the correct profile in multiplexed data and
580 must be given there. It's not used in non-multiplexed data.
581
582 If C<mappings> is present, it must contain a hashref that maps strings to known
583 fields. This can be used to add custom profiles for known sources, that don't
584 comply with the expected header identities.
585
586 Without strict profiles, mappings can also directly map header fields that
587 should end up in the same accessor.
588
589 With case insensitive headings, mappings will also modify the headers, to fit
590 the expected profile.
591
592 Mappings can be identical to known fields and will be prefered during lookup,
593 but will not replace the field, meaning that:
594
595   profile => {
596     name        => 'name',
597     description => 'description',
598   }
599   mapping => {
600     name        => 'description',
601     shortname   => 'name',
602   }
603
604 will work as expected, and shortname will not end up in description. This also
605 works with the case insensitive option. Note however that the case insensitive
606 option will not enable true unicode collating.
607
608
609 Here's a full example:
610
611   [
612     {
613       class     => 'SL::DB::Order',
614       row_ident => 'O'
615     },
616     {
617       class     => 'SL::DB::OrderItem',
618       row_ident => 'I',
619       profile   => { sellprice => 'sellprice_as_number' },
620       mapping   => { 'Verkaufspreis' => 'sellprice' }
621     },
622   ]
623
624 =head1 ERROR HANDLING
625
626 After parsing a file all errors will be accumulated into C<errors>.
627 Each entry is an object with the following attributes:
628
629  raw_input:  offending raw input,
630  code:   Text::CSV error code if Text:CSV signalled an error, 0 else,
631  diag:   error diagnostics,
632  line:   position in line,
633  col:    estimated line in file,
634
635 Note that the last entry can be off, but will give an estimate.
636
637 Error handling is also known to break on new Perl versions and need to be
638 adjusted from time to time due to changes in Text::CSV_XS.
639
640 =head1 CAVEATS
641
642 =over 4
643
644 =item *
645
646 sep_char, quote_char, and escape_char are passed to Text::CSV on creation.
647 Changing them later has no effect currently.
648
649 =item *
650
651 Encoding errors are not dealt with properly.
652
653 =back
654
655 =head1 TODO
656
657 Dispatch to child objects, like this:
658
659  $csv = SL::Helper::Csv->new(
660    file    => ...
661    profile => [ {
662      profile => [
663        makemodel => {
664          make_1  => make,
665          model_1 => model,
666        },
667        makemodel => {
668          make_2  => make,
669          model_2 => model,
670        },
671      ],
672      class   => SL::DB::Part,
673    } ]
674  );
675
676 =head1 AUTHOR
677
678 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
679
680 =cut