Sonderbehandlung im template
[kivitendo-erp.git] / SL / Helper / Csv.pm
1 package SL::Helper::Csv;
2
3 use strict;
4 use warnings;
5
6 use Carp;
7 use IO::File;
8 use Params::Validate qw(:all);
9 use Text::CSV_XS;
10 use Rose::Object::MakeMethods::Generic scalar => [ qw(
11   file encoding sep_char quote_char escape_char header profile class
12   numberformat dateformat ignore_unknown_columns strict_profile _io _csv
13   _objects _parsed _data _errors all_cvar_configs case_insensitive_header
14 ) ];
15
16 use SL::Helper::Csv::Dispatcher;
17 use SL::Helper::Csv::Error;
18
19 # public interface
20
21 sub new {
22   my $class  = shift;
23   my %params = validate(@_, {
24     sep_char               => { default => ';' },
25     quote_char             => { default => '"' },
26     escape_char            => { default => '"' },
27     header                 => { type    => ARRAYREF, optional => 1 },
28     profile                => { type    => HASHREF,  optional => 1 },
29     file                   => 1,
30     encoding               => 0,
31     class                  => 0,
32     numberformat           => 0,
33     dateformat             => 0,
34     ignore_unknown_columns => 0,
35     strict_profile         => 0,
36     case_insensitive_header => 0,
37   });
38   my $self = bless {}, $class;
39
40   $self->$_($params{$_}) for keys %params;
41
42   $self->_io(IO::File->new);
43   $self->_csv(Text::CSV_XS->new({
44     binary => 1,
45     sep_char    => $self->sep_char,
46     quote_char  => $self->quote_char,
47     escape_char => $self->escape_char,
48
49   }));
50   $self->_errors([]);
51
52   return $self;
53 }
54
55 sub parse {
56   my ($self, %params) = @_;
57
58   $self->_open_file;
59   return if ! $self->_check_header;
60   return if ! $self->dispatcher->parse_profile;
61   return if ! $self->_parse_data;
62
63   $self->_parsed(1);
64   return $self;
65 }
66
67 sub get_data {
68   $_[0]->_data;
69 }
70
71 sub get_objects {
72   my ($self, %params) = @_;
73   croak 'no class given'   unless $self->class;
74   croak 'must parse first' unless $self->_parsed;
75
76   $self->_make_objects unless $self->_objects;
77   return wantarray ? @{ $self->_objects } : $self->_objects;
78 }
79
80 sub errors {
81   @{ $_[0]->_errors }
82 }
83
84 sub check_header {
85   $_[0]->_check_header;
86 }
87
88 # private stuff
89
90 sub _open_file {
91   my ($self, %params) = @_;
92
93   $self->encoding($self->_guess_encoding) if !$self->encoding;
94
95   $self->_io->open($self->file, '<' . $self->_encode_layer)
96     or die "could not open file " . $self->file;
97
98   return $self->_io;
99 }
100
101 sub _check_header {
102   my ($self, %params) = @_;
103   my $header = $self->header;
104
105   if (! $header) {
106     $header = $self->_csv->getline($self->_io);
107
108     $self->_push_error([
109       $self->_csv->error_input,
110       $self->_csv->error_diag,
111       0,
112     ]) unless $header;
113   }
114
115   # Special case: utf8 BOM.
116   # certain software (namely MS Office and notepad.exe insist on prefixing
117   # data with a discouraged but valid byte order mark
118   # if not removed, the first header field will not be recognized
119   if ($header && $header->[0] && $self->encoding =~ /utf-?8/i) {
120     $header->[0] =~ s/^\x{FEFF}//;
121   }
122
123   return unless $header;
124
125   # Special case: human stupidity
126   # people insist that case sensitivity doesn't exist and try to enter all
127   # sorts of stuff. at this point we've got a profile (with keys that represent
128   # valid methods), and a header full of strings. if two of them match, the user
129   # mopst likely meant that field, so rewrite the header
130   if ($self->case_insensitive_header) {
131     die 'case_insensitive_header is only possible with profile' unless $self->profile;
132     my @names = (
133       keys %{ $self->profile || {} },
134     );
135     for my $name (@names) {
136       for my $i (0..$#$header) {
137         $header->[$i] = $name if lc $header->[$i] eq lc $name;
138       }
139     }
140   }
141
142   return $self->header($header);
143 }
144
145 sub _parse_data {
146   my ($self, %params) = @_;
147   my (@data, @errors);
148
149   $self->_csv->column_names(@{ $self->header });
150
151   while (1) {
152     my $row = $self->_csv->getline($self->_io);
153     if ($row) {
154       my %hr;
155       @hr{@{ $self->header }} = @$row;
156       push @data, \%hr;
157     } else {
158       last if $self->_csv->eof;
159       push @errors, [
160         $self->_csv->error_input,
161         $self->_csv->error_diag,
162         $self->_io->input_line_number,
163       ];
164     }
165     last if $self->_csv->eof;
166   }
167
168   $self->_data(\@data);
169   $self->_push_error(@errors);
170
171   return ! @errors;
172 }
173
174 sub _encode_layer {
175   ':encoding(' . $_[0]->encoding . ')';
176 }
177
178 sub _make_objects {
179   my ($self, %params) = @_;
180   my @objs;
181
182   eval "require " . $self->class;
183   local $::myconfig{numberformat} = $self->numberformat if $self->numberformat;
184   local $::myconfig{dateformat}   = $self->dateformat   if $self->dateformat;
185
186   for my $line (@{ $self->_data }) {
187     my $tmp_obj = $self->class->new;
188     $self->dispatcher->dispatch($tmp_obj, $line);
189     push @objs, $tmp_obj;
190   }
191
192   $self->_objects(\@objs);
193 }
194
195 sub dispatcher {
196   my ($self, %params) = @_;
197
198   $self->{_dispatcher} ||= $self->_make_dispatcher;
199 }
200
201 sub _make_dispatcher {
202   my ($self, %params) = @_;
203
204   die 'need a header to make a dispatcher' unless $self->header;
205
206   return SL::Helper::Csv::Dispatcher->new($self);
207 }
208
209 sub _guess_encoding {
210   # won't fix
211   'utf-8';
212 }
213
214 sub _push_error {
215   my ($self, @errors) = @_;
216   my @new_errors = ($self->errors, map { SL::Helper::Csv::Error->new(@$_) } @errors);
217   $self->_errors(\@new_errors);
218 }
219
220
221 1;
222
223 __END__
224
225 =encoding utf-8
226
227 =head1 NAME
228
229 SL::Helper::Csv - take care of csv file uploads
230
231 =head1 SYNOPSIS
232
233   use SL::Helper::Csv;
234
235   my $csv = SL::Helper::Csv->new(
236     file        => \$::form->{upload_file},
237     encoding    => 'utf-8', # undef means utf8
238     sep_char    => ',',     # default ';'
239     quote_char  => '\'',    # default '"'
240     escape_char => '"',     # default '"'
241     header      => [qw(id text sellprice word)], # see later
242     profile     => { sellprice => 'sellprice_as_number' },
243     class       => 'SL::DB::CsvLine',   # if present, map lines to this
244   );
245
246   my $status  = $csv->parse;
247   my $hrefs   = $csv->get_data;
248   my @objects = $csv->get_objects;
249
250   my @errors  = $csv->errors;
251
252 =head1 DESCRIPTION
253
254 See Synopsis.
255
256 Text::CSV offeres already good functions to get lines out of a csv file, but in
257 most cases you will want those line to be parsed into hashes or even objects,
258 so this model just skips ahead and gives you objects.
259
260 Its basic assumptions are:
261
262 =over 4
263
264 =item You do know what you expect to be in that csv file.
265
266 This means first and foremost you have knowledge about encoding, number and
267 date format, csv parameters such as quoting and separation characters. You also
268 know what content will be in that csv and what L<Rose::DB> is responsible for
269 it. You provide valid header columns and their mapping to the objects.
270
271 =item You do NOT know if the csv provider yields to your expectations.
272
273 Stuff that does not work with what you expect should not crash anything, but
274 give you a hint what went wrong. As a result, if you remeber to check for
275 errors after each step, you should be fine.
276
277 =item Data does not make sense. It's just data.
278
279 Almost all data imports have some type of constraints. Some data needs to be
280 unique, other data needs to be connected to existing data sets. This will not
281 happen here. You will receive a plain mapping of the data into the class tree,
282 nothing more.
283
284 =back
285
286 =head1 METHODS
287
288 =over 4
289
290 =item C<new> PARAMS
291
292 Standard constructor. You can use this to set most of the data.
293
294 =item C<parse>
295
296 Do the actual work. Will return true ($self actually) if success, undef if not.
297
298 =item C<get_objects>
299
300 Parse the data into objects and return those.
301
302 This method will return list or arrayref depending on context.
303
304 =item C<get_data>
305
306 Returns an arrayref of the raw lines as hashrefs.
307
308 =item C<errors>
309
310 Return all errors that came up during parsing. See error handling for detailed
311 information.
312
313 =back
314
315 =head1 PARAMS
316
317 =over 4
318
319 =item C<file>
320
321 The file which contents are to be read. Can be a name of a physical file or a
322 scalar ref for memory data.
323
324 =item C<encoding>
325
326 Encoding of the CSV file. Note that this module does not do any encoding
327 guessing. Know what your data is. Defaults to utf-8.
328
329 =item C<sep_char>
330
331 =item C<quote_char>
332
333 =item C<escape_char>
334
335 Same as in L<Text::CSV>
336
337 =item C<header> \@FIELDS
338
339 Can be an array of columns, in this case the first line is not used as a
340 header. Empty header fields will be ignored in objects.
341
342 =item C<profile> \%ACCESSORS
343
344 May be used to map header fields to custom accessors. Example:
345
346   { listprice => listprice_as_number }
347
348 In this case C<listprice_as_number> will be used to read in values from the
349 C<listprice> column.
350
351 In case of a One-To-One relationsship these can also be set over
352 relationsships by sparating the steps with a dot (C<.>). This will work:
353
354   { customer => 'customer.name' }
355
356 And will result in something like this:
357
358   $obj->customer($obj->meta->relationship('customer')->class->new);
359   $obj->customer->name($csv_line->{customer})
360
361 But beware, this will not try to look up anything in the database. You will
362 simply receive objects that represent what the profile defined. If some of
363 these information are unique, and should be connected to preexisting data, you
364 will have to do that for yourself. Since you provided the profile, it is
365 assumed you know what to do in this case.
366
367 If no profile is given, any header field found will be taken as is.
368
369 If the path in a profile entry is empty, the field will be subjected to
370 C<strict_profile> and C<case_insensitive_header> checking, will be parsed into
371 C<get_data>, but will not be attempted to be dispatched into objects.
372
373 =item C<class>
374
375 If present, the line will be handed to the new sub of this class,
376 and the return value used instead of the line itself.
377
378 =item C<ignore_unknown_columns>
379
380 If set, the import will ignore unkown header columns. Useful for lazy imports,
381 but deactivated by default.
382
383 =item C<case_insensitive_header>
384
385 If set, header columns will be matched against profile entries case
386 insensitive, and on match the profile name will be taken.
387
388 Only works if a profile is given, will die otherwise.
389
390 If both C<case_insensitive_header> and C<strict_profile> is set, matched header
391 columns will be accepted.
392
393 =item C<strict_profile>
394
395 If set, all columns to be parsed must be specified in C<profile>. Every header
396 field not listed there will be treated like an unknown column.
397
398 If both C<case_insensitive_header> and C<strict_profile> is set, matched header
399 columns will be accepted.
400
401 =back
402
403 =head1 ERROR HANDLING
404
405 After parsing a file all errors will be accumulated into C<errors>.
406 Each entry is an object with the following attributes:
407
408  raw_input:  offending raw input,
409  code:   Text::CSV error code if Text:CSV signalled an error, 0 else,
410  diag:   error diagnostics,
411  line:   position in line,
412  col:    estimated line in file,
413
414 Note that the last entry can be off, but will give an estimate.
415
416 =head1 CAVEATS
417
418 =over 4
419
420 =item *
421
422 sep_char, quote_char, and escape_char are passed to Text::CSV on creation.
423 Changing them later has no effect currently.
424
425 =item *
426
427 Encoding errors are not dealt with properly.
428
429 =back
430
431 =head1 TODO
432
433 Dispatch to child objects, like this:
434
435  $csv = SL::Helper::Csv->new(
436    file  => ...
437    class => SL::DB::Part,
438    profile => [
439      makemodel => {
440        make_1  => make,
441        model_1 => model,
442      },
443      makemodel => {
444        make_2  => make,
445        model_2 => model,
446      },
447    ]
448  );
449
450 =head1 AUTHOR
451
452 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
453
454 =cut