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   269904 use strict;
  12         102  
  12         387  
4 12     12   70 use warnings;
  12         27  
  12         455  
5              
6             require Exporter;
7              
8 12     12   6634 use Data::Dumper;
  12         84745  
  12         1027  
9 12     12   6033 use Tie::Array;
  12         16519  
  12         406  
10 12     12   10438 use Text::CSV_XS;
  12         219867  
  12         774  
11 12     12   10190 use Tie::File;
  12         272856  
  12         600  
12 12     12   7183 use Params::Validate qw/:all/;
  12         113883  
  12         2297  
13 12     12   102 use Carp;
  12         40  
  12         2393  
14              
15             our @ISA = qw(Exporter Tie::Array);
16              
17             our $VERSION = '0.24';
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   199 shift =~ /^(.*_SEP)A(RATED)/;
23 60         221 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         1305 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   104 );
  12         32  
37              
38 12         1959 use constant SEPARATOR_CHARS => (
39             [TAB => "\t"],
40             [COLON => ":"],
41             [SEMICOLON => ";"],
42             [PIPE => "|"]
43 12     12   100 );
  12         36  
44              
45             # Create typical file format constants,
46             # only different on their seperator chars
47             BEGIN {
48 12     12   62 foreach (SEPARATOR_CHARS) {
49 48         156 my ($name, $char) = @$_;
50 48         104 $name .= "_SEPARATED";
51 48     12   3300 eval "use constant $name => (sep_char => \$char,
  12     12   88  
  12     12   25  
  12     12   580  
  12         82  
  12         27  
  12         622  
  12         84  
  12         24  
  12         627  
  12         95  
  12         28  
  12         573  
52             SPLIT_SEPARATED_STANDARD_OPTIONS)";
53 48         372 (my $name_with_spelling_mistake = $name) =~ s/(?<=SEP)A(?=RATED)/E/;
54 48         2823 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         10583 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   83645 my ($class, $fname) = (shift(), shift());
74            
75             # Parameter validation
76 113         4106 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         919 $options{binary} = 1; # to handle with 'ä','ö','ü' and so on, not for "\n"
86            
87             # Check for some cases to warn
88 110 100       377 unless( defined $options{sep_char} ) {
89 1         24 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         729 $options{sep_char} = ',';
93             }
94 110 100       366 unless ( (my $l = length $options{sep_char}) == 1) {
95 3         312 carp "The sep_char should have a length of 1, not $l - reset it to default ','";
96 3         749 $options{sep_char} = ',';
97             }
98 110 100 66     677 if (defined(my $c = $options{sep_char}) && defined(my $r = $options{sep_re})) {
99 10 100       205 carp "The sep_char '$c' is itself not matched by the sep_re '$r'"
100             if $c !~ /$r/;
101             }
102            
103 110 100       1083 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         20501 my %csv_xs_options = %options;
108 109         325 delete $csv_xs_options{sep_re};
109 109 100       305 if (not defined($csv_xs_options{eol})) {
110 100         184 delete $csv_xs_options{eol};
111             }
112 109         670 my $csv_xs = Text::CSV_XS->new(\%csv_xs_options);
113 109 50       18881 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         612 };
123 109         300 $self->{sep_char} = $options{sep_char};
124 109         208 $self->{eol} = $options{eol};
125 109         278 $self->{sep_re} = $options{sep_re};
126 109         864 bless $self, $class;
127             }
128              
129             sub FETCHSIZE {
130 1310     1310   175623 my ($self) = @_;
131 1310         1755 return scalar( @{ $self->{lines} } );
  1310         4131  
132             }
133              
134             sub FETCH {
135 1203     1203   72487 my ($self, $line_nr) = @_;
136 1203         2302 my @csv_options = map {$self->{$_}} qw/csv eol sep_char sep_re quote_char/;
  6015         11304  
137 1203         6282 tie my @fields, 'Tie::CSV_File::Line', $self->{lines}, $line_nr, @csv_options;
138 1203         4413 return \@fields;
139             }
140              
141             sub EXISTS {
142 22     22   1613 my ($self, $line_nr) = @_;
143 22         51 exists $self->{lines}->[$line_nr];
144             }
145              
146             sub STORE {
147 235     235   30068 my ($self, $line_nr, $columns) = @_;
148 235         431 my $csv = $self->{csv};
149 235 100       605 if (@$columns) {
150 199 50       677 $csv->combine(@$columns) or die "Can't store " . Dumper($columns);
151 199         4275 $self->{lines}->[$line_nr] = $csv->string;
152             } else {
153 30   100     237 $self->{lines}->[$line_nr] = $self->{eol} || '';
154             }
155             }
156              
157             sub STORESIZE {
158 5     5   1788 my ($self, $count) = @_;
159 5         18 $#{$self->{lines}} = $count-1;
  5         57  
160             }
161              
162             sub DELETE {
163 6     6   176 my ($self, $line_nr) = @_;
164 6         35 delete $self->{lines}->[$line_nr];
165             }
166              
167             package Tie::CSV_File::Line;
168              
169 12     12   96 use strict;
  12         26  
  12         389  
