File Coverage

blib/lib/PDL/IO/CSV.pm
Criterion Covered Total %
statement 281 476 59.0
branch 105 274 38.3
condition 21 88 23.8
subroutine 32 37 86.4
pod 4 4 100.0
total 443 879 50.4


line stmt bran cond sub pod time code
1             package PDL::IO::CSV;
2              
3 3     3   546214 use strict;
  3         14  
  3         73  
4 3     3   22 use warnings;
  3         6  
  3         224  
5              
6             require Exporter;
7             our @ISA = qw(Exporter);
8             our @EXPORT_OK = qw(rcsv1D rcsv2D wcsv1D wcsv2D);
9             our %EXPORT_TAGS = (all => \@EXPORT_OK);
10              
11             our $VERSION = '0.011';
12              
13 3     3   14 use Config;
  3         5  
  3         150  
14 3 50   3   15 use constant NO64BITINT => ($Config{ivsize} < 8) ? 1 : 0;
  3         6  
  3         504  
15 3 50   3   18 use constant NODATETIME => eval { require PDL::DateTime; require Time::Moment; 1 } ? 0 : 1;
  3         6  
  3         9  
  3         634  
  0         0  
  0         0  
16 3 50   3   17 use constant DEBUG => $ENV{PDL_IO_CSV_DEBUG} ? 1 : 0;
  3         6  
  3         180  
17              
18 3     3   541 use PDL;
  3         16  
  3         13  
19 3     3   188331 use Text::CSV_XS;
  3         29345  
  3         131  
20 3     3   17 use Scalar::Util qw(looks_like_number openhandle blessed);
  3         9  
  3         129  
21 3     3   1238 use POSIX qw();
  3         15528  
  3         73  
22 3     3   1288 use Time::Piece;
  3         23256  
  3         10  
23              
24 3     3   180 use Carp;
  3         5  
  3         188  
