File Coverage

blib/lib/Tie/CSV_File.pm

Criterion	Covered	Total	%
statement	165	166	99.4
branch	38	44	86.3
condition	13	20	65.0
subroutine	39	39	100.0
pod			n/a
total	255	269	94.8

package Tie::CSV_File;

use strict;
use warnings;

require Exporter;

use Data::Dumper;
use Tie::Array;
use Text::CSV_XS;
use Tie::File;
use Params::Validate qw/:all/;
use Carp;

our @ISA = qw(Exporter Tie::Array);

our $VERSION = '0.25';

# There's a common misspelling of sepArated (an E instead of A)
# That's why all csv file definitions are defined even with an E and an A
sub __mispell($) {
    shift =~ /^(.*_SEP)A(RATED)/;
    return "$1E$2";
}

# Export all predefined file types
our @EXPORT = map {($_, __mispell $_)}
              map {$_ . "_SEPARATED"}
              qw/TAB COLON SEMICOLON PIPE WHITESPACE/;

use constant SPLIT_SEPARATED_STANDARD_OPTIONS => (
     quote_char   => undef,
     eol          => undef, # default
     escape_char  => undef,
     always_quote => 0     # default
);

use constant SEPARATOR_CHARS => (
    [TAB       => "\t"],
    [COLON     => ":"],
    [SEMICOLON => ";"],
    [PIPE      => "|"]
);

# Create typical file format constants,
# only different on their seperator chars
BEGIN {
    foreach (SEPARATOR_CHARS) {
        my ($name, $char) = @$_;
        $name .= "_SEPARATED";
        eval "use constant $name => (sep_char => \$char,
                                     SPLIT_SEPARATED_STANDARD_OPTIONS)";
        (my $name_with_spelling_mistake = $name) =~ s/(?<=SEP)A(?=RATED)/E/;
        eval "*$name_with_spelling_mistake = *$name";
    };
}
# Note that the BEGIN block is necessary for Perl <= 5.6.1
# otherwise it detects too late the constant creation
# and signalizes the *_SEPARATED as barewords :-((

use constant WHITESPACE_SEPARATED => (
     sep_re       => qr/\s+/,
     sep_char     => ' ',
     quote_char   => undef,
     eol          => undef, # default
     escape_char  => undef,
     always_quote => 0     # default
);
*WHITESPACE_SEPERATED = *WHITESPACE_SEPARATED;
#              ^                       ^        you see the difference

