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