170 12     12   80 use warnings;
  12         23  
  12         451  
171              
172 12     12   78 use Tie::Array;
  12         25  
  12         341  
173 12     12   70 use Text::CSV_XS;
  12         248  
  12         545  
174 12     12   81 use Tie::File;
  12         26  
  12         314  
175 12     12   69 use Data::Dumper;
  12         26  
  12         10897  
176              
177             our @ISA = qw(Exporter Tie::Array);
178              
179             sub TIEARRAY {
180 1203     1203   2945 my ($class, $data, $line_nr, $csv, $eol, $sep_char, $sep_re, $quote_char) = @_;
181 1203         8066 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   1774 my $self = shift;
195 1195         1872 my @fields = (); # even if there aren't any fields, it's an empty list
196 1195         4791 my $line = $self->{data}->[$self->{line_nr}];
197 1195 100       110700 defined($line) or return $self->{fields} = \@fields;
198 1145 100       2713 if (defined( my $eol = $self->{eol} )) {
199 61         410 $line =~ s/\Q$eol\E$//;
200             } else {
201 1084         4631 $line =~ s:$/$::; # remove default eol in $/ at the end
202             }
203 1145 100       2686 if (length($line) == 0) {
204 194         1240 return $self->{fields} = []
205             };
206 951 100       1911 if (defined( my $re = $self->{sep_re} )) {
207             push @fields,
208 50 50       789 map {defined($_) ? $_ : ''} # empty fields shall be '', not undef
  182         417  
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       317 push @fields, '' if $line =~ /$re$/; # needed when the last element is empty
213             # - it won't be catched with split
214             } else {
215 901         1491 my $csv = $self->{csv};
216 901 50       3361 $csv->parse($line) and push @fields, $csv->fields();
217             }
218 951         32019 return $self->{fields} = \@fields;
219             }
220              
221             sub set_new_fields {
222 180     180   369 my ($self, $fields) = @_;
223 180         266 $self->{fields} = $fields;
224              
225 180         222 my $csv_string;
226 180 100 100     633 if (@$fields == 0) { # No columns
    100          
227 1         4 my $eol = $self->{eol};
228 1 50       7 $csv_string = defined($eol) ? $eol : "";
229             } elsif (@$fields == 1 and $fields->[0] eq '') { # One column with an empty string
230 21         43 my $quote_char = $self->{quote_char};
231 21         34 my $eol = $self->{eol};
232             $_ = defined($_) ? $_ : ""
233 21 100       86 for $eol, $quote_char;
234              
235 21         52 $csv_string = $quote_char . $quote_char . $eol;
236             } else { # Default
237 158         260 my $csv = $self->{csv};
238 158 50       453 $csv->combine(@$fields) or die "Can't store columns " . Dumper($fields);
239 158         2645 $csv_string = $csv->string;
240             }
241 180         1635 $self->{data}->[$self->{line_nr}] = $csv_string;
242             }
243              
244             sub FETCHSIZE {
245 4058     4058   171595 my ($self) = @_;
246 4058 100       5024 return scalar( @{$self->{fields} || $self->columns} );
  4058         12435  
247             }
248              
249             sub FETCH {
250 2881     2881   17655 my ($self, $col_nr) = @_;
251 2881   66     8905 ($self->{fields} || $self->columns)->[$col_nr];
252             }
253              
254             sub EXISTS {
255 61     61   94 my ($self, $col_nr) = @_;
256 61   33     141 exists( ($self->{fields} || $self->columns)->[$col_nr] );
257             }
258              
259             sub STORE {
260 177     177   382 my ($self, $col_nr, $value) = @_;
261 177         296 my $csv = $self->{csv};
262 177   66     536 my $fields = $self->{fields} || $self->columns;
263 177         386 $fields->[$col_nr] = $value;
264 177         347 $self->set_new_fields($fields);
265             }
266              
267             sub STORESIZE {
268 3     3   13 my ($self, $new_size) = @_;
269 3   33     22 my $fields = $self->{fields} || $self->columns;
270 3         16 $#$fields = $new_size-1; # Set new size => last element is now at
271             # index size-1
272 3         14 $self->set_new_fields($fields);
273             }
274              
275             sub DELETE {
276 14     14   30 my ($self, $col_nr) = @_;
277 14         48 $self->STORE($col_nr,"");
278             }
279              
280             1;
281             __END__