sub TIEARRAY {
    my ($class, $fname) = (shift(), shift());

    # Parameter validation
    my %options = validate( @_, {
        quote_char   => {default => q/"/,  type => SCALAR | UNDEF},
        eol          => {default => undef, type => SCALAR | UNDEF},
        sep_char     => {default => q/,/,  type => SCALAR | UNDEF},
        sep_re       => {default => undef, isa  => 'Regexp'},
        escape_char  => {default => q/"/,  type => SCALAR | UNDEF},
        always_quote => {default => 0,     type => SCALAR | UNDEF}
    });

    $options{binary} = 1;   # to handle with 'ä','ö','ü' and so on, not for "\n"

    # Check for some cases to warn
    unless( defined $options{sep_char} ) {
        carp "The sep_char should either be defined or not mentioned, ".
             "but I got something like sep_char => undef\n" .
             "It's interpreted as the default value ',' (a comma)!";
        $options{sep_char} = ',';
    }
    unless ( (my $l = length $options{sep_char}) == 1) {
        carp "The sep_char should have a length of 1, not $l - reset it to default ','";
        $options{sep_char} = ',';
    }
    if (defined(my $c = $options{sep_char}) && defined(my $r = $options{sep_re})) {
        carp "The sep_char '$c' is itself not matched by the sep_re '$r'"
            if $c !~ /$r/;
    }

    tie my @lines, 'Tie::File', $fname or die "Can't open $fname: $!";
    # options are almost same for Text::CSV_XS
    # but sep_re is unknown to Text::CSV_XS
    # so remove it temporarely
    my %csv_xs_options = %options;
    delete $csv_xs_options{sep_re};
    if (not defined($csv_xs_options{eol})) {
        delete $csv_xs_options{eol};
    }
    my $csv_xs = Text::CSV_XS->new(\%csv_xs_options);
    if (not defined($csv_xs)) {
        die "Could not initialize Text::CSV_XS with options " . Dumper(\%csv_xs_options);
    }
    my $self = {
        lines       => \@lines,
        csv         => $csv_xs,
        quote_char  => $options{quote_char},
        escape_char => $options{escape_char},
        always_quote=> $options{always_quote},
    };
    $self->{sep_char} = $options{sep_char};
    $self->{eol} = $options{eol};
    $self->{sep_re} = $options{sep_re};
    bless $self, $class;
}

sub FETCHSIZE {
    my ($self) = @_;
    return scalar( @{ $self->{lines} } );
}

sub FETCH {
    my ($self, $line_nr) = @_;
    my @csv_options = map {$self->{$_}} qw/csv eol sep_char sep_re quote_char/;
    tie my @fields, 'Tie::CSV_File::Line', $self->{lines}, $line_nr, @csv_options;
    return \@fields;
}

sub EXISTS {
    my ($self, $line_nr) = @_;
    exists $self->{lines}->[$line_nr];
}

sub STORE {
    my ($self, $line_nr, $columns) = @_;
    my $csv = $self->{csv};
    if (@$columns) {
        $csv->combine(@$columns) or die "Can't store " . Dumper($columns);
        $self->{lines}->[$line_nr] = $csv->string;
    } else {
        $self->{lines}->[$line_nr] = $self->{eol} || '';
    }
}

sub STORESIZE {
    my ($self, $count) = @_;
    $#{$self->{lines}} = $count-1;
}

sub DELETE {
    my ($self, $line_nr) = @_;
    delete $self->{lines}->[$line_nr];
}

package Tie::CSV_File::Line;

use strict;
use warnings;

use Tie::Array;
use Text::CSV_XS;
use Tie::File;
use Data::Dumper;

our @ISA = qw(Exporter Tie::Array);

sub TIEARRAY {
    my ($class, $data, $line_nr, $csv, $eol, $sep_char, $sep_re, $quote_char) = @_;
    my $self = bless {
        data     => $data,
        line_nr  => $line_nr,
        csv      => $csv,
        eol      => $eol,
        sep_char => $sep_char,
        sep_re   => $sep_re,
        quote_char => $quote_char,
        fields   => undef
    }, $class;
}

sub columns {
    my $self = shift;
    my @fields = ();     # even if there aren't any fields, it's an empty list
    my $line  = $self->{data}->[$self->{line_nr}];
    defined($line) or return $self->{fields} = \@fields;
    if (defined( my $eol = $self->{eol} )) {
        $line =~ s/\Q$eol\E$//;
    } else {
        $line =~ s:$/$::;  # remove default eol in $/ at the end
    }
    if (length($line) == 0) {
        return $self->{fields} = []
    };
    if (defined( my $re = $self->{sep_re} )) {
        push @fields,
            map {defined($_) ? $_ : ''}  # empty fields shall be '', not undef
            grep !/$re/,                 # ugly, but needed see downside
            split /($re)/, $line;        # needed, as perl has problems with
                                         # split /x/,"xxxxxxxxxx"; or similar
        push @fields, '' if $line =~ /$re$/; # needed when the last element is empty
                                             # - it won't be catched with split
    } else {
        my $csv    = $self->{csv};
        $csv->parse($line) and push @fields, $csv->fields();
    }
    return $self->{fields} = \@fields;
}

sub set_new_fields {
    my ($self, $fields) = @_;
    $self->{fields} = $fields;

    my $csv_string;
    if (@$fields == 0) {                             # No columns
        my $eol = $self->{eol};
        $csv_string = defined($eol) ? $eol : "";
    } elsif (@$fields == 1 and $fields->[0] eq '') { # One column with an empty string
        my $quote_char = $self->{quote_char};
        my $eol        = $self->{eol};
        $_ = defined($_) ? $_ : ""
            for $eol, $quote_char;

        $csv_string = $quote_char . $quote_char . $eol;
    } else {                                         # Default
        my $csv = $self->{csv};
        $csv->combine(@$fields) or die "Can't store columns " . Dumper($fields);
        $csv_string = $csv->string;
    }
    $self->{data}->[$self->{line_nr}] = $csv_string;
}

sub FETCHSIZE {
    my ($self) = @_;
    return scalar( @{$self->{fields} || $self->columns} );
}

sub FETCH {
    my ($self, $col_nr) = @_;
    ($self->{fields} || $self->columns)->[$col_nr];
}

sub EXISTS {
    my ($self, $col_nr) = @_;
    exists( ($self->{fields} || $self->columns)->[$col_nr] );
}

sub STORE {
    my ($self, $col_nr, $value) = @_;
    my $csv    = $self->{csv};
    my $fields = $self->{fields} || $self->columns;
    $fields->[$col_nr] = $value;
    $self->set_new_fields($fields);
}

sub STORESIZE {
    my ($self, $new_size) = @_;
    my $fields = $self->{fields} || $self->columns;
    $#$fields    = $new_size-1;         # Set new size => last element is now at
                                        #                 index  size-1
    $self->set_new_fields($fields);
}

sub DELETE {
    my ($self, $col_nr) = @_;
    $self->STORE($col_nr,"");
}

1;
__END__