SL/Helper/Csv.pm

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