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