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