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