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