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


line stmt bran cond sub pod time code
1             package Tie::CSV_File;
2              
3 12     12   249831 use strict;
  12         90  
  12         369  
4 12     12   62 use warnings;
  12         23  
  12         408  
5              
6             require Exporter;
7              
8 12     12   7301 use Data::Dumper;
  12         78855  
  12         893  
9 12     12   5756 use Tie::Array;
  12         15512  
  12         382  
10 12     12   11728 use Text::CSV_XS;
  12         223830  
  12         700  
11 12     12   9093 use Tie::File;
  12         265485  
  12         461  
12 12     12   6847 use Params::Validate qw/:all/;
  12         115636  
  12         2055  
13 12     12   120 use Carp;
  12         25  
  12         2289  
14              
15             our @ISA = qw(Exporter Tie::Array);
16              
17             our $VERSION = '0.25';
18              
19             # There's a common misspelling of sepArated (an E instead of A)
20             # That's why all csv file definitions are defined even with an E and an A
21             sub __mispell($) {
22 60     60   202 shift =~ /^(.*_SEP)A(RATED)/;
23 60         218 return "$1E$2";
24             }
25              
26             # Export all predefined file types
27             our @EXPORT = map {($_, __mispell $_)}
28             map {$_ . "_SEPARATED"}
29             qw/TAB COLON SEMICOLON PIPE WHITESPACE/;
30              
31 12         1274 use constant SPLIT_SEPARATED_STANDARD_OPTIONS => (
32             quote_char => undef,
33             eol => undef, # default
34             escape_char => undef,
35             always_quote => 0 # default
36 12     12   93 );
  12         21  
37              
38 12         2002 use constant SEPARATOR_CHARS => (
39             [TAB => "\t"],
40             [COLON => ":"],
41             [SEMICOLON => ";"],
42             [PIPE => "|"]
43 12     12   128 );
  12         30  
44              
45             # Create typical file format constants,
46             # only different on their seperator chars
47             BEGIN {
48 12     12   61 foreach (SEPARATOR_CHARS) {
49 48         162 my ($name, $char) = @$_;
50 48         100 $name .= "_SEPARATED";
51 48     12   3353 eval "use constant $name => (sep_char => \$char,
  12     12   95  
  12     12   37  
  12     12   699  
  12         78  
  12         29  
  12         569  
  12         81  
  12         26  
  12         680  
  12         83  
  12         39  
  12         572  
52             SPLIT_SEPARATED_STANDARD_OPTIONS)";
53 48         378 (my $name_with_spelling_mistake = $name) =~ s/(?<=SEP)A(?=RATED)/E/;
54 48         3024 eval "*$name_with_spelling_mistake = *$name";
55             };
56             }
57             # Note that the BEGIN block is necessary for Perl <= 5.6.1
58             # otherwise it detects too late the constant creation
59             # and signalizes the *_SEPARATED as barewords :-((
60              
61 12         10386 use constant WHITESPACE_SEPARATED => (
62             sep_re => qr/\s+/,
63             sep_char => ' ',
64             quote_char => undef,
65             eol => undef, # default
66             escape_char => undef,
67             always_quote => 0 # default
68 12     12   82 );
  12         28  
