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