--- /dev/null
+package SL::Helper::Csv;
+
+use strict;
+use warnings;
+
+use Carp;
+use IO::File;
+use Text::CSV;
+use Params::Validate qw(:all);
+use Rose::Object::MakeMethods::Generic scalar => [ qw(
+ file encoding sep_char quote_char header header_acc class numberformat
+ dateformat _io _csv _objects _parsed _data
+) ];
+
+
+# public interface
+
+sub new {
+ my $class = shift;
+ my %params = validate(@_, {
+ sep_char => { default => ';' },
+ quote_char => { default => '"' },
+ header => { type => ARRAYREF, optional => 1 },
+ header_acc => { type => HASHREF, optional => 1 },
+ file => 1,
+ encoding => 0,
+ class => 0,
+ numberformat => 0,
+ dateformat => 0,
+ });
+ my $self = bless {}, $class;
+
+ $self->$_($params{$_}) for keys %params;
+
+ $self->_io(IO::File->new);
+ $self->_csv(Text::CSV->new({
+ binary => 1,
+ sep_char => $self->sep_char,
+ quote_char => $self->quote_char,
+
+ }));
+
+ return $self;
+}
+
+sub parse {
+ my ($self, %params) = @_;
+
+ $self->_open_file;
+ return unless $self->_check_header;
+ return unless $self->_parse_data;
+
+ $self->_parsed(1);
+ return $self;
+}
+
+sub get_data {
+ $_[0]->_data;
+}
+
+sub get_objects {
+ my ($self, %params) = @_;
+ croak 'no class given' unless $self->class;
+ croak 'must parse first' unless $self->_parsed;
+
+ $self->_make_objects unless $self->_objects;
+ return wantarray ? @{ $self->_objects } : $self->_objects;
+}
+
+# private stuff
+
+sub _open_file {
+ my ($self, %params) = @_;
+
+ $self->encoding($self->_guess_encoding) if !$self->encoding;
+
+ $self->_io->open($self->file, '<' . $self->_encode_layer)
+ or die "could not open file " . $self->file;
+
+ return $self->_io;
+}
+
+sub _check_header {
+ my ($self, %params) = @_;
+ return $self->header if $self->header;
+
+ my $header = $self->_csv->getline($self->_io);
+
+ $self->header($header);
+}
+
+sub _parse_data {
+ my ($self, %params) = @_;
+ my @data;
+
+ $self->_csv->column_names(@{ $self->header });
+
+ push @data, $self->_csv->getline_hr($self->_io)
+ while !$self->_csv->eof;
+
+ $self->_data(\@data);
+}
+
+sub _encode_layer {
+ ':encoding(' . $_[0]->encoding . ')';
+}
+
+sub _make_objects {
+ my ($self, %params) = @_;
+ my @objs;
+
+ eval "require " . $self->class;
+ local $::myconfig{numberformat} = $self->numberformat if $self->numberformat;
+ local $::myconfig{dateformat} = $self->dateformat if $self->dateformat;
+
+ for my $line (@{ $self->_data }) {
+ push @objs, $self->class->new(
+ map {
+ ($self->header_acc && $self->header_acc->{$_}) || $_ => $line->{$_}
+ } grep { $_ } keys %$line
+ );
+ }
+
+ $self->_objects(\@objs);
+}
+
+sub _guess_encoding {
+ # won't fix
+ 'utf-8';
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+SL::Helper::Csv - take care of csv file uploads
+
+=head1 SYNOPSIS
+
+ use SL::Helper::Csv;
+
+ my $csv = SL::Helper::Csv->new(
+ file => \$::form->{upload_file},
+ encoding => 'utf-8', # undef means utf8
+ sep_char => ',', # default ';'
+ quote_char => ''', # default '"'
+ header => [qw(id text sellprice word)] # see later
+ header_acc => { sellprice => 'sellprice_as_number' }
+ class => 'SL::DB::CsvLine', # if present, map lines to this
+ )
+
+ my $status = $csv->parse;
+ my @hrefs = $csv->get_data;
+ my @objects = $scv->get_objects;
+
+=head1 DESCRIPTION
+
+See Synopsis.
+
+Text::CSV offeres already good functions to get lines out of a csv file, but in
+most cases you will want those line to be parsed into hashes or even objects,
+so this model just skips ahead and gives you objects.
+
+Encoding autodetection is not easy, and should not be trusted. Try to avoid it if possible.
+
+=head1 METHODS
+
+=over 4
+
+=item C<new> PARAMS
+
+Standard constructor. You can use this to set most of the data.
+
+=item C<parse>
+
+Do the actual work. Will return true ($self actually) if success, undef if not.
+
+=item C<get_objects>
+
+Parse the data into objects and return those.
+
+=item C<get_data>
+
+Returns an arrayref of the raw lines as hashrefs.
+
+=item C<file>
+
+The file which contents are to be read. Can be a name of a physical file or a
+scalar ref for memory data.
+
+=item C<encoding>
+
+Encoding of the CSV file. Note that this module does not do any encoding guessing.
+Know what your data ist. Defaults to utf-8.
+
+=item C<sep_char>
+
+=item C<quote_char>
+
+Same as in L<Text::CSV>
+
+=item C<header> \@FIELDS
+
+can be an array of columns, in this case the first line is not used as a
+header. Empty header fields will be ignored in objects.
+
+=item C<header_acc> \%ACCESSORS
+
+May be used to map header fields to custom accessors. Example:
+
+ { listprice => listprice_as_number }
+
+In this case C<listprice_as_number> will be used to read in values from the
+C<listprice> column.
+
+=item C<class>
+
+If present, the line will be handed to the new sub of this class,
+and the return value used instead of the line itself.
+
+=back
+
+=head1 BUGS
+
+=head1 AUTHOR
+
+=cut
--- /dev/null
+use Test::More;
+use SL::Dispatcher;
+use utf8;
+
+use_ok 'SL::Helper::Csv';
+my $csv;
+
+$csv = SL::Helper::Csv->new(
+ file => \"Kaffee;\n",
+ header => [ 'description' ],
+);
+
+isa_ok $csv->_csv, 'Text::CSV';
+isa_ok $csv->_io, 'IO::File';
+isa_ok $csv->parse, 'SL::Helper::Csv', 'parsing returns self';
+is_deeply $csv->get_data, [ { description => 'Kaffee' } ], 'simple case works';
+
+$csv->class('SL::DB::Part');
+
+is $csv->get_objects->[0]->description, 'Kaffee', 'get_object works';
+####
+
+SL::Dispatcher::pre_startup_setup();
+
+$::form = Form->new;
+$::myconfig{numberformat} = '1.000,00';
+$::myconfig{dateformat} = 'dd.mm.yyyy';
+$::locale = Locale->new('de');
+
+$csv = SL::Helper::Csv->new(
+ file => \"Kaffee;0.12;12,2;1,5234\n",
+ header => [ 'description', 'sellprice', 'lastcost_as_number', 'listprice' ],
+ header_acc => { listprice => 'listprice_as_number' },
+ class => 'SL::DB::Part',
+);
+$csv->parse;
+
+is $csv->get_objects->[0]->sellprice, 0.12, 'numeric attr works';
+is $csv->get_objects->[0]->lastcost, 12.2, 'attr helper works';
+is $csv->get_objects->[0]->listprice, 1.5234, 'header_acc works';
+
+#####
+
+
+$csv = SL::Helper::Csv->new(
+ file => \<<EOL,
+description,sellprice,lastcost_as_number,listprice,
+Kaffee,0.12,'12,2','1,5234'
+EOL
+ sep_char => ',',
+ quote_char => "'",
+ header_acc => { listprice => 'listprice_as_number' },
+ class => 'SL::DB::Part',
+);
+$csv->parse;
+is scalar @{ $csv->get_objects }, 1, 'auto header works';
+is $csv->get_objects->[0]->description, 'Kaffee', 'get_object works on auto header';
+
+#####
+
+
+$csv = SL::Helper::Csv->new(
+ file => \<<EOL,
+;;description;sellprice;lastcost_as_number;
+#####;Puppy;Kaffee;0.12;12,2;1,5234
+EOL
+ class => 'SL::DB::Part',
+);
+$csv->parse;
+is scalar @{ $csv->get_objects }, 1, 'bozo header doesn\'t blow things up';
+
+#####
+
+$csv = SL::Helper::Csv->new(
+ file => \<<EOL,
+description;partnumber;sellprice;lastcost_as_number;
+Kaffee;;0.12;12,2;1,5234
+Beer;1123245;0.12;12,2;1,5234
+EOL
+ class => 'SL::DB::Part',
+);
+$csv->parse;
+is scalar @{ $csv->get_objects }, 2, 'multiple objects work';
+is $csv->get_objects->[0]->description, 'Kaffee', 'first object';
+is $csv->get_objects->[1]->partnumber, '1123245', 'second object';
+
+####
+
+$csv = SL::Helper::Csv->new(
+ file => \<<EOL,
+description;partnumber;sellprice;lastcost_as_number;
+Kaffee;;0.12;1,221.52
+Beer;1123245;0.12;1.5234
+EOL
+ numberformat => '1,000.00',
+ class => 'SL::DB::Part',
+);
+$csv->parse;
+is $csv->get_objects->[0]->lastcost, '1221.52', 'formatnumber';
+
+######
+
+$csv = SL::Helper::Csv->new(
+ file => \<<EOL,
+"description;partnumber;sellprice;lastcost_as_number;
+Kaffee;;0.12;1,221.52
+Beer;1123245;0.12;1.5234
+EOL
+ numberformat => '1,000.00',
+ class => 'SL::DB::Part',
+);
+is $csv->parse, undef, 'broken csv header won\'t get parsed';
+
+
+done_testing();
+# vim: ft=perl
projects / kivitendo-erp.git / commitdiff