25             $Carp::Internal{ (__PACKAGE__) }++;
26              
27             sub import {
28 3     3   26 my $package = shift;
29             {
30 3     3   15 no strict 'refs';
  3         3  
  3         4788  
  3         5  
31 3 100       7 *{'PDL::wcsv2D'} = \&wcsv2D if grep { /^(:all|wcsv2D)$/ } @_;
  2         10  
  2         15  
32 3 100       14 *{'PDL::wcsv1D'} = \&wcsv1D if grep { /^(:all|wcsv1D)$/ } @_;
  2         9  
  2         12  
33             }
34 3 100       282 __PACKAGE__->export_to_level(1, $package, @_) if @_;
35             }
36              
37             my %pck = (
38             byte => "C",
39             short => "s",
40             ushort => "S",
41             long => "l",
42             longlong => "q",
43             float => "f",
44             double => "d",
45             );
46              
47             sub wcsv1D {
48 0     0 1 0 my ($fh, $O, $C) = _proc_wargs('1D', @_);
49              
50 0         0 my $cols = 0;
51 0         0 my $rows = 0;
52 0         0 my @c_pdl;
53             my @c_rows;
54 0         0 my @c_type;
55 0         0 my @c_size;
56 0         0 my @c_pack;
57 0         0 my @c_dataref;
58 0         0 my @c_offset;
59 0         0 my @c_max_offset;
60 0         0 my @c_bad;
61              
62 0         0 my $bad2empty = $O->{bad2empty};
63              
64 0   0     0 while (blessed $_[0] && $_[0]->isa('PDL')) {
65 0         0 $c_pdl[$cols] = shift;
66 0 0       0 croak "FATAL: wcsv1D() expects 1D piddles" unless $c_pdl[$cols]->ndims == 1;
67 0         0 $c_size[$cols] = PDL::Core::howbig($c_pdl[$cols]->get_datatype);
68 0         0 $c_dataref[$cols] = $c_pdl[$cols]->get_dataref;
69 0         0 $c_offset[$cols] = 0;
70 0         0 my $type = $c_pdl[$cols]->type;
71 0         0 my $dim = $c_pdl[$cols]->dim(0);
72 0         0 $c_pack[$cols] = $pck{$type};
73 0 0 0     0 croak "FATAL: your perl does not support 64bitint (avoid using type longlong)" if $c_pack[$cols] eq 'q' && NO64BITINT;
74 0         0 $c_max_offset[$cols] = $c_size[$cols] * $dim;
75 0 0       0 $rows = $dim if $rows < $dim;
76 0 0 0     0 if ($bad2empty && $c_pdl[$cols]->check_badflag) {
77 0         0 my $b = pdl($type, 1)->setbadif(1);
78 0         0 my $d = $b->get_dataref;
79 0         0 $c_bad[$cols] = substr($$d, 0, $c_size[$cols]); # raw bytes representind BAD value
80             }
81 0         0 $cols++;
82             }
83              
84 0 0       0 my $csv = Text::CSV_XS->new($C) or croak "" . Text::CSV_XS->error_diag();
85 0 0       0 if ($O->{header}) {
86 0         0 my $count = scalar @{$O->{header}};
  0         0  
87 0 0       0 croak "FATAL: wrong header (expected $cols items, got $count)" if $cols != $count;
88 0         0 $csv->print($fh, $O->{header});
89             }
90 0         0 for my $r (0..$rows-1) {
91 0         0 my @v = ('') x $cols;
92 0         0 for my $c (0..$cols-1) {
93 0 0       0 if ($c_max_offset[$c] >= $c_offset[$c]) {
94 0 0 0     0 if ($bad2empty && $c_bad[$c]) {
95 0         0 my $v = substr(${$c_dataref[$c]}, $c_offset[$c], $c_size[$c]);
  0         0  
96 0 0       0 if ($v ne $c_bad[$c]) {
97 0         0 $v[$c] = unpack($c_pack[$c], $v);
98 0 0       0 $v[$c] = PDL::DateTime::ll2dt($v[$c]) if ref $c_pdl[$c] eq 'PDL::DateTime';
99             }
100             }
101             else {
102 0         0 my $v = substr(${$c_dataref[$c]}, $c_offset[$c], $c_size[$c]);
  0         0  
103 0         0 $v[$c] = unpack($c_pack[$c], $v);
104 0 0       0 $v[$c] = PDL::DateTime::ll2dt($v[$c]) if ref $c_pdl[$c] eq 'PDL::DateTime';
105             }
106             }
107 0         0 $c_offset[$c] += $c_size[$c];
108             }
109 0         0 $csv->print($fh, \@v);
110             }
111             #XXX close $fh;
112             }
113              
114             sub wcsv2D {
115 0     0 1 0 my $pdl = shift;
116 0         0 my ($fh, $O, $C) = _proc_wargs('2D', @_);
117              
118 0 0       0 croak "FATAL: wcsv2D() expects 2D piddle" unless $pdl->ndims == 2;
119 0         0 my $p = $pdl->transpose;
120              
121 0         0 my ($cols, $rows) = $p->dims;
122 0         0 my $type = $p->type;
123 0         0 my $size = PDL::Core::howbig($p->get_datatype);
124 0         0 my $packC = $pck{$type} . "[$cols]";
125 0         0 my $pack1 = $pck{$type};
126 0 0 0     0 croak "FATAL: your perl does not support 64bitint (avoid using type longlong)" if $pck{$type} eq 'q' && NO64BITINT;
127 0         0 my $dataref = $p->get_dataref;
128 0         0 my $offset = 0;
129 0         0 my $colsize = $size * $cols;
130 0         0 my $max_offset = $colsize * ($rows - 1);
131 0         0 my $bad;
132 0 0 0     0 if ($O->{bad2empty} && $p->check_badflag) {
133 0         0 my $b = pdl($type, 1)->setbadif(1);
134 0         0 my $d = $b->get_dataref;
135 0         0 $bad = substr($$d, 0, $size); # raw bytes representind BAD value
136             }
137              
138 0 0       0 my $csv = Text::CSV_XS->new($C) or croak "" . Text::CSV_XS->error_diag();
139 0 0       0 if ($O->{header}) {
140 0         0 my $n = scalar @{$O->{header}};
  0         0  
141 0 0       0 croak "FATAL: wrong header (expected $cols items, got $n)" if $cols != $n;
142 0         0 $csv->print($fh, $O->{header});
143             }
144 0         0 while ($offset <= $max_offset) {
145 0 0       0 if (defined $bad) {
146 0 0       0 my @v = map { my $v = substr($$dataref, $offset + $_*$size, $size); $v eq $bad ? '' : unpack($pack1, $v) } (0..$cols-1);
  0         0  
  0         0  
147 0         0 $csv->print($fh, \@v);
148             }
149             else {
150 0         0 my @v = unpack($packC, substr($$dataref, $offset, $colsize));
151 0         0 $csv->print($fh, \@v);
152             }
153 0         0 $offset += $colsize;
154             }
155             #XXX close $fh;
156             }
157              
158             sub rcsv1D {
159 6     6 1 8815 my ($fh, $coli, $O, $C) = _proc_rargs('1D', @_);
160              
161 6         9 my ($c_type, $c_pack, $c_sizeof, $c_pdl, $c_bad, $c_dataref, $c_idx, $c_dt, $allocated, $cols); # initialize after we get 1st line
162              
163 6 50       37 my $csv = Text::CSV_XS->new($C) or croak "" . Text::CSV_XS->error_diag();
164 6         613 my $processed = 0;
165 6         7 my $finished = 0;
166 6         20 my $chunk = $O->{fetch_chunk};
167 6         7 my $empty2bad = $O->{empty2bad};
168 6         10 my $text2bad = $O->{text2bad};
169 6         8 my $dec_comma = $O->{decimal_comma};
170              
171 6 50       10 warn "Fetching 1D " . _dbg_msg($O, $C) . "\n" if $O->{debug};
172             # skip headers
173 6         9 my $headerline;
174             my $headerdetection;
175 6 100 33     35 if (looks_like_number($O->{header})) {
    50          
176 1 50       4 if ($O->{header} == 1) {
177             # get the header line (only if skipping exactly 1 line)
178 0         0 $headerline = $csv->getline($fh);
179             }
180             else {
181 1         33 $csv->getline($fh) for (1..$O->{header});
182             }
183             }
184             elsif ($O->{header} && $O->{header} eq 'auto') {
185 5         8 $headerdetection = 1;
186             }
187              
188 6         65 while (!$finished) {
189 6         7 my $rows = 0;
190 6         8 my @bytes;
191             my $r;
192 6         10 while ($rows < $chunk) {
193 110         2104 my $r = $csv->getline($fh);
194 110 100       2671 if (defined $r) {
195 104 100       155 if (defined $headerdetection) {
196 5         7 my $numeric = 0;
197 5         11 for (@$r) {
198 27 50       42 if (looks_like_number($_)) {
199 27         34 $numeric++;
200             }
201 0         0 elsif (!NODATETIME) {
202             my $v = $O->{strptime} ? _strptime($_, $O->{strptime}) : PDL::DateTime::dt2ll($_);
203             $numeric++ if defined $v;
204             }
205             }
206 5 50       15 if ($numeric == 0) {
207             # no numeric values found => skip this line but keep it as a potential header
208 0         0 $headerline = $r;
209 0         0 next;
210             }
211 5         9 $headerdetection = undef;
212             }
213 104 100       142 unless (defined $c_type) {
214 6         19 ($c_type, $c_pack, $c_sizeof, $c_pdl, $c_bad, $c_dataref, $c_idx, $c_dt, $allocated, $cols) = _init_1D($coli, $r, $O);
215 6 50       19 warn "Initialized size=$allocated, cols=$cols, type=".join(",",@$c_type)."\n" if $O->{debug};
216             }
217 104 50       136 if ($dec_comma) {
218 0 0       0 for (@$r) { s/,/./ if defined $_ };
  0         0  
219             }
220 104 100       134 if ($empty2bad) {
221 72 50       93 if (defined $coli) {
222 0         0 for (0..$cols-1) {
223 0         0 my $i = $coli->[$_];
224 0 0       0 unless (defined $r->[$i]) { $r->[$i] = $c_bad->[$_]; $c_pdl->[$_]->badflag(1) }
  0         0  
  0         0  
225             }
226             }
227             else {
228 72         118 for (0..$cols-1) {
229 360 50       484 unless (defined $r->[$_]) { $r->[$_] = $c_bad->[$_]; $c_pdl->[$_]->badflag(1) }
  0         0  
  0         0  
230             }
231             }
232             }
233 104 50       142 if (defined $c_dt) {
234 0         0 for (0..$cols-1) {
235 0 0       0 next unless defined $c_dt->[$_];
236 0 0       0 my $v = $c_dt->[$_] ne 'datetime' ? _strptime($r->[$_], $c_dt->[$_]) : PDL::DateTime::dt2ll($r->[$_]);
237 0 0       0 if (defined $v) {
238 0         0 $r->[$_] = $v;
239             }
240             else {
241 0         0 $r->[$_] = $c_bad->[$_];
242 0         0 $c_pdl->[$_]->badflag(1);
243             }
244             }
245             }
246 104 50       122 if ($text2bad) {
247 0 0       0 if (defined $coli) {
248 0         0 for (0..$cols-1) {
249 0         0 my $i = $coli->[$_];
250 0 0       0 unless (looks_like_number($r->[$i])) { $r->[$i] = $c_bad->[$_]; $c_pdl->[$_]->badflag(1) }
  0         0  
  0         0  
251             }
252             }
253             else {
254 0         0 for (0..$cols-1) {
255 0 0       0 unless (looks_like_number($r->[$_])) { $r->[$_] = $c_bad->[$_]; $c_pdl->[$_]->badflag(1) }
  0         0  
  0         0  
256             }
257             }
258             }
259 104 50       119 if (defined $coli) { # only selected columns
260 3     3   35 no warnings 'pack'; # intentionally disable all pack related warnings
  3         6  
  3         123  
261 3     3   17 no warnings 'numeric'; # disable: Argument ??? isn't numeric in pack
  3         4  
  3         160  
262 3     3   25 no warnings 'uninitialized'; # disable: Use of uninitialized value in pack
  3         5  
  3         171  
263 0         0 $bytes[$_] .= pack($c_pack->[$_], $r->[$coli->[$_]]) for (0..$cols-1);
264             }
265             else { # all columns
266 3     3   14 no warnings 'pack'; # intentionally disable all pack related warnings
  3         7  
  3         104  
267 3     3   14 no warnings 'numeric'; # disable: Argument ??? isn't numeric in pack
  3         5  
  3         84  
268 3     3   13 no warnings 'uninitialized'; # disable: Use of uninitialized value in pack
  3         5  
  3         2466  
269 104         620 $bytes[$_] .= pack($c_pack->[$_], $r->[$_]) for (0..$cols-1);
270             }
271 104         223 $rows++;
272             }
273             else {
274 6         9 $finished = 1;
275 6         10 last;
276             }
277             }
278 6 50       20 if ($rows > 0) {
279 6         8 $processed += $rows;
280 6 50       11 if ($allocated < $processed) {
281 0         0 $allocated += $O->{reshape_inc};
282 0 0       0 warn "Reshape to: '$allocated'\n" if $O->{debug};
283 0         0 for (0..$cols-1) {
284 0         0 $c_pdl->[$_]->reshape($allocated);
285 0         0 $c_dataref->[$_] = $c_pdl->[$_]->get_dataref;
286             }
287             }
288 6         13 for my $ci (0..$cols-1) {
289 30         40 my $len = length $bytes[$ci];
290 30         33 my $expected_len = $c_sizeof->[$ci] * $rows;
291 30 50       50 croak "FATAL: len mismatch $len != $expected_len" if $len != $expected_len;
292 30         31 substr(${$c_dataref->[$ci]}, $c_idx->[$ci], $len) = $bytes[$ci];
  30         48  
293 30         46 $c_idx->[$ci] += $expected_len;
294             }
295             }
296             }
297              
298             #XXX close $fh;
299 6 50       17 if (ref $c_pdl eq 'ARRAY') {
300 6 50       12 if ($processed != $allocated) {
301 6 50       13 warn "Reshape to: '$processed' (final)\n" if $O->{debug};
302 6         47 $c_pdl->[$_]->reshape($processed) for (0..$cols-1);
303             }
304 6         789 $c_pdl->[$_]->upd_data for (0..$cols-1);
305 6 50       12 if (ref $headerline eq 'ARRAY') {
306 0         0 for (0..$cols-1) {
307 0 0 0     0 $c_pdl->[$_]->hdr->{col_name} = $headerline->[$_] if $headerline->[$_] && $headerline->[$_] ne '';
308             };
309             }
310 6         118 return @$c_pdl;
311             }
312              
313 0         0 warn "rcsv1D: no data\n";
314 0         0 return undef;
315             }
316              
317             sub rcsv2D {
318 7     7 1 24961 my ($fh, $coli, $O, $C) = _proc_rargs('2D', @_);
319              
320 7         14 my ($c_type, $c_pack, $c_sizeof, $c_pdl, $c_bad, $c_dataref, $allocated, $cols);
321              
322 7 50       38 my $csv = Text::CSV_XS->new($C) or croak "" . Text::CSV_XS->error_diag();
323 7         740 my $processed = 0;
324 7         9 my $c_idx = 0;
325 7         10 my $finished;
326             my $pck;
327 7         8 my $chunk = $O->{fetch_chunk};
328 7         9 my $empty2bad = $O->{empty2bad};
329 7         10 my $text2bad = $O->{text2bad};
330 7         37 my $dec_comma = $O->{decimal_comma};
331 7         9 my $bcount = 0;
332              
333 7 50       11 warn "Fetching 2D " . _dbg_msg($O, $C) . "\n" if $O->{debug};
334 7 100       14 if ($O->{header}) {
335 1         32 $csv->getline($fh) for (1..$O->{header});
336             }
337 7         66 while (!$finished) {
338 7         14 my $bytes = '';
339 7         8 my $rows = 0;
340 7         9 while ($rows < $chunk) {
341 59         1037 my $r = $csv->getline($fh);
342 59 100       1636 if (defined $r) {
343 52 100       79 unless (defined $pck) {
344 7         17 ($c_type, $c_pack, $c_sizeof, $c_pdl, $c_bad, $c_dataref, $allocated, $cols) = _init_2D($coli, scalar @$r, $O);
345 7 50       19 warn "Initialized size=$allocated, cols=$cols, type=$c_type\n" if $O->{debug};
346 7         15 $pck = "$c_pack\[$cols\]";
347             }
348 52 50       75 if ($dec_comma) {
349 0 0       0 for (@$r) { s/,/./ if defined $_ };
  0         0  
350             }
351 52 100       76 if ($empty2bad) {
352 10 50       17 if (defined $coli) {
353 0         0 for (0..$cols-1) {
354 0         0 my $i = $coli->[$_];
355 0 0       0 unless (defined $r->[$i]) { $r->[$i] = $c_bad; $c_pdl->badflag(1) }
  0         0  
  0         0  
356             }
357             }
358             else {
359 10         20 for (0..$cols-1) {
360 30 100       46 unless (defined $r->[$_]) { $r->[$_] = $c_bad; $c_pdl->badflag(1) }
  6         9  
  6         17  
361             }
362             }
363             }
364 52 100       62 if ($text2bad) {
365 5 50       10 if (defined $coli) {
366 0         0 for (0..$cols-1) {
367 0         0 my $i = $coli->[$_];
368 0 0       0 unless (looks_like_number($r->[$i])) { $r->[$i] = $c_bad; $c_pdl->badflag(1) }
  0         0  
  0         0  
369             }
370             }
371             else {
372 5         7 for (0..$cols-1) {
373 15 100       28 unless (looks_like_number($r->[$_])) { $r->[$_] = $c_bad; $c_pdl->badflag(1) }
  1         2  
  1         5  
374             }
375             }
376             }
377 52 50       70 if (defined $coli) { # only selected columns
378 3     3   19 no warnings 'pack'; # intentionally disable all pack related warnings
  3         5  
  3         117  
379 3     3   16 no warnings 'numeric'; # disable: Argument ??? isn't numeric in pack
  3         4  
  3         110  
380 3     3   14 no warnings 'uninitialized'; # disable: Use of uninitialized value in pack
  3         24  
  3         134  
381 0         0 $bytes .= pack($pck, map { $r->[$_] } @$coli);
  0         0  
382             }
383             else { # all columns
384 3     3   15 no warnings 'pack'; # intentionally disable all pack related warnings
  3         5  
  3         91  
385 3     3   12 no warnings 'numeric'; # disable: Argument ??? isn't numeric in pack
  3         6  
  3         90  
386 3     3   15 no warnings 'uninitialized'; # disable: Use of uninitialized value in pack
  3         3  
  3         5488  
387 52         182 $bytes .= pack($pck, @$r);
388             }
389 52         114 $rows++;
390             }
391             else {
392 7         12 $finished = 1;
393 7         10 last;
394             }
395             }
396 7 50       15 if ($rows > 0) {
397 7         11 $processed += $rows;
398 7 50       11 if ($allocated < $processed) {
399 0         0 $allocated += $O->{reshape_inc};
400 0 0       0 warn "Reshaping to $allocated\n" if $O->{debug};
401 0         0 $c_pdl->reshape($cols, $allocated);
402 0         0 $c_dataref = $c_pdl->get_dataref;
403             }
404 7         13 my $len = length $bytes;
405 7         9 my $expected_len = $c_sizeof * $cols * $rows;
406 7 50       11 croak "FATAL: len mismatch $len != $expected_len" if $len != $expected_len;
407 7         16 substr($$c_dataref, $c_idx, $len) = $bytes;
408 7         14 $c_idx += $len;
409             }
410             }
411              
412             #XXX close $fh;
413              
414 7 50 33     80 if (blessed $c_pdl && $c_pdl->isa('PDL')) {
415 7 50       16 if ($processed != $allocated) {
416 7 50       28 warn "Reshaping to $processed (final)\n" if $O->{debug};
417 7         20 $c_pdl->reshape($cols, $processed); # allocate the exact size
418             }
419 7         285 $c_pdl->upd_data;
420 7         20 return $c_pdl->transpose;
421             }
422              
423 0         0 warn "rcsv2D: no data\n";
424 0         0 return undef;
425             }
426              
427             sub _dbg_msg {
428 0     0   0 my ($O, $C) = @_;
429             sprintf "chunk=%s, reshape=%s, bad=%s/%s, sep_char='%s'",
430             $O->{fetch_chunk} ||= '?',
431             $O->{reshape_inc} ||= '?',
432             $O->{empty2bad} ||= '?',
433             $O->{text2bad} ||= '?',
434 0   0     0 $C->{sep_char} ||= '?';
      0        
      0        
      0        
      0        
435             }
436              
437             sub _proc_wargs {
438 0 0   0   0 my $options = ref $_[-1] eq 'HASH' ? pop : {};
439 0 0 0     0 my $filename_or_fh = !blessed $_[-1] || !$_[-1]->isa('PDL') ? pop : undef;
440 0         0 my $fn = shift;
441              
442 0         0 my $C = { %$options }; # make a copy
443              
444 0         0 my @keys = qw/ debug header bad2empty encoding /;
445 0         0 my $O = { map { $_ => delete $C->{$_} } @keys };
  0         0  
446 0 0       0 $O->{debug} = DEBUG unless defined $O->{debug};
447 0 0       0 $O->{bad2empty} = 1 unless defined $O->{bad2empty};
448 0 0       0 $O->{header} = ($fn eq '1D' ? 'auto' : 0) if !defined $O->{header};
    0          
449              
450             # explicitely set
451 0 0       0 $C->{sep_char} = ',' unless defined $C->{sep_char};
452 0 0       0 $C->{eol} = "\n" unless defined $C->{eol};
453              
454 0 0       0 if (defined $O->{header}) {
455 0 0 0     0 croak "FATAL: header should be arrayref" unless ref $O->{header} eq 'ARRAY' || $O->{header} eq 'auto';
456 0 0       0 if ($O->{header} eq 'auto') {
457 0         0 my @n;
458 0         0 my $count = 0;
459 0         0 for (@_) {
460 0         0 push @n, my $n = $_->hdr->{col_name};
461 0 0       0 $count++ if defined $n;
462             }
463 0 0       0 $O->{header} = $count > 0 ? \@n : undef;
464             }
465             }
466              
467 0         0 my $fh;
468 0 0       0 if (!defined $filename_or_fh) {
    0          
469 0         0 $fh = \*STDOUT;
470             }
471             elsif (openhandle($filename_or_fh)) {
472 0         0 $fh = $filename_or_fh;
473             }
474             else {
475 0 0       0 open $fh, ">", $filename_or_fh or croak "$filename_or_fh: $!";
476             }
477 0 0       0 binmode $fh, $O->{encoding} if $O->{encoding};
478              
479 0         0 return ($fh, $O, $C);
480             }
481              
482             sub _proc_rargs {
483 13 100   13   36 my $options = ref $_[-1] eq 'HASH' ? pop : {};
484 13         27 my ($fn, $filename_or_fh, $coli) = @_;
485              
486 13 50 33     31 croak "FATAL: invalid column ids" if defined $coli && ref $coli ne 'ARRAY';
487 13 50       22 croak "FATAL: invalid filename" unless defined $filename_or_fh;
488 13         36 my $C = { %$options }; # make a copy
489              
490             # get options related to this module the rest will be passed to Text::CSV_XS
491 13         36 my @keys = qw/ reshape_inc fetch_chunk type debug empty2bad text2bad header decimal_comma encoding detect_datetime /;
492 13         21 my $O = { map { $_ => delete $C->{$_} } @keys };
  130         212  
493 13   50     58 $O->{fetch_chunk} ||= 40_000;
494 13   50     41 $O->{reshape_inc} ||= 80_000;
495 13 100 66     50 $O->{type} ||= ($fn eq '1D' ? 'auto' : double);
496 13 100 100     273 $O->{header} ||= ($fn eq '1D' ? 'auto' : 0);
497 13         15 if (!NODATETIME) {
498             $O->{detect_datetime} = 1 if !defined $O->{detect_datetime};
499             if ($O->{detect_datetime} =~ /%/) {
500             $O->{strptime} = $O->{detect_datetime};
501             $O->{detect_datetime} = 1;
502             }
503             }
504 13 50       28 $O->{debug} = DEBUG unless defined $O->{debug};
505              
506             # reshape_inc cannot be lower than fetch_chunk
507 13 50       35 $O->{reshape_inc} = $O->{fetch_chunk} if $O->{reshape_inc} < $O->{fetch_chunk};
508              
509             # explicitely set column separator default
510 13 50       28 $C->{sep_char} = ',' unless defined $C->{sep_char};
511              
512             # empty2bad implies some Text::CSV_XS extra options
513 13 100       20 if ($O->{empty2bad}) {
514 5         9 $C->{blank_is_undef} = 1;
515 5         7 $C->{empty_is_undef} = 1;
516             }
517              
518 13 50 33     27 croak "FATAL: cannot use decimal_comma + sep_char ','" if $O->{decimal_comma} && $C->{sep_char} eq ',';
519              
520 13         14 my $fh;
521 13 50       30 if (openhandle($filename_or_fh)) {
522 0         0 $fh = $filename_or_fh;
523             }
524             else {
525 1 50   1   8 open $fh, "<", $filename_or_fh or croak "$filename_or_fh: $!";
  1         2  
  1         7  
  13         428  
526             }
527 13 50       937 binmode $fh, $O->{encoding} if $O->{encoding};
528              
529 13         58 return ($fh, $coli, $O, $C);
530             }
531              
532             sub _init_1D {
533 6     6   13 my ($coli, $firstline, $O) = @_;
534 6         10 my $colcount = scalar @$firstline;
535 6         5 my $cols;
536 6 50       43 if (!defined $coli) { # take all columns
537 6         10 $cols = $colcount;
538             }
539             else {
540 0         0 $cols = scalar @$coli;
541 0   0     0 ($_<0 || $_>$colcount) and croak "FATAL: invalid column '$_' (column count=$colcount)" for (@$coli);
      0        
542             }
543 6 50 33     26 croak "FATAL: invalid column count" unless $cols && $cols > 0 && $cols <= $colcount;
      33        
544              
545 6         26 my @c_type;
546             my @c_pack;
547 6         0 my @c_sizeof;
548 6         0 my @c_pdl;
549 6         0 my @c_bad;
550 6         0 my @c_dataref;
551 6         0 my @c_idx;
552              
553 6 100       14 if (ref $O->{type} eq 'ARRAY') {
554 1         6 $c_type[$_] = $O->{type}->[$_] for (0..$cols-1);
555             }
556             else {
557 5         23 $c_type[$_] = $O->{type} for (0..$cols-1);
558             }
559              
560 6         9 my @c_dt;
561 6         11 for (0..$cols-1) {
562 30 100 100     327 if (!defined $c_type[$_] || $c_type[$_] eq 'auto') {
    50          
    50          
563 16         22 $c_type[$_] = undef;
564 16 50       30 if ($O->{detect_datetime}) {
565 0         0 croak "PDL::DateTime not installed" if NODATETIME;
566 0 0       0 my $v = $O->{strptime} ? _strptime($firstline->[$_], $O->{strptime}) : PDL::DateTime::dt2ll($firstline->[$_]);
567 0 0       0 if (defined $v) {
568 0 0       0 $c_dt[$_] = $O->{strptime} ? $O->{strptime} : 'datetime';
569 0         0 $c_type[$_] = longlong;
570             }
571             }
572             }
573             elsif ($c_type[$_] eq 'datetime') {
574 0         0 croak "PDL::DateTime not installed" if NODATETIME;
575 0         0 $c_dt[$_] = 'datetime';
576 0         0 $c_type[$_] = longlong;
577             }
578             elsif ($c_type[$_] =~ /%/) {
579 0         0 $c_dt[$_] = $c_type[$_]; # strptime format
580 0         0 $c_type[$_] = longlong;
581             }
582 30 100       541 $c_type[$_] = double if !$c_type[$_];
583             }
584              
585 6         61 my $allocated = $O->{reshape_inc};
586 6         10 for (0..$cols-1) {
587 30 50       51 $c_type[$_] = double if !defined $c_type[$_];
588 30         73 $c_pack[$_] = $pck{$c_type[$_]};
589 30 50 100     438 croak "FATAL: your perl does not support 64bitint (avoid using type longlong)" if $c_pack[$_] eq 'q' && NO64BITINT;
590 30 50       44 croak "FATAL: invalid type '$c_type[$_]' for column $_" if !$c_pack[$_];
591 30         67 $c_sizeof[$_] = length pack($c_pack[$_], 1);
592 30 50       87 $c_pdl[$_] = $c_dt[$_] ? PDL::DateTime->new(zeroes(longlong, $allocated)) : zeroes($c_type[$_], $allocated);
593 30         16949 $c_dataref[$_] = $c_pdl[$_]->get_dataref;
594 30         78 $c_bad[$_] = $c_pdl[$_]->badvalue;
595 30         906 $c_idx[$_] = 0;
596 30         79 my $big = PDL::Core::howbig($c_pdl[$_]->get_datatype);
597 30 50       180 croak "FATAL: column $_ mismatch (type=$c_type[$_], sizeof=$c_sizeof[$_], big=$big)" if $big != $c_sizeof[$_];
598             }
599              
600 6 50       41 return (\@c_type, \@c_pack, \@c_sizeof, \@c_pdl, \@c_bad, \@c_dataref, \@c_idx, (@c_dt > 0 ? \@c_dt : undef), $allocated, $cols);
601             }
602              
603             sub _init_2D {
604 7     7   11 my ($coli, $colcount, $O) = @_;
605              
606 7         10 my $cols;
607 7 50       11 if (!defined $coli) { # take all columns
608 7         23 $cols = $colcount;
609             }
610             else {
611 0         0 $cols = scalar @$coli;
612 0   0     0 ($_<0 || $_>$colcount) and croak "FATAL: invalid column '$_' (column count=$colcount)" for (@$coli);
      0        
613             }
614 7 50 33     39 croak "FATAL: invalid column count" unless $cols && $cols > 0 && $cols <= $colcount;
      33        
615              
616 7         12 my $c_type = $O->{type};
617 7         23 my $c_pack = $pck{$c_type};
618 7 50 50     112 croak "FATAL: your perl does not support 64bitint (avoid using type longlong)" if $c_pack eq 'q' && NO64BITINT;
619 7 50       13 croak "FATAL: invalid type '$c_type' for column $_" if !$c_pack;
620              
621 7         15 my $allocated = $O->{reshape_inc};
622 7         19 my $c_sizeof = length pack($c_pack, 1);
623 7         20 my $c_pdl = zeroes($c_type, $cols, $allocated);
624 7         16148 my $c_dataref = $c_pdl->get_dataref;
625 7         22 my $c_bad = $c_pdl->badvalue;
626              
627 7         249 my $big = PDL::Core::howbig($c_pdl->get_datatype);
628 7 50       48 croak "FATAL: column $_ size mismatch (type=$c_type, sizeof=$c_sizeof, big=$big)" if $big != $c_sizeof;
629              
630 7         23 return ($c_type, $c_pack, $c_sizeof, $c_pdl, $c_bad, $c_dataref, $allocated, $cols);
631             }
632              
633             sub _strptime {
634 0     0     my ($string, $format) = @_;
635 0           return eval { int POSIX::floor(Time::Piece->strptime($string, $format)->epoch * 1_000_000 + 0.5) };
  0            
636             }
637              
638             1;
639              
640             __END__