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__ |