69             *WHITESPACE_SEPERATED = *WHITESPACE_SEPARATED;
70             # ^ ^ you see the difference
71              
72             sub TIEARRAY {
73 113     113   72929 my ($class, $fname) = (shift(), shift());
74            
75             # Parameter validation
76 113         3503 my %options = validate( @_, {
77             quote_char => {default => q/"/, type => SCALAR | UNDEF},
78             eol => {default => undef, type => SCALAR | UNDEF},
79             sep_char => {default => q/,/, type => SCALAR | UNDEF},
80             sep_re => {default => undef, isa => 'Regexp'},
81             escape_char => {default => q/"/, type => SCALAR | UNDEF},
82             always_quote => {default => 0, type => SCALAR | UNDEF}
83             });
84            
85 110         847 $options{binary} = 1; # to handle with 'ä','ö','ü' and so on, not for "\n"
86            
87             # Check for some cases to warn
88 110 100       353 unless( defined $options{sep_char} ) {
89 1         17 carp "The sep_char should either be defined or not mentioned, ".
90             "but I got something like sep_char => undef\n" .
91             "It's interpreted as the default value ',' (a comma)!";
92 1         599 $options{sep_char} = ',';
93             }
94 110 100       306 unless ( (my $l = length $options{sep_char}) == 1) {
95 3         336 carp "The sep_char should have a length of 1, not $l - reset it to default ','";
96 3         896 $options{sep_char} = ',';
97             }
98 110 100 66     557 if (defined(my $c = $options{sep_char}) && defined(my $r = $options{sep_re})) {
99 10 100       248 carp "The sep_char '$c' is itself not matched by the sep_re '$r'"
100             if $c !~ /$r/;
101             }
102            
103 110 100       1129 tie my @lines, 'Tie::File', $fname or die "Can't open $fname: $!";
104             # options are almost same for Text::CSV_XS
105             # but sep_re is unknown to Text::CSV_XS
106             # so remove it temporarely
107 109         19253 my %csv_xs_options = %options;
108 109         264 delete $csv_xs_options{sep_re};
109 109 100       259 if (not defined($csv_xs_options{eol})) {
110 100         171 delete $csv_xs_options{eol};
111             }
112 109         574 my $csv_xs = Text::CSV_XS->new(\%csv_xs_options);
113 109 50       18082 if (not defined($csv_xs)) {
114 0         0 die "Could not initialize Text::CSV_XS with options " . Dumper(\%csv_xs_options);
115             }
116             my $self = {
117             lines => \@lines,
118             csv => $csv_xs,
119             quote_char => $options{quote_char},
120             escape_char => $options{escape_char},
121             always_quote=> $options{always_quote},
122 109         707 };
123 109         244 $self->{sep_char} = $options{sep_char};
124 109         196 $self->{eol} = $options{eol};
125 109         266 $self->{sep_re} = $options{sep_re};
126 109         689 bless $self, $class;
127             }
128              
129             sub FETCHSIZE {
130 1310     1310   151195 my ($self) = @_;
131 1310         1854 return scalar( @{ $self->{lines} } );
  1310         3792  
132             }
133              
134             sub FETCH {
135 1203     1203   72443 my ($self, $line_nr) = @_;
136 1203         2080 my @csv_options = map {$self->{$_}} qw/csv eol sep_char sep_re quote_char/;
  6015         10846  
137 1203         4182 tie my @fields, 'Tie::CSV_File::Line', $self->{lines}, $line_nr, @csv_options;
138 1203         4063 return \@fields;
139             }
140              
141             sub EXISTS {
142 22     22   1911 my ($self, $line_nr) = @_;
143 22         54 exists $self->{lines}->[$line_nr];
144             }
145              
146             sub STORE {
147 235     235   42584 my ($self, $line_nr, $columns) = @_;
148 235         401 my $csv = $self->{csv};
149 235 100       548 if (@$columns) {
150 199 50       569 $csv->combine(@$columns) or die "Can't store " . Dumper($columns);
151 199         3987 $self->{lines}->[$line_nr] = $csv->string;
152             } else {
153 30   100     194 $self->{lines}->[$line_nr] = $self->{eol} || '';
154             }
155             }
156              
157             sub STORESIZE {
158 5     5   676 my ($self, $count) = @_;
159 5         11 $#{$self->{lines}} = $count-1;
  5         35  
160             }
161              
162             sub DELETE {
163 6     6   143 my ($self, $line_nr) = @_;
164 6         21 delete $self->{lines}->[$line_nr];
165             }
166              
167             package Tie::CSV_File::Line;
168              
169 12     12   117 use strict;
  12         32  
  12         288  
170 12     12   87 use warnings;
  12         42  
  12         435  
171              
172 12     12   69 use Tie::Array;
  12         22  
  12         314  
173 12     12   64 use Text::CSV_XS;
  12         238  
  12         539  
174 12     12   72 use Tie::File;
  12         26  
  12         341  
175 12     12   63 use Data::Dumper;
  12         19  
  12         10932  
176              
177             our @ISA = qw(Exporter Tie::Array);
178              
179             sub TIEARRAY {
180 1203     1203   2901 my ($class, $data, $line_nr, $csv, $eol, $sep_char, $sep_re, $quote_char) = @_;
181 1203         7314 my $self = bless {
182             data => $data,
183             line_nr => $line_nr,
184             csv => $csv,
185             eol => $eol,
186             sep_char => $sep_char,
187             sep_re => $sep_re,
188             quote_char => $quote_char,
189             fields => undef
190             }, $class;
191             }
192              
193             sub columns {
194 1195     1195   1763 my $self = shift;
195 1195         1773 my @fields = (); # even if there aren't any fields, it's an empty list
196 1195         4546 my $line = $self->{data}->[$self->{line_nr}];
197 1195 100       106002 defined($line) or return $self->{fields} = \@fields;
198 1145 100       2584 if (defined( my $eol = $self->{eol} )) {
199 61         497 $line =~ s/\Q$eol\E$//;
200             } else {
201 1084         4548 $line =~ s:$/$::; # remove default eol in $/ at the end
202             }
203 1145 100       2568 if (length($line) == 0) {
204 194         1009 return $self->{fields} = []
205             };
206 951 100       1802 if (defined( my $re = $self->{sep_re} )) {
207             push @fields,
208 50 50       858 map {defined($_) ? $_ : ''} # empty fields shall be '', not undef
  182         470  
209             grep !/$re/, # ugly, but needed see downside
210             split /($re)/, $line; # needed, as perl has problems with
211             # split /x/,"xxxxxxxxxx"; or similar
212 50 100       346 push @fields, '' if $line =~ /$re$/; # needed when the last element is empty
213             # - it won't be catched with split
214             } else {
215 901         1325 my $csv = $self->{csv};
216 901 50       2433 $csv->parse($line) and push @fields, $csv->fields();
217             }
218 951         30933 return $self->{fields} = \@fields;
219             }
220              
221             sub set_new_fields {
222 180     180   317 my ($self, $fields) = @_;
223 180         259 $self->{fields} = $fields;
224              
225 180         227 my $csv_string;
226 180 100 100     614 if (@$fields == 0) { # No columns
    100          
227 1         4 my $eol = $self->{eol};
228 1 50       4 $csv_string = defined($eol) ? $eol : "";
229             } elsif (@$fields == 1 and $fields->[0] eq '') { # One column with an empty string
230 21         38 my $quote_char = $self->{quote_char};
231 21         36 my $eol = $self->{eol};
232             $_ = defined($_) ? $_ : ""
233 21 100       93 for $eol, $quote_char;
234              
235 21         52 $csv_string = $quote_char . $quote_char . $eol;
236             } else { # Default
237 158         226 my $csv = $self->{csv};
238 158 50       395 $csv->combine(@$fields) or die "Can't store columns " . Dumper($fields);
239 158         2592 $csv_string = $csv->string;
240             }
241 180         1483 $self->{data}->[$self->{line_nr}] = $csv_string;
242             }
243              
244             sub FETCHSIZE {
245 4058     4058   160148 my ($self) = @_;
246 4058 100       5164 return scalar( @{$self->{fields} || $self->columns} );
  4058         10930  
247             }
248              
249             sub FETCH {
250 2881     2881   15471 my ($self, $col_nr) = @_;
251 2881   66     8596 ($self->{fields} || $self->columns)->[$col_nr];
252             }
253              
254             sub EXISTS {
255 61     61   117 my ($self, $col_nr) = @_;
256 61   33     159 exists( ($self->{fields} || $self->columns)->[$col_nr] );
257             }
258              
259             sub STORE {
260 177     177   405 my ($self, $col_nr, $value) = @_;
261 177         277 my $csv = $self->{csv};
262 177   66     523 my $fields = $self->{fields} || $self->columns;
263 177         356 $fields->[$col_nr] = $value;
264 177         357 $self->set_new_fields($fields);
265             }
266              
267             sub STORESIZE {
268 3     3   8 my ($self, $new_size) = @_;
269 3   33     13 my $fields = $self->{fields} || $self->columns;
270 3         12 $#$fields = $new_size-1; # Set new size => last element is now at
271             # index size-1
272 3         9 $self->set_new_fields($fields);
273             }
274              
275             sub DELETE {
276 14     14   31 my ($self, $col_nr) = @_;
277 14         34 $self->STORE($col_nr,"");
278             }
279              
280             1;
281             __END__