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