This is an automated email from the git hooks/post-receive script. js pushed a commit to branch master in repository libcatmandu-perl.
commit 1eb531bf3bb522ccec6e6eecf7976d9b395ba537 Author: Nicolas Steenlant <nicolas.steenl...@ugent.be> Date: Thu Dec 10 16:36:35 2015 +0100 TabularExporter --- lib/Catmandu/Exporter/CSV.pm | 35 ++++------------- lib/Catmandu/TabularExporter.pm | 85 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 92 insertions(+), 28 deletions(-) diff --git a/lib/Catmandu/Exporter/CSV.pm b/lib/Catmandu/Exporter/CSV.pm index 8d7ec3c..0672417 100644 --- a/lib/Catmandu/Exporter/CSV.pm +++ b/lib/Catmandu/Exporter/CSV.pm @@ -8,34 +8,14 @@ use Text::CSV; use Moo; use namespace::clean; -with 'Catmandu::Exporter'; +with 'Catmandu::TabularExporter'; -has csv => (is => 'ro', lazy => 1, builder => 1); +has csv => (is => 'lazy'); has sep_char => (is => 'ro', default => sub { ',' }); has quote_char => (is => 'ro', default => sub { '"' }); has escape_char => (is => 'ro', default => sub { '"' }); has always_quote => (is => 'ro'); -has header => (is => 'lazy', default => sub { 1 }); - -has fields => ( - is => 'rw', - trigger => sub { - my ($self, $fields) = @_; - $self->{fields} = _coerce_list($fields); - if (ref $fields and ref $fields eq 'HASH') { - $self->{header} = [ - map { $fields->{$_} // $_ } @{$self->{fields}} - ]; - } - }, -); - -sub _coerce_list { - my $fields = $_[0]; - if (ref $fields eq 'ARRAY') { return $fields } - if (ref $fields eq 'HASH') { return [sort keys %$fields] } - return [split ',', $fields]; -} +has header => (is => 'ro', default => sub { 1 }); sub _build_csv { my ($self) = @_; @@ -51,8 +31,6 @@ sub _build_csv { sub add { my ($self, $data) = @_; - return undef unless defined $data; - $self->fields([ sort keys %$data ]) unless $self->fields; my $fields = $self->fields; my $row = [map { my $val = $data->{$_} // ""; @@ -62,11 +40,12 @@ sub add { $val; } @$fields]; my $fh = $self->fh; - # we need to wait for the first row that can be printed to provide us with - # a header + + # header if (!$self->count && $self->header) { - $self->csv->print($fh, ref $self->header ? $self->header : $fields); + $self->csv->print($fh, $self->columns || $fields); } + $self->csv->print($fh, $row); } diff --git a/lib/Catmandu/TabularExporter.pm b/lib/Catmandu/TabularExporter.pm new file mode 100644 index 0000000..e49bbc8 --- /dev/null +++ b/lib/Catmandu/TabularExporter.pm @@ -0,0 +1,85 @@ +package Catmandu::TabularExporter; + +use Catmandu::Sane; + +our $VERSION = '0.9505'; + +use Moo::Role; + +sub _coerce_array { + my $fields = $_[0]; + if (ref $fields eq 'ARRAY') { return $fields } + if (ref $fields eq 'HASH') { return [sort keys %$fields] } + [split ',', $fields]; +} + +use namespace::clean; + +with 'Catmandu::Exporter'; + +has fields => ( + is => 'rwp', + coerce => \&_coerce_array, +); + +has columns => ( + is => 'rwp', + coerce => \&_coerce_array, +); + +has collect_fields => ( + is => 'ro', +); + +around add => sub { + my ($orig, $self, $data) = @_; + $self->_set_fields([sort keys %$data]) unless $self->fields; + $orig->($self, $data); +}; + +around add_many => sub { + my ($orig, $self, $many) = @_; + + if ($self->collect_fields && !$self->fields) { + my $coll; + + if (is_array_ref($many)) { + $coll = $many; + } elsif (is_hash_ref($many)) { + $coll = [$many]; + } else { + if (is_invocant($many)) { + $many = check_able($many, 'generator')->generator; + } + check_code_ref($many); + $coll = []; + while (defined(my $data = $many->())) { + push @$coll, $data; + } + } + + my %keys; + for my $data (@$coll) { + for my $key (keys %$data) { + $keys{$key} ||= 1; + } + } + $self->_set_fields([sort keys %keys]); + + $many = $coll; + } + + $orig->($self, $many); +}; + +1; + +__END__ + +=pod + +=head1 NAME + +Catmandu::TabularExporter - base role for exporters that export a tabular format like CSV + +=cut -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libcatmandu-perl.git _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits