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