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 Text::CSV;
   9 use Params::Validate qw(:all);
  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 _io _csv _objects _parsed
  13   _data _errors
  14 ) ];
  15
  16
  17 # public interface
  18
  19 sub new {
  20   my $class  = shift;
  21   my %params = validate(@_, {
  22     sep_char               => { default => ';' },
  23     quote_char             => { default => '"' },
  24     escape_char            => { default => '"' },
  25     header                 => { type    => ARRAYREF, optional => 1 },
  26     profile                => { type    => HASHREF,  optional => 1 },
  27     file                   => 1,
  28     encoding               => 0,
  29     class                  => 0,
  30     numberformat           => 0,
  31     dateformat             => 0,
  32     ignore_unknown_columns => 0,
  33   });
  34   my $self = bless {}, $class;
  35
  36   $self->$_($params{$_}) for keys %params;
  37
  38   $self->_io(IO::File->new);
  39   $self->_csv(Text::CSV->new({
  40     binary => 1,
  41     sep_char    => $self->sep_char,
  42     quote_char  => $self->quote_char,
  43     escape_char => $self->escape_char,
  44
  45   }));
  46   $self->_errors([]);
  47
  48   return $self;
  49 }
  50
  51 sub parse {
  52   my ($self, %params) = @_;
  53
  54   $self->_open_file;
  55   return if ! $self->_check_header;
  56   return if $self->class && ! $self->_check_header_for_class;
  57   return if ! $self->_parse_data;
  58
  59   $self->_parsed(1);
  60   return $self;
  61 }
  62
  63 sub get_data {
  64   $_[0]->_data;
  65 }
  66
  67 sub get_objects {
  68   my ($self, %params) = @_;
  69   croak 'no class given'   unless $self->class;
  70   croak 'must parse first' unless $self->_parsed;
  71
  72   $self->_make_objects unless $self->_objects;
  73   return wantarray ? @{ $self->_objects } : $self->_objects;
  74 }
  75
  76 sub errors {
  77   @{ $_[0]->_errors }
  78 }
  79
  80 sub check_header {
  81   $_[0]->_check_header;
  82 }
  83
  84 # private stuff
  85
  86 sub _open_file {
  87   my ($self, %params) = @_;
  88
  89   $self->encoding($self->_guess_encoding) if !$self->encoding;
  90
  91   $self->_io->open($self->file, '<' . $self->_encode_layer)
  92     or die "could not open file " . $self->file;
  93
  94   return $self->_io;
  95 }
  96
  97 sub _check_header {
  98   my ($self, %params) = @_;
  99   return $self->header if $self->header;
 100
 101   my $header = $self->_csv->getline($self->_io);
 102
 103   $self->_push_error([
 104     $self->_csv->error_input,
 105     $self->_csv->error_diag,
 106     0,
 107   ]) unless $header;
 108
 109   $self->header($header);
 110 }
 111
 112 sub _check_header_for_class {
 113   my ($self, %params) = @_;
 114   my @errors;
 115
 116   carp 'this should never be called without' unless $self->class;
 117
 118   if ($self->ignore_unknown_columns) {
 119     my @new_header;
 120     for my $method (@{ $self->header }) {
 121       push @new_header, $self->class->can($self->_real_method($method))
 122          ? $method : undef;
 123     }
 124
 125     $self->header(\@new_header);
 126
 127     return 1;
 128   } else {
 129     for my $method (@{ $self->header }) {
 130       next if ! $method;
 131       next if $self->class->can($self->_real_method($method));
 132
 133       push @errors, [
 134         $method,
 135         undef,
 136         "header field $method is not recognized",
 137         undef,
 138         0,
 139       ];
 140     }
 141
 142     $self->_push_error(@errors);
 143     return ! @errors;
 144   }
 145 }
 146
 147 sub _parse_data {
 148   my ($self, %params) = @_;
 149   my (@data, @errors);
 150
 151   $self->_csv->column_names(@{ $self->header });
 152
 153   while (1) {
 154     my $row = $self->_csv->getline($self->_io);
 155     last if $self->_csv->eof;
 156
 157     if ($row) {
 158       my %hr;
 159       @hr{@{ $self->header }} = @$row;
 160       push @data, \%hr;
 161     } else {
 162       push @errors, [
 163         $self->_csv->error_input,
 164         $self->_csv->error_diag,
 165         $self->_io->input_line_number,
 166       ];
 167     }
 168   }
 169
 170   $self->_data(\@data);
 171   $self->_push_error(@errors);
 172
 173   return ! @errors;
 174 }
 175
 176 sub _encode_layer {
 177   ':encoding(' . $_[0]->encoding . ')';
 178 }
 179
 180 sub _make_objects {
 181   my ($self, %params) = @_;
 182   my @objs;
 183
 184   eval "require " . $self->class;
 185   local $::myconfig{numberformat} = $self->numberformat if $self->numberformat;
 186   local $::myconfig{dateformat}   = $self->dateformat   if $self->dateformat;
 187
 188   for my $line (@{ $self->_data }) {
 189     push @objs, $self->class->new(
 190       map {
 191         $self->_real_method($_) => $line->{$_}
 192       } grep { $_ } keys %$line
 193     );
 194   }
 195
 196   $self->_objects(\@objs);
 197 }
 198
 199 sub _real_method {
 200   my ($self, $arg) = @_;
 201   ($self->profile && $self->profile->{$arg}) || $arg;
 202 }
 203
 204 sub _guess_encoding {
 205   # won't fix
 206   'utf-8';
 207 }
 208
 209 sub _push_error {
 210   my ($self, @errors) = @_;
 211   my @new_errors = ($self->errors, @errors);
 212   $self->_errors(\@new_errors);
 213 }
 214
 215
 216 1;
 217
 218 __END__
 219
 220 =encoding utf-8
 221
 222 =head1 NAME
 223
 224 SL::Helper::Csv - take care of csv file uploads
 225
 226 =head1 SYNOPSIS
 227
 228   use SL::Helper::Csv;
 229
 230   my $csv = SL::Helper::Csv->new(
 231     file        => \$::form->{upload_file},
 232     encoding    => 'utf-8', # undef means utf8
 233     sep_char    => ',',     # default ';'
 234     quote_char  => ''',     # default '"'
 235     header      => [qw(id text sellprice word)] # see later
 236     profile    => { sellprice => 'sellprice_as_number' }
 237     class       => 'SL::DB::CsvLine',   # if present, map lines to this
 238   )
 239
 240   my $status  = $csv->parse;
 241   my $hrefs   = $csv->get_data;
 242   my @objects = $scv->get_objects;
 243
 244 =head1 DESCRIPTION
 245
 246 See Synopsis.
 247
 248 Text::CSV offeres already good functions to get lines out of a csv file, but in
 249 most cases you will want those line to be parsed into hashes or even objects,
 250 so this model just skips ahead and gives you objects.
 251
 252 Encoding autodetection is not easy, and should not be trusted. Try to avoid it
 253 if possible.
 254
 255 =head1 METHODS
 256
 257 =over 4
 258
 259 =item C<new> PARAMS
 260
 261 Standard constructor. You can use this to set most of the data.
 262
 263 =item C<parse>
 264
 265 Do the actual work. Will return true ($self actually) if success, undef if not.
 266
 267 =item C<get_objects>
 268
 269 Parse the data into objects and return those.
 270
 271 This method will return list or arrayref depending on context.
 272
 273 =item C<get_data>
 274
 275 Returns an arrayref of the raw lines as hashrefs.
 276
 277 =item C<errors>
 278
 279 Return all errors that came up druing parsing. See error handling for detailed
 280 information.
 281
 282 =back
 283
 284 =head1 PARAMS
 285
 286 =over 4
 287
 288 =item C<file>
 289
 290 The file which contents are to be read. Can be a name of a physical file or a
 291 scalar ref for memory data.
 292
 293 =item C<encoding>
 294
 295 Encoding of the CSV file. Note that this module does not do any encoding
 296 guessing.  Know what your data ist. Defaults to utf-8.
 297
 298 =item C<sep_char>
 299
 300 =item C<quote_char>
 301
 302 =item C<escape_char>
 303
 304 Same as in L<Text::CSV>
 305
 306 =item C<header> \@FIELDS
 307
 308 Can be an array of columns, in this case the first line is not used as a
 309 header. Empty header fields will be ignored in objects.
 310
 311 =item C<profile> \%ACCESSORS
 312
 313 May be used to map header fields to custom accessors. Example:
 314
 315   { listprice => listprice_as_number }
 316
 317 In this case C<listprice_as_number> will be used to read in values from the
 318 C<listprice> column.
 319
 320 =item C<class>
 321
 322 If present, the line will be handed to the new sub of this class,
 323 and the return value used instead of the line itself.
 324
 325 =item C<ignore_unknown_columns>
 326
 327 If set, the import will ignore unkown header columns. Useful for lazy imports,
 328 but deactivated by default.
 329
 330 =back
 331
 332 =head1 ERROR HANDLING
 333
 334 After parsing a file all errors will be accumulated into C<errors>.
 335
 336 Each entry is an arrayref with the following structure:
 337
 338  [
 339  0  offending raw input,
 340  1  Text::CSV error code if T:C error, 0 else,
 341  2  error diagnostics,
 342  3  position in line,
 343  4  estimated line in file,
 344  ]
 345
 346 Note that the last entry can be off, but will give an estimate.
 347
 348 =head1 CAVEATS
 349
 350 =over 4
 351
 352 =item *
 353
 354 sep_char, quote_char, and escape_char are passed to Text::CSV on creation.
 355 Changing them later has no effect currently.
 356
 357 =item *
 358
 359 Encoding errors are not dealt with properly.
 360
 361 =back
 362
 363 =head1 TODO
 364
 365 Dispatch to child objects, like this:
 366
 367  $csv = SL::Helper::Csv->new(
 368    file  => ...
 369    class => SL::DB::Part,
 370    profile => [
 371      makemodel => {
 372        make_1  => make,
 373        model_1 => model,
 374      },
 375      makemodel => {
 376        make_2  => make,
 377        model_2 => model,
 378      },
 379    ]
 380  );
 381
 382 =head1 AUTHOR
 383
 384 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
 385
 386 =cut