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