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