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 Text::CSV_XS;
  11 use Rose::Object::MakeMethods::Generic scalar => [ qw(
  12   file encoding sep_char quote_char escape_char header profile class
  13   numberformat dateformat ignore_unknown_columns strict_profile _io _csv
  14   _objects _parsed _data _errors all_cvar_configs case_insensitive_header
  15 ) ];
  16
  17 use SL::Helper::Csv::Dispatcher;
  18 use SL::Helper::Csv::Error;
  19
  20 # public interface
  21
  22 sub new {
  23   my $class  = shift;
  24   my %params = validate(@_, {
  25     sep_char               => { default => ';' },
  26     quote_char             => { default => '"' },
  27     escape_char            => { default => '"' },
  28     header                 => { type    => ARRAYREF, optional => 1 },
  29     profile                => { type    => HASHREF,  optional => 1 },
  30     file                   => 1,
  31     encoding               => 0,
  32     class                  => 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_header;
  61   return if ! $self->dispatcher->parse_profile;
  62   return if ! $self->_parse_data;
  63
  64   $self->_parsed(1);
  65   return $self;
  66 }
  67
  68 sub get_data {
  69   $_[0]->_data;
  70 }
  71
  72 sub get_objects {
  73   my ($self, %params) = @_;
  74   croak 'no class given'   unless $self->class;
  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 sub _check_header {
 103   my ($self, %params) = @_;
 104   my $header = $self->header;
 105
 106   if (! $header) {
 107     $header = $self->_csv->getline($self->_io);
 108
 109     $self->_push_error([
 110       $self->_csv->error_input,
 111       $self->_csv->error_diag,
 112       0,
 113     ]) unless $header;
 114   }
 115
 116   # Special case: utf8 BOM.
 117   # certain software (namely MS Office and notepad.exe insist on prefixing
 118   # data with a discouraged but valid byte order mark
 119   # if not removed, the first header field will not be recognized
 120   if ($header && $header->[0] && $self->encoding =~ /utf-?8/i) {
 121     $header->[0] =~ s/^\x{FEFF}//;
 122   }
 123
 124   return unless $header;
 125
 126   # Special case: human stupidity
 127   # people insist that case sensitivity doesn't exist and try to enter all
 128   # sorts of stuff. at this point we've got a profile (with keys that represent
 129   # valid methods), and a header full of strings. if two of them match, the user
 130   # mopst likely meant that field, so rewrite the header
 131   if ($self->case_insensitive_header) {
 132     die 'case_insensitive_header is only possible with profile' unless $self->profile;
 133     my @names = (
 134       keys %{ $self->profile || {} },
 135     );
 136     for my $name (@names) {
 137       for my $i (0..$#$header) {
 138         $header->[$i] = $name if lc $header->[$i] eq lc $name;
 139       }
 140     }
 141   }
 142
 143   return $self->header($header);
 144 }
 145
 146 sub _parse_data {
 147   my ($self, %params) = @_;
 148   my (@data, @errors);
 149
 150   $self->_csv->column_names(@{ $self->header });
 151
 152   while (1) {
 153     my $row = $self->_csv->getline($self->_io);
 154     if ($row) {
 155       my %hr;
 156       @hr{@{ $self->header }} = @$row;
 157       push @data, \%hr;
 158     } else {
 159       last if $self->_csv->eof;
 160       # Text::CSV_XS 0.89 added record number to error_diag
 161       if (qv(Text::CSV_XS->VERSION) >= qv('0.89')) {
 162         push @errors, [
 163           $self->_csv->error_input,
 164           $self->_csv->error_diag,
 165         ];
 166       } else {
 167         push @errors, [
 168           $self->_csv->error_input,
 169           $self->_csv->error_diag,
 170           $self->_io->input_line_number,
 171         ];
 172       }
 173     }
 174     last if $self->_csv->eof;
 175   }
 176
 177   $self->_data(\@data);
 178   $self->_push_error(@errors);
 179
 180   return ! @errors;
 181 }
 182
 183 sub _encode_layer {
 184   ':encoding(' . $_[0]->encoding . ')';
 185 }
 186
 187 sub _make_objects {
 188   my ($self, %params) = @_;
 189   my @objs;
 190
 191   eval "require " . $self->class;
 192   local $::myconfig{numberformat} = $self->numberformat if $self->numberformat;
 193   local $::myconfig{dateformat}   = $self->dateformat   if $self->dateformat;
 194
 195   for my $line (@{ $self->_data }) {
 196     my $tmp_obj = $self->class->new;
 197     $self->dispatcher->dispatch($tmp_obj, $line);
 198     push @objs, $tmp_obj;
 199   }
 200
 201   $self->_objects(\@objs);
 202 }
 203
 204 sub dispatcher {
 205   my ($self, %params) = @_;
 206
 207   $self->{_dispatcher} ||= $self->_make_dispatcher;
 208 }
 209
 210 sub _make_dispatcher {
 211   my ($self, %params) = @_;
 212
 213   die 'need a header to make a dispatcher' unless $self->header;
 214
 215   return SL::Helper::Csv::Dispatcher->new($self);
 216 }
 217
 218 sub _guess_encoding {
 219   # won't fix
 220   'utf-8';
 221 }
 222
 223 sub _push_error {
 224   my ($self, @errors) = @_;
 225   my @new_errors = ($self->errors, map { SL::Helper::Csv::Error->new(@$_) } @errors);
 226   $self->_errors(\@new_errors);
 227 }
 228
 229
 230 1;
 231
 232 __END__
 233
 234 =encoding utf-8
 235
 236 =head1 NAME
 237
 238 SL::Helper::Csv - take care of csv file uploads
 239
 240 =head1 SYNOPSIS
 241
 242   use SL::Helper::Csv;
 243
 244   my $csv = SL::Helper::Csv->new(
 245     file        => \$::form->{upload_file},
 246     encoding    => 'utf-8', # undef means utf8
 247     sep_char    => ',',     # default ';'
 248     quote_char  => '\'',    # default '"'
 249     escape_char => '"',     # default '"'
 250     header      => [qw(id text sellprice word)], # see later
 251     profile     => { sellprice => 'sellprice_as_number' },
 252     class       => 'SL::DB::CsvLine',   # if present, map lines to this
 253   );
 254
 255   my $status  = $csv->parse;
 256   my $hrefs   = $csv->get_data;
 257   my @objects = $csv->get_objects;
 258
 259   my @errors  = $csv->errors;
 260
 261 =head1 DESCRIPTION
 262
 263 See Synopsis.
 264
 265 Text::CSV offeres already good functions to get lines out of a csv file, but in
 266 most cases you will want those line to be parsed into hashes or even objects,
 267 so this model just skips ahead and gives you objects.
 268
 269 Its basic assumptions are:
 270
 271 =over 4
 272
 273 =item You do know what you expect to be in that csv file.
 274
 275 This means first and foremost you have knowledge about encoding, number and
 276 date format, csv parameters such as quoting and separation characters. You also
 277 know what content will be in that csv and what L<Rose::DB> is responsible for
 278 it. You provide valid header columns and their mapping to the objects.
 279
 280 =item You do NOT know if the csv provider yields to your expectations.
 281
 282 Stuff that does not work with what you expect should not crash anything, but
 283 give you a hint what went wrong. As a result, if you remember to check for
 284 errors after each step, you should be fine.
 285
 286 =item Data does not make sense. It's just data.
 287
 288 Almost all data imports have some type of constraints. Some data needs to be
 289 unique, other data needs to be connected to existing data sets. This will not
 290 happen here. You will receive a plain mapping of the data into the class tree,
 291 nothing more.
 292
 293 =back
 294
 295 =head1 METHODS
 296
 297 =over 4
 298
 299 =item C<new> PARAMS
 300
 301 Standard constructor. You can use this to set most of the data.
 302
 303 =item C<parse>
 304
 305 Do the actual work. Will return true ($self actually) if success, undef if not.
 306
 307 =item C<get_objects>
 308
 309 Parse the data into objects and return those.
 310
 311 This method will return list or arrayref depending on context.
 312
 313 =item C<get_data>
 314
 315 Returns an arrayref of the raw lines as hashrefs.
 316
 317 =item C<errors>
 318
 319 Return all errors that came up during parsing. See error handling for detailed
 320 information.
 321
 322 =back
 323
 324 =head1 PARAMS
 325
 326 =over 4
 327
 328 =item C<file>
 329
 330 The file which contents are to be read. Can be a name of a physical file or a
 331 scalar ref for memory data.
 332
 333 =item C<encoding>
 334
 335 Encoding of the CSV file. Note that this module does not do any encoding
 336 guessing. Know what your data is. Defaults to utf-8.
 337
 338 =item C<sep_char>
 339
 340 =item C<quote_char>
 341
 342 =item C<escape_char>
 343
 344 Same as in L<Text::CSV>
 345
 346 =item C<header> \@FIELDS
 347
 348 Can be an array of columns, in this case the first line is not used as a
 349 header. Empty header fields will be ignored in objects.
 350
 351 =item C<profile> \%ACCESSORS
 352
 353 May be used to map header fields to custom accessors. Example:
 354
 355   { listprice => listprice_as_number }
 356
 357 In this case C<listprice_as_number> will be used to read in values from the
 358 C<listprice> column.
 359
 360 In case of a One-To-One relationsship these can also be set over
 361 relationsships by sparating the steps with a dot (C<.>). This will work:
 362
 363   { customer => 'customer.name' }
 364
 365 And will result in something like this:
 366
 367   $obj->customer($obj->meta->relationship('customer')->class->new);
 368   $obj->customer->name($csv_line->{customer})
 369
 370 But beware, this will not try to look up anything in the database. You will
 371 simply receive objects that represent what the profile defined. If some of
 372 these information are unique, and should be connected to preexisting data, you
 373 will have to do that for yourself. Since you provided the profile, it is
 374 assumed you know what to do in this case.
 375
 376 If no profile is given, any header field found will be taken as is.
 377
 378 If the path in a profile entry is empty, the field will be subjected to
 379 C<strict_profile> and C<case_insensitive_header> checking, will be parsed into
 380 C<get_data>, but will not be attempted to be dispatched into objects.
 381
 382 =item C<class>
 383
 384 If present, the line will be handed to the new sub of this class,
 385 and the return value used instead of the line itself.
 386
 387 =item C<ignore_unknown_columns>
 388
 389 If set, the import will ignore unkown header columns. Useful for lazy imports,
 390 but deactivated by default.
 391
 392 =item C<case_insensitive_header>
 393
 394 If set, header columns will be matched against profile entries case
 395 insensitive, and on match the profile name will be taken.
 396
 397 Only works if a profile is given, will die otherwise.
 398
 399 If both C<case_insensitive_header> and C<strict_profile> is set, matched header
 400 columns will be accepted.
 401
 402 =item C<strict_profile>
 403
 404 If set, all columns to be parsed must be specified in C<profile>. Every header
 405 field not listed there will be treated like an unknown column.
 406
 407 If both C<case_insensitive_header> and C<strict_profile> is set, matched header
 408 columns will be accepted.
 409
 410 =back
 411
 412 =head1 ERROR HANDLING
 413
 414 After parsing a file all errors will be accumulated into C<errors>.
 415 Each entry is an object with the following attributes:
 416
 417  raw_input:  offending raw input,
 418  code:   Text::CSV error code if Text:CSV signalled an error, 0 else,
 419  diag:   error diagnostics,
 420  line:   position in line,
 421  col:    estimated line in file,
 422
 423 Note that the last entry can be off, but will give an estimate.
 424
 425 =head1 CAVEATS
 426
 427 =over 4
 428
 429 =item *
 430
 431 sep_char, quote_char, and escape_char are passed to Text::CSV on creation.
 432 Changing them later has no effect currently.
 433
 434 =item *
 435
 436 Encoding errors are not dealt with properly.
 437
 438 =back
 439
 440 =head1 TODO
 441
 442 Dispatch to child objects, like this:
 443
 444  $csv = SL::Helper::Csv->new(
 445    file  => ...
 446    class => SL::DB::Part,
 447    profile => [
 448      makemodel => {
 449        make_1  => make,
 450        model_1 => model,
 451      },
 452      makemodel => {
 453        make_2  => make,
 454        model_2 => model,
 455      },
 456    ]
 457  );
 458
 459 =head1 AUTHOR
 460
 461 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 462
 463 =cut