File Coverage

blib/lib/Text/CSV_PP.pm
Criterion Covered Total %
statement 1537 1595 96.4
branch 1122 1226 91.5
condition 671 805 83.2
subroutine 118 118 100.0
pod 57 58 98.2
total 3505 3802 92.1


line stmt bran cond sub pod time code
1             package Text::CSV_PP;
2              
3             ################################################################################
4             #
5             # Text::CSV_PP - Text::CSV_XS compatible pure-Perl module
6             #
7             ################################################################################
8             require 5.006001;
9              
10 32     32   55912 use strict;
  32         65  
  32         833  
11 32     32   143 use Exporter ();
  32         51  
  32         618  
12 32     32   138 use vars qw($VERSION @ISA @EXPORT_OK);
  32         64  
  32         1569  
13 32     32   164 use Carp;
  32         72  
  32         11383  
14              
15             $VERSION = '2.00';
16             @ISA = qw(Exporter);
17             @EXPORT_OK = qw(csv);
18              
19 4     4 1 13 sub PV { 0 }
20 10     10 1 1188 sub IV { 1 }
21 8     8 1 29 sub NV { 2 }
22              
23             sub IS_QUOTED () { 0x0001; }
24             sub IS_BINARY () { 0x0002; }
25             sub IS_ERROR () { 0x0004; }
26             sub IS_MISSING () { 0x0010; }
27              
28             sub HOOK_ERROR () { 0x0001; }
29             sub HOOK_AFTER_PARSE () { 0x0002; }
30             sub HOOK_BEFORE_PRINT () { 0x0004; }
31              
32             sub useIO_EOF () { 0x0010; }
33              
34             my $ERRORS = {
35             # Generic errors
36             1000 => "INI - constructor failed",
37             1001 => "INI - sep_char is equal to quote_char or escape_char",
38             1002 => "INI - allow_whitespace with escape_char or quote_char SP or TAB",
39             1003 => "INI - \\r or \\n in main attr not allowed",
40             1004 => "INI - callbacks should be undef or a hashref",
41             1005 => "INI - EOL too long",
42             1006 => "INI - SEP too long",
43             1007 => "INI - QUOTE too long",
44             1008 => "INI - SEP undefined",
45              
46             1010 => "INI - the header is empty",
47             1011 => "INI - the header contains more than one valid separator",
48             1012 => "INI - the header contains an empty field",
49             1013 => "INI - the header contains nun-unique fields",
50             1014 => "INI - header called on undefined stream",
51              
52             # Syntax errors
53             1500 => "PRM - Invalid/unsupported arguments(s)",
54             1501 => "PRM - The key attribute is passed as an unsupported type",
55             1502 => "PRM - The value attribute is passed without the key attribute",
56             1503 => "PRM - The value attribute is passed as an unsupported type",
57              
58             # Parse errors
59             2010 => "ECR - QUO char inside quotes followed by CR not part of EOL",
60             2011 => "ECR - Characters after end of quoted field",
61             2012 => "EOF - End of data in parsing input stream",
62             2013 => "ESP - Specification error for fragments RFC7111",
63             2014 => "ENF - Inconsistent number of fields",
64              
65             # EIQ - Error Inside Quotes
66             2021 => "EIQ - NL char inside quotes, binary off",
67             2022 => "EIQ - CR char inside quotes, binary off",
68             2023 => "EIQ - QUO character not allowed",
69             2024 => "EIQ - EOF cannot be escaped, not even inside quotes",
70             2025 => "EIQ - Loose unescaped escape",
71             2026 => "EIQ - Binary character inside quoted field, binary off",
72             2027 => "EIQ - Quoted field not terminated",
73              
74             # EIF - Error Inside Field
75             2030 => "EIF - NL char inside unquoted verbatim, binary off",
76             2031 => "EIF - CR char is first char of field, not part of EOL",
77             2032 => "EIF - CR char inside unquoted, not part of EOL",
78             2034 => "EIF - Loose unescaped quote",
79             2035 => "EIF - Escaped EOF in unquoted field",
80             2036 => "EIF - ESC error",
81             2037 => "EIF - Binary character in unquoted field, binary off",
82              
83             # Combine errors
84             2110 => "ECB - Binary character in Combine, binary off",
85              
86             # IO errors
87             2200 => "EIO - print to IO failed. See errno",
88              
89             # Hash-Ref errors
90             3001 => "EHR - Unsupported syntax for column_names ()",
91             3002 => "EHR - getline_hr () called before column_names ()",
92             3003 => "EHR - bind_columns () and column_names () fields count mismatch",
93             3004 => "EHR - bind_columns () only accepts refs to scalars",
94             3006 => "EHR - bind_columns () did not pass enough refs for parsed fields",
95             3007 => "EHR - bind_columns needs refs to writable scalars",
96             3008 => "EHR - unexpected error in bound fields",
97             3009 => "EHR - print_hr () called before column_names ()",
98             3010 => "EHR - print_hr () called with invalid arguments",
99              
100             4001 => "PRM - The key does not exist as field in the data",
101              
102             0 => "",
103             };
104              
105             BEGIN {
106 32 50   32   350 if ( $] < 5.006 ) {
    50          
    50          
107 0 0       0 $INC{'bytes.pm'} = 1 unless $INC{'bytes.pm'}; # dummy
108 32     32   219 no strict 'refs';
  32         65  
  32         2848  
109 0         0 *{"utf8::is_utf8"} = sub { 0; };
  0         0  
  0         0  
110 0         0 *{"utf8::decode"} = sub { };
  0         0  
111             }
112             elsif ( $] < 5.008 ) {
113 32     32   210 no strict 'refs';
  32         60  
  32         8865  
114 0         0 *{"utf8::is_utf8"} = sub { 0; };
  0         0  
  0         0  
115 0         0 *{"utf8::decode"} = sub { };
  0         0  
116 0         0 *{"utf8::encode"} = sub { };
  0         0  
117             }
118             elsif ( !defined &utf8::is_utf8 ) {
119 0         0 require Encode;
120 0         0 *utf8::is_utf8 = *Encode::is_utf8;
121             }
122              
123 32         2160 eval q| require Scalar::Util |;
124 32 50       316404 if ( $@ ) {
125 0         0 eval q| require B |;
126 0 0       0 if ( $@ ) {
127 0         0 Carp::croak $@;
128             }
129             else {
130 0         0 my %tmap = qw(
131             B::NULL SCALAR
132             B::HV HASH
133             B::AV ARRAY
134             B::CV CODE
135             B::IO IO
136             B::GV GLOB
137             B::REGEXP REGEXP
138             );
139             *Scalar::Util::reftype = sub (\$) {
140 0         0 my $r = shift;
141 0 0       0 return undef unless length(ref($r));
142 0         0 my $t = ref(B::svref_2object($r));
143             return
144 0 0       0 exists $tmap{$t} ? $tmap{$t}
    0          
145             : length(ref($$r)) ? 'REF'
146             : 'SCALAR';
147 0         0 };
148             *Scalar::Util::readonly = sub (\$) {
149 0         0 my $b = B::svref_2object( $_[0] );
150 0         0 $b->FLAGS & 0x00800000; # SVf_READONLY?
151 0         0 };
152             }
153             }
154             }
155              
156             ################################################################################
157             #
158             # Common pure perl methods, taken almost directly from Text::CSV_XS.
159             # (These should be moved into a common class eventually, so that
160             # both XS and PP don't need to apply the same changes.)
161             #
162             ################################################################################
163              
164             ################################################################################
165             # version
166             ################################################################################
167              
168             sub version {
169 2     2 1 489 return $VERSION;
170             }
171              
172             ################################################################################
173             # new
174             ################################################################################
175              
176             my %def_attr = (
177             eol => '',
178             sep_char => ',',
179             quote_char => '"',
180             escape_char => '"',
181             binary => 0,
182             decode_utf8 => 1,
183             auto_diag => 0,
184             diag_verbose => 0,
185             strict => 0,
186             blank_is_undef => 0,
187             empty_is_undef => 0,
188             allow_whitespace => 0,
189             allow_loose_quotes => 0,
190             allow_loose_escapes => 0,
191             allow_unquoted_escape => 0,
192             always_quote => 0,
193             quote_empty => 0,
194             quote_space => 1,
195             quote_binary => 1,
196             escape_null => 1,
197             keep_meta_info => 0,
198             verbatim => 0,
199             formula => 0,
200             undef_str => undef,
201             types => undef,
202             callbacks => undef,
203              
204             _EOF => 0,
205             _RECNO => 0,
206             _STATUS => undef,
207             _FIELDS => undef,
208             _FFLAGS => undef,
209             _STRING => undef,
210             _ERROR_INPUT => undef,
211             _COLUMN_NAMES => undef,
212             _BOUND_COLUMNS => undef,
213             _AHEAD => undef,
214              
215             ENCODING => undef,
216             );
217              
218             my %attr_alias = (
219             quote_always => "always_quote",
220             verbose_diag => "diag_verbose",
221             quote_null => "escape_null",
222             escape => "escape_char",
223             );
224              
225             my $last_new_error = Text::CSV_PP->SetDiag(0);
226             my $last_error;
227              
228             # NOT a method: is also used before bless
229             sub _unhealthy_whitespace {
230 15450     15450   25639 my ($self, $aw) = @_;
231 15450 100       41771 $aw or return 0; # no checks needed without allow_whitespace
232              
233 3567         5266 my $quo = $self->{quote};
234 3567 100 100     8437 defined $quo && length ($quo) or $quo = $self->{quote_char};
235 3567         4839 my $esc = $self->{escape_char};
236              
237 3567 100 100     15416 defined $quo && $quo =~ m/^[ \t]/ and return 1002;
238 3325 100 100     10953 defined $esc && $esc =~ m/^[ \t]/ and return 1002;
239              
240 3035         7074 return 0;
241             }
242              
243             sub _check_sanity {
244 12144     12144   16541 my $self = shift;
245              
246 12144         17998 my $eol = $self->{eol};
247 12144         17713 my $sep = $self->{sep};
248 12144 100 100     29156 defined $sep && length ($sep) or $sep = $self->{sep_char};
249 12144         17958 my $quo = $self->{quote};
250 12144 100 100     26082 defined $quo && length ($quo) or $quo = $self->{quote_char};
251 12144         16609 my $esc = $self->{escape_char};
252              
253             # use DP;::diag ("SEP: '", DPeek ($sep),
254             # "', QUO: '", DPeek ($quo),
255             # "', ESC: '", DPeek ($esc),"'");
256              
257             # sep_char should not be undefined
258 12144 100       22595 $sep ne "" or return 1008;
259 12142 100       24320 length ($sep) > 16 and return 1006;
260 12141 100       35027 $sep =~ m/[\r\n]/ and return 1003;
261              
262 12135 100       22997 if (defined $quo) {
263 12126 100       21494 $quo eq $sep and return 1001;
264 11898 100       21389 length ($quo) > 16 and return 1007;
265 11897 100       21832 $quo =~ m/[\r\n]/ and return 1003;
266             }
267 11900 100       20045 if (defined $esc) {
268 11890 100       23282 $esc eq $sep and return 1001;
269 11722 100       22083 $esc =~ m/[\r\n]/ and return 1003;
270             }
271 11726 100       19853 if (defined $eol) {
272 11722 100       19719 length ($eol) > 16 and return 1005;
273             }
274              
275 11725         23911 return _unhealthy_whitespace ($self, $self->{allow_whitespace});
276             }
277              
278             sub known_attributes {
279 3     3 1 527 sort grep !m/^_/ => "sep", "quote", keys %def_attr;
280             }
281              
282             sub new {
283 789     789 1 3252 $last_new_error = Text::CSV_PP->SetDiag(1000,
284             'usage: my $csv = Text::CSV_PP->new ([{ option => value, ... }]);');
285              
286 789         1433 my $proto = shift;
287 789 100 66     2802 my $class = ref ($proto) || $proto or return;
288 788 100 100     3205 @_ > 0 && ref $_[0] ne "HASH" and return;
289 780   100     1860 my $attr = shift || {};
290             my %attr = map {
291 780 100       2448 my $k = m/^[a-zA-Z]\w+$/ ? lc $_ : $_;
  1850         6554  
292 1850 100       3754 exists $attr_alias{$k} and $k = $attr_alias{$k};
293 1850         4745 $k => $attr->{$_};
294             } keys %$attr;
295              
296 780         1552 my $sep_aliased = 0;
297 780 100       1633 if (exists $attr{sep}) {
298 7         16 $attr{sep_char} = delete $attr{sep};
299 7         14 $sep_aliased = 1;
300             }
301 780         1080 my $quote_aliased = 0;
302 780 100       1494 if (exists $attr{quote}) {
303 25         48 $attr{quote_char} = delete $attr{quote};
304 25         36 $quote_aliased = 1;
305             }
306             exists $attr{formula_handling} and
307 780 100       1453 $attr{formula} = delete $attr{formula_handling};
308             exists $attr{formula} and
309 780 100       1469 $attr{formula} = _supported_formula (undef, $attr{formula});
310 779         1795 for (keys %attr) {
311 1849 100 100     6096 if (m/^[a-z]/ && exists $def_attr{$_}) {
312             # uncoverable condition false
313 1842 100 100     5595 defined $attr{$_} && m/_char$/ and utf8::decode ($attr{$_});
314 1842         2711 next;
315             }
316             # croak?
317 7         26 $last_new_error = Text::CSV_PP->SetDiag(1000, "INI - Unknown attribute '$_'");
318 7 100       19 $attr{auto_diag} and error_diag ();
319 7         29 return;
320             }
321 772 100       1612 if ($sep_aliased) {
322 7         43 my @b = unpack "U0C*", $attr{sep_char};
323 7 100       23 if (@b > 1) {
324 6         13 $attr{sep} = $attr{sep_char};
325 6         16 $attr{sep_char} = "\0";
326             }
327             else {
328 1         4 $attr{sep} = undef;
329             }
330             }
331 772 100 100     1749 if ($quote_aliased and defined $attr{quote_char}) {
332 21         72 my @b = unpack "U0C*", $attr{quote_char};
333 21 100       44 if (@b > 1) {
334 7         17 $attr{quote} = $attr{quote_char};
335 7         16 $attr{quote_char} = "\0";
336             }
337             else {
338 14         24 $attr{quote} = undef;
339             }
340             }
341              
342 772         12503 my $self = { %def_attr, %attr };
343 772 100       2639 if (my $ec = _check_sanity ($self)) {
344 35         64 $last_new_error = Text::CSV_PP->SetDiag($ec);
345 35 100       68 $attr{auto_diag} and error_diag ();
346 35         182 return;
347             }
348 737 100 100     2228 if (defined $self->{callbacks} && ref $self->{callbacks} ne "HASH") {
349 6         878 Carp::carp "The 'callbacks' attribute is set but is not a hash: ignored\n";
350 6         264 $self->{callbacks} = undef;
351             }
352              
353 737         1686 $last_new_error = Text::CSV_PP->SetDiag(0);
354 737 100 100     2196 defined $\ && !exists $attr{eol} and $self->{eol} = $\;
355 737         1212 bless $self, $class;
356 737 100       1697 defined $self->{types} and $self->types ($self->{types});
357 737         2978 $self;
358             }
359              
360             # Keep in sync with XS!
361             my %_cache_id = ( # Only expose what is accessed from within PM
362             quote_char => 0,
363             escape_char => 1,
364             sep_char => 2,
365             sep => 39, # 39 .. 55
366             binary => 3,
367             keep_meta_info => 4,
368             always_quote => 5,
369             allow_loose_quotes => 6,
370             allow_loose_escapes => 7,
371             allow_unquoted_escape => 8,
372             allow_whitespace => 9,
373             blank_is_undef => 10,
374             eol => 11,
375             quote => 15,
376             verbatim => 22,
377             empty_is_undef => 23,
378             auto_diag => 24,
379             diag_verbose => 33,
380             quote_space => 25,
381             quote_empty => 37,
382             quote_binary => 32,
383             escape_null => 31,
384             decode_utf8 => 35,
385             _has_ahead => 30,
386             _has_hooks => 36,
387             _is_bound => 26, # 26 .. 29
388             formula => 38,
389             strict => 42,
390             undef_str => 46,
391             );
392              
393             my %_hidden_cache_id = qw(
394             sep_len 38
395             eol_len 12
396             eol_is_cr 13
397             quo_len 16
398             has_error_input 34
399             );
400              
401             my %_reverse_cache_id = (
402             map({$_cache_id{$_} => $_} keys %_cache_id),
403             map({$_hidden_cache_id{$_} => $_} keys %_hidden_cache_id),
404             );
405              
406             # A `character'
407             sub _set_attr_C {
408 11073     11073   22130 my ($self, $name, $val, $ec) = @_;
409 11073 100       21465 defined $val or $val = 0;
410 11073         26346 utf8::decode ($val);
411 11073         18096 $self->{$name} = $val;
412 11073 100       19563 $ec = _check_sanity ($self) and croak ($self->SetDiag ($ec));
413 10163         23916 $self->_cache_set ($_cache_id{$name}, $val);
414             }
415              
416             # A flag
417             sub _set_attr_X {
418 5642     5642   10553 my ($self, $name, $val) = @_;
419 5642 100       10461 defined $val or $val = 0;
420 5642         9533 $self->{$name} = $val;
421 5642         14002 $self->_cache_set ($_cache_id{$name}, 0 + $val);
422             }
423              
424             # A number
425             sub _set_attr_N {
426 36     36   90 my ($self, $name, $val) = @_;
427 36         71 $self->{$name} = $val;
428 36         160 $self->_cache_set ($_cache_id{$name}, 0 + $val);
429             }
430              
431             # Accessor methods.
432             # It is unwise to change them halfway through a single file!
433             sub quote_char {
434 4835     4835 1 662492 my $self = shift;
435 4835 100       11565 if (@_) {
436 3600         8707 $self->_set_attr_C ("quote_char", shift);
437 3373         6278 $self->_cache_set ($_cache_id{quote}, "");
438             }
439 4608         14490 $self->{quote_char};
440             }
441              
442             sub quote {
443 20     20 1 44 my $self = shift;
444 20 100       67 if (@_) {
445 11         20 my $quote = shift;
446 11 100       25 defined $quote or $quote = "";
447 11         29 utf8::decode ($quote);
448 11         43 my @b = unpack "U0C*", $quote;
449 11 100       28 if (@b > 1) {
450 5 100       17 @b > 16 and croak ($self->SetDiag (1007));
451 4         63 $self->quote_char ("\0");
452             }
453             else {
454 6         14 $self->quote_char ($quote);
455 6         9 $quote = "";
456             }
457 10         17 $self->{quote} = $quote;
458              
459 10         17 my $ec = _check_sanity ($self);
460 10 100       21 $ec and croak ($self->SetDiag ($ec));
461              
462 9         19 $self->_cache_set ($_cache_id{quote}, $quote);
463             }
464 18         33 my $quote = $self->{quote};
465 18 100 100     105 defined $quote && length ($quote) ? $quote : $self->{quote_char};
466             }
467              
468             sub escape_char {
469 4826     4826 1 663483 my $self = shift;
470 4826 100       10912 if (@_) {
471 3594         4993 my $ec = shift;
472 3594         8375 $self->_set_attr_C ("escape_char", $ec);
473 3479 100       7526 $ec or $self->_set_attr_X ("escape_null", 0);
474             }
475 4711         15779 $self->{escape_char};
476             }
477              
478             sub sep_char {
479 5122     5122 1 659891 my $self = shift;
480 5122 100       11736 if (@_) {
481 3879         9139 $self->_set_attr_C ("sep_char", shift);
482 3311         6455 $self->_cache_set ($_cache_id{sep}, "");
483             }
484 4554         14045 $self->{sep_char};
485             }
486              
487             sub sep {
488 325     325 1 3246 my $self = shift;
489 325 100       615 if (@_) {
490 293         458 my $sep = shift;
491 293 100       511 defined $sep or $sep = "";
492 293         767 utf8::decode ($sep);
493 293         1007 my @b = unpack "U0C*", $sep;
494 293 100       577 if (@b > 1) {
495 13 100       59 @b > 16 and croak ($self->SetDiag (1006));
496 12         56 $self->sep_char ("\0");
497             }
498             else {
499 280         626 $self->sep_char ($sep);
500 277         342 $sep = "";
501             }
502 289         565 $self->{sep} = $sep;
503              
504 289         421 my $ec = _check_sanity ($self);
505 289 100       544 $ec and croak ($self->SetDiag ($ec));
506              
507 288         539 $self->_cache_set ($_cache_id{sep}, $sep);
508             }
509 320         432 my $sep = $self->{sep};
510 320 100 100     1158 defined $sep && length ($sep) ? $sep : $self->{sep_char};
511             }
512              
513             sub eol {
514 157     157 1 3763 my $self = shift;
515 157 100       359 if (@_) {
516 125         200 my $eol = shift;
517 125 100       246 defined $eol or $eol = "";
518 125 100       303 length ($eol) > 16 and croak ($self->SetDiag (1005));
519 124         229 $self->{eol} = $eol;
520 124         281 $self->_cache_set ($_cache_id{eol}, $eol);
521             }
522 156         318 $self->{eol};
523             }
524              
525             sub always_quote {
526 3033     3033 1 670412 my $self = shift;
527 3033 100       8343 @_ and $self->_set_attr_X ("always_quote", shift);
528 3033         8122 $self->{always_quote};
529             }
530              
531             sub quote_space {
532 10     10 1 26 my $self = shift;
533 10 100       33 @_ and $self->_set_attr_X ("quote_space", shift);
534 10         33 $self->{quote_space};
535             }
536              
537             sub quote_empty {
538 5     5 1 10 my $self = shift;
539 5 100       16 @_ and $self->_set_attr_X ("quote_empty", shift);
540 5         17 $self->{quote_empty};
541             }
542              
543             sub escape_null {
544 6     6 1 9 my $self = shift;
545 6 100       19 @_ and $self->_set_attr_X ("escape_null", shift);
546 6         21 $self->{escape_null};
547             }
548              
549 3     3 0 9 sub quote_null { goto &escape_null; }
550              
551             sub quote_binary {
552 7     7 1 17 my $self = shift;
553 7 100       25 @_ and $self->_set_attr_X ("quote_binary", shift);
554 7         26 $self->{quote_binary};
555             }
556              
557             sub binary {
558 21     21 1 2460 my $self = shift;
559 21 100       93 @_ and $self->_set_attr_X ("binary", shift);
560 21         49 $self->{binary};
561             }
562              
563             sub strict {
564 2     2 1 4 my $self = shift;
565 2 100       6 @_ and $self->_set_attr_X ("strict", shift);
566 2         7 $self->{strict};
567             }
568              
569             sub _SetDiagInfo {
570 16     16   36 my ($self, $err, $msg) = @_;
571 16         45 $self->SetDiag ($err);
572 16         42 my $em = $self->error_diag;
573 16 50       37 $em =~ s/^\d+$// and $msg =~ s/^/# /;
574 16 100       30 my $sep = $em =~ m/[;\n]$/ ? "\n\t" : ": ";
575 16         35 join $sep => grep m/\S\S\S/ => $em, $msg;
576             }
577              
578             sub _supported_formula {
579 96     96   173 my ($self, $f) = @_;
580 96 100       188 defined $f or return 5;
581             $f =~ m/^(?: 0 | none )$/xi ? 0 :
582             $f =~ m/^(?: 1 | die )$/xi ? 1 :
583             $f =~ m/^(?: 2 | croak )$/xi ? 2 :
584             $f =~ m/^(?: 3 | diag )$/xi ? 3 :
585             $f =~ m/^(?: 4 | empty | )$/xi ? 4 :
586 95 100       809 $f =~ m/^(?: 5 | undef )$/xi ? 5 : do {
    100          
    100          
    100          
    100          
    100          
587 8   100     24 $self ||= "Text::CSV_PP";
588 8         37 croak ($self->_SetDiagInfo (1500, "formula-handling '$f' is not supported"));
589             };
590             }
591              
592             sub formula {
593 43     43 1 3762 my $self = shift;
594 43 100       146 @_ and $self->_set_attr_N ("formula", _supported_formula ($self, shift));
595 36         117 [qw( none die croak diag empty undef )]->[_supported_formula ($self, $self->{formula})];
596             }
597             sub formula_handling {
598 7     7 1 14 my $self = shift;
599 7         18 $self->formula (@_);
600             }
601              
602             sub decode_utf8 {
603 2     2 1 4 my $self = shift;
604 2 100       7 @_ and $self->_set_attr_X ("decode_utf8", shift);
605 2         7 $self->{decode_utf8};
606             }
607              
608             sub keep_meta_info {
609 12     12 1 137 my $self = shift;
610 12 100       36 if (@_) {
611 11         17 my $v = shift;
612 11 100 100     55 !defined $v || $v eq "" and $v = 0;
613 11 100       54 $v =~ m/^[0-9]/ or $v = lc $v eq "false" ? 0 : 1; # true/truth = 1
    100          
614 11         33 $self->_set_attr_X ("keep_meta_info", $v);
615             }
616 12         55 $self->{keep_meta_info};
617             }
618              
619             sub allow_loose_quotes {
620 12     12 1 24 my $self = shift;
621 12 100       45 @_ and $self->_set_attr_X ("allow_loose_quotes", shift);
622 12         23 $self->{allow_loose_quotes};
623             }
624              
625             sub allow_loose_escapes {
626 12     12 1 1233 my $self = shift;
627 12 100       59 @_ and $self->_set_attr_X ("allow_loose_escapes", shift);
628 12         29 $self->{allow_loose_escapes};
629             }
630              
631             sub allow_whitespace {
632 4954     4954 1 1837660 my $self = shift;
633 4954 100       12682 if (@_) {
634 3725         5227 my $aw = shift;
635 3725 100       7441 _unhealthy_whitespace ($self, $aw) and
636             croak ($self->SetDiag (1002));
637 3721         8448 $self->_set_attr_X ("allow_whitespace", $aw);
638             }
639 4950         16074 $self->{allow_whitespace};
640             }
641              
642             sub allow_unquoted_escape {
643 4     4 1 9 my $self = shift;
644 4 100       25 @_ and $self->_set_attr_X ("allow_unquoted_escape", shift);
645 4         11 $self->{allow_unquoted_escape};
646             }
647              
648             sub blank_is_undef {
649 3     3 1 7 my $self = shift;
650 3 100       15 @_ and $self->_set_attr_X ("blank_is_undef", shift);
651 3         9 $self->{blank_is_undef};
652             }
653              
654             sub empty_is_undef {
655 2     2 1 4 my $self = shift;
656 2 100       6 @_ and $self->_set_attr_X ("empty_is_undef", shift);
657 2         8 $self->{empty_is_undef};
658             }
659              
660             sub verbatim {
661 9     9 1 5205 my $self = shift;
662 9 100       38 @_ and $self->_set_attr_X ("verbatim", shift);
663 9         22 $self->{verbatim};
664             }
665              
666             sub undef_str {
667 12     12 1 3267 my $self = shift;
668 12 100       31 if (@_) {
669 11         22 my $v = shift;
670 11 100       42 $self->{undef_str} = defined $v ? "$v" : undef;
671 11         26 $self->_cache_set ($_cache_id{undef_str}, $self->{undef_str});
672             }
673 12         43 $self->{undef_str};
674             }
675              
676             sub auto_diag {
677 12     12 1 1658 my $self = shift;
678 12 100       31 if (@_) {
679 9         14 my $v = shift;
680 9 100 100     45 !defined $v || $v eq "" and $v = 0;
681 9 100       39 $v =~ m/^[0-9]/ or $v = lc $v eq "false" ? 0 : 1; # true/truth = 1
    100          
682 9         22 $self->_set_attr_X ("auto_diag", $v);
683             }
684 12         51 $self->{auto_diag};
685             }
686              
687             sub diag_verbose {
688 10     10 1 565 my $self = shift;
689 10 100       23 if (@_) {
690 8         13 my $v = shift;
691 8 100 100     39 !defined $v || $v eq "" and $v = 0;
692 8 100       36 $v =~ m/^[0-9]/ or $v = lc $v eq "false" ? 0 : 1; # true/truth = 1
    100          
693 8         20 $self->_set_attr_X ("diag_verbose", $v);
694             }
695 10         38 $self->{diag_verbose};
696             }
697              
698             ################################################################################
699             # status
700             ################################################################################
701              
702             sub status {
703 5     5 1 18 $_[0]->{_STATUS};
704             }
705              
706             sub eof {
707 33     33 1 790 $_[0]->{_EOF};
708             }
709              
710             sub types {
711 7     7 1 1982 my $self = shift;
712              
713 7 100       18 if (@_) {
714 2 100       8 if (my $types = shift) {
715 1         3 $self->{'_types'} = join("", map{ chr($_) } @$types);
  3         13  
716 1         5 $self->{'types'} = $types;
717             }
718             else {
719 1         5 delete $self->{'types'};
720 1         2 delete $self->{'_types'};
721 1         5 undef;
722             }
723             }
724             else {
725 5         28 $self->{'types'};
726             }
727             }
728              
729             sub callbacks {
730 72     72 1 19988 my $self = shift;
731 72 100       198 if (@_) {
732 42         62 my $cb;
733 42         53 my $hf = 0x00;
734 42 100       102 if (defined $_[0]) {
    100          
735 40 100       73 grep { !defined } @_ and croak ($self->SetDiag (1004));
  71         172  
736 38 100 100     194 $cb = @_ == 1 && ref $_[0] eq "HASH" ? shift
    100          
737             : @_ % 2 == 0 ? { @_ }
738             : croak ($self->SetDiag (1004));
739 33         103 foreach my $cbk (keys %$cb) {
740             # A key cannot be a ref. That would be stored as the *string
741             # 'SCALAR(0x1f3e710)' or 'ARRAY(0x1a5ae18)'
742 35 100 100     262 $cbk =~ m/^[\w.]+$/ && ref $cb->{$cbk} eq "CODE" or
743             croak ($self->SetDiag (1004));
744             }
745 19 100       60 exists $cb->{error} and $hf |= 0x01;
746 19 100       45 exists $cb->{after_parse} and $hf |= 0x02;
747 19 100       39 exists $cb->{before_print} and $hf |= 0x04;
748             }
749             elsif (@_ > 1) {
750             # (undef, whatever)
751 1         4 croak ($self->SetDiag (1004));
752             }
753 20         71 $self->_set_attr_X ("_has_hooks", $hf);
754 20         42 $self->{callbacks} = $cb;
755             }
756 50         149 $self->{callbacks};
757             }
758              
759             ################################################################################
760             # error_diag
761             ################################################################################
762              
763             sub error_diag {
764 1662     1662 1 34919 my $self = shift;
765 1662         4803 my @diag = (0 + $last_new_error, $last_new_error, 0, 0, 0);
766              
767             # Docs state to NEVER use UNIVERSAL::isa, because it will *never* call an
768             # overridden isa method in any class. Well, that is exacly what I want here
769 1662 100 100     14498 if ($self && ref $self && # Not a class method or direct call
      100        
      100        
770             UNIVERSAL::isa ($self, __PACKAGE__) && exists $self->{_ERROR_DIAG}) {
771 1489         3162 $diag[0] = 0 + $self->{_ERROR_DIAG};
772 1489         2823 $diag[1] = $self->{_ERROR_DIAG};
773 1489 100       3197 $diag[2] = 1 + $self->{_ERROR_POS} if exists $self->{_ERROR_POS};
774 1489         2435 $diag[3] = $self->{_RECNO};
775 1489 100       2978 $diag[4] = $self->{_ERROR_FLD} if exists $self->{_ERROR_FLD};
776              
777             $diag[0] && $self->{callbacks} && $self->{callbacks}{error} and
778 1489 100 100     5695 return $self->{callbacks}{error}->(@diag);
      100        
779             }
780              
781 1659         2682 my $context = wantarray;
782              
783 1659 100       3857 unless (defined $context) { # Void context, auto-diag
784 246 100 100     836 if ($diag[0] && $diag[0] != 2012) {
785 12         45 my $msg = "# CSV_PP ERROR: $diag[0] - $diag[1] \@ rec $diag[3] pos $diag[2]\n";
786 12 100       72 $diag[4] and $msg =~ s/$/ field $diag[4]/;
787              
788 12 100 100     51 unless ($self && ref $self) { # auto_diag
789             # called without args in void context
790 4         38 warn $msg;
791 4         29 return;
792             }
793              
794 8 50 66     32 if ($self->{diag_verbose} and $self->{_ERROR_INPUT}) {
795 2         5 $msg .= "$self->{_ERROR_INPUT}'\n";
796 2         8 $msg .= " " x ($diag[2] - 1);
797 2         3 $msg .= "^\n";
798             }
799              
800 8         16 my $lvl = $self->{auto_diag};
801 8 100       21 if ($lvl < 2) {
802 7         47 my @c = caller (2);
803 7 50 66     50 if (@c >= 11 && $c[10] && ref $c[10] eq "HASH") {
      33        
804 0         0 my $hints = $c[10];
805             (exists $hints->{autodie} && $hints->{autodie} or
806             exists $hints->{"guard Fatal"} &&
807 0 0 0     0 !exists $hints->{"no Fatal"}) and
      0        
      0        
808             $lvl++;
809             # Future releases of autodie will probably set $^H{autodie}
810             # to "autodie @args", like "autodie :all" or "autodie open"
811             # so we can/should check for "open" or "new"
812             }
813             }
814 8 100       89 $lvl > 1 ? die $msg : warn $msg;
815             }
816 241         546 return;
817             }
818              
819 1413 100       4496 return $context ? @diag : $diag[1];
820             }
821              
822             sub record_number {
823 3     3 1 10 return shift->{_RECNO};
824             }
825              
826             ################################################################################
827             # string
828             ################################################################################
829              
830             *string = \&_string;
831             sub _string {
832 1401 100   1401   376183 defined $_[0]->{_STRING} ? ${ $_[0]->{_STRING} } : undef;
  1400         5850  
833             }
834              
835             ################################################################################
836             # fields
837             ################################################################################
838              
839             *fields = \&_fields;
840             sub _fields {
841 1594 100   1594   26824 ref($_[0]->{_FIELDS}) ? @{$_[0]->{_FIELDS}} : undef;
  1593         10100  
842             }
843              
844             ################################################################################
845             # meta_info
846             ################################################################################
847              
848             sub meta_info {
849 21 100   21 1 567 $_[0]->{_FFLAGS} ? @{ $_[0]->{_FFLAGS} } : undef;
  16         54  
850             }
851              
852             sub is_quoted {
853 29 100   29 1 94 return unless (defined $_[0]->{_FFLAGS});
854 26 100 66     121 return if( $_[1] =~ /\D/ or $_[1] < 0 or $_[1] > $#{ $_[0]->{_FFLAGS} } );
  25   100     73  
855              
856 24 100       87 $_[0]->{_FFLAGS}->[$_[1]] & IS_QUOTED ? 1 : 0;
857             }
858              
859             sub is_binary {
860 11 100   11 1 39 return unless (defined $_[0]->{_FFLAGS});
861 10 100 66     64 return if( $_[1] =~ /\D/ or $_[1] < 0 or $_[1] > $#{ $_[0]->{_FFLAGS} } );
  9   100     36  
862 8 100       47 $_[0]->{_FFLAGS}->[$_[1]] & IS_BINARY ? 1 : 0;
863             }
864              
865             sub is_missing {
866 19     19 1 43 my ($self, $idx, $val) = @_;
867 19 100       69 return unless $self->{keep_meta_info}; # FIXME
868 13 100 100     93 $idx < 0 || !ref $self->{_FFLAGS} and return;
869 11 100       18 $idx >= @{$self->{_FFLAGS}} and return 1;
  11         26  
870 10 100       54 $self->{_FFLAGS}[$idx] & IS_MISSING ? 1 : 0;
871             }
872              
873             ################################################################################
874             # combine
875             ################################################################################
876             *combine = \&_combine;
877             sub _combine {
878 1399     1399   711925 my ($self, @fields) = @_;
879 1399         2822 my $str = "";
880 1399         4858 $self->{_FIELDS} = \@fields;
881 1399   100     6794 $self->{_STATUS} = (@fields > 0) && $self->__combine(\$str, \@fields, 0);
882 1395         3214 $self->{_STRING} = \$str;
883 1395         4089 $self->{_STATUS};
884             }
885              
886             ################################################################################
887             # parse
888             ################################################################################
889             *parse = \&_parse;
890             sub _parse {
891 1933     1933   96933 my ($self, $str) = @_;
892              
893 1933 100       4853 ref $str and croak ($self->SetDiag (1500));
894              
895 1929         3295 my $fields = [];
896 1929         3202 my $fflags = [];
897 1929         4110 $self->{_STRING} = \$str;
898 1929 100 100     6789 if (defined $str && $self->__parse ($fields, $fflags, $str, 0)) {
899 1719         4506 $self->{_FIELDS} = $fields;
900 1719         2926 $self->{_FFLAGS} = $fflags;
901 1719         2935 $self->{_STATUS} = 1;
902             }
903             else {
904 207         413 $self->{_FIELDS} = undef;
905 207         336 $self->{_FFLAGS} = undef;
906 207         333 $self->{_STATUS} = 0;
907             }
908 1926         8900 $self->{_STATUS};
909             }
910              
911             sub column_names {
912 925     925 1 45507 my ( $self, @columns ) = @_;
913              
914 925 100       2149 @columns or return defined $self->{_COLUMN_NAMES} ? @{$self->{_COLUMN_NAMES}} : ();
  266 100       994  
915 616 100 100     2039 @columns == 1 && ! defined $columns[0] and return $self->{_COLUMN_NAMES} = undef;
916              
917 480 100 100     1532 if ( @columns == 1 && ref $columns[0] eq "ARRAY" ) {
    100          
918 192         272 @columns = @{ $columns[0] };
  192         406  
919             }
920 590 100       1659 elsif ( join "", map { defined $_ ? ref $_ : "" } @columns ) {
921 5         17 croak $self->SetDiag( 3001 );
922             }
923              
924 475 100 100     1139 if ( $self->{_BOUND_COLUMNS} && @columns != @{$self->{_BOUND_COLUMNS}} ) {
  2         9  
925 1         4 croak $self->SetDiag( 3003 );
926             }
927              
928 474 100       648 $self->{_COLUMN_NAMES} = [ map { defined $_ ? $_ : "\cAUNDEF\cA" } @columns ];
  1036         2168  
929 474         674 @{ $self->{_COLUMN_NAMES} };
  474         1097  
930             }
931              
932             sub header {
933 297     297 1 35782 my ($self, $fh, @args) = @_;
934              
935 297 100       907 $fh or croak ($self->SetDiag (1014));
936              
937 296         431 my (@seps, %args);
938 296         524 for (@args) {
939 191 100       372 if (ref $_ eq "ARRAY") {
940 18         41 push @seps, @$_;
941 18         30 next;
942             }
943 173 100       312 if (ref $_ eq "HASH") {
944 172         381 %args = %$_;
945 172         285 next;
946             }
947 1         206 croak (q{usage: $csv->header ($fh, [ seps ], { options })});
948             }
949              
950             defined $args{munge} && !defined $args{munge_column_names} and
951 295 50 33     692 $args{munge_column_names} = $args{munge}; # munge as alias
952 295 100       675 defined $args{detect_bom} or $args{detect_bom} = 1;
953 295 100       527 defined $args{set_column_names} or $args{set_column_names} = 1;
954 295 100       647 defined $args{munge_column_names} or $args{munge_column_names} = "lc";
955              
956             # Reset any previous leftovers
957 295         431 $self->{_RECNO} = 0;
958 295         461 $self->{_AHEAD} = undef;
959 295 100       543 $self->{_COLUMN_NAMES} = undef if $args{set_column_names};
960 295 100       547 $self->{_BOUND_COLUMNS} = undef if $args{set_column_names};
961 295         760 $self->_cache_set($_cache_id{'_has_ahead'}, 0);
962              
963 295 100       522 if (defined $args{sep_set}) {
964 11 100       31 ref $args{sep_set} eq "ARRAY" or
965             croak ($self->_SetDiagInfo (1500, "sep_set should be an array ref"));
966 6         10 @seps = @{$args{sep_set}};
  6         15  
967             }
968              
969 290 50       762 $^O eq "MSWin32" and binmode $fh;
970 290         3799 my $hdr = <$fh>;
971             # check if $hdr can be empty here, I don't think so
972 290 100 66     1356 defined $hdr && $hdr ne "" or croak ($self->SetDiag (1010));
973              
974 288         400 my %sep;
975 288 100       818 @seps or @seps = (",", ";");
976 288         534 foreach my $sep (@seps) {
977 672 100       1593 index ($hdr, $sep) >= 0 and $sep{$sep}++;
978             }
979              
980 288 100       539 keys %sep >= 2 and croak ($self->SetDiag (1011));
981              
982 287         988 $self->sep (keys %sep);
983 287         403 my $enc = "";
984 287 100       548 if ($args{detect_bom}) { # UTF-7 is not supported
985 286 100       2275 if ($hdr =~ s/^\x00\x00\xfe\xff//) { $enc = "utf-32be" }
  24 100       40  
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
986 24         52 elsif ($hdr =~ s/^\xff\xfe\x00\x00//) { $enc = "utf-32le" }
987 25         37 elsif ($hdr =~ s/^\xfe\xff//) { $enc = "utf-16be" }
988 24         42 elsif ($hdr =~ s/^\xff\xfe//) { $enc = "utf-16le" }
989 48         86 elsif ($hdr =~ s/^\xef\xbb\xbf//) { $enc = "utf-8" }
990 1         2 elsif ($hdr =~ s/^\xf7\x64\x4c//) { $enc = "utf-1" }
991 1         2 elsif ($hdr =~ s/^\xdd\x73\x66\x73//) { $enc = "utf-ebcdic" }
992 1         2 elsif ($hdr =~ s/^\x0e\xfe\xff//) { $enc = "scsu" }
993 1         2 elsif ($hdr =~ s/^\xfb\xee\x28//) { $enc = "bocu-1" }
994 1         2 elsif ($hdr =~ s/^\x84\x31\x95\x33//) { $enc = "gb-18030" }
995 36         61 elsif ($hdr =~ s/^\x{feff}//) { $enc = "" }
996              
997 286         607 $self->{ENCODING} = uc $enc;
998              
999 286 100       530 $hdr eq "" and croak ($self->SetDiag (1010));
1000              
1001 280 100       426 if ($enc) {
1002 144 100       433 if ($enc =~ m/([13]).le$/) {
1003 48         138 my $l = 0 + $1;
1004 48         59 my $x;
1005 48         101 $hdr .= "\0" x $l;
1006 48         154 read $fh, $x, $l;
1007             }
1008 144 100       298 if ($enc ne "utf-8") {
1009 96         484 require Encode;
1010 96         601 $hdr = Encode::decode ($enc, $hdr);
1011             }
1012 144         5308 binmode $fh, ":encoding($enc)";
1013             }
1014             }
1015              
1016 281         7482 my ($ahead, $eol);
1017 281 100       1753 if ($hdr =~ s/^([^\r\n]+)([\r\n]+)([^\r\n].+)\z/$1/s) {
1018 142         355 $eol = $2;
1019 142         278 $ahead = $3;
1020             }
1021              
1022 281 100       833 $args{munge_column_names} eq "lc" and $hdr = lc $hdr;
1023 281 100       489 $args{munge_column_names} eq "uc" and $hdr = uc $hdr;
1024              
1025 281         358 my $hr = \$hdr; # Will cause croak on perl-5.6.x
1026 281 50       2618 open my $h, "<", $hr or croak ($self->SetDiag (1010));
1027              
1028 281 100       1528 my $row = $self->getline ($h) or croak;
1029 279         712 close $h;
1030              
1031 279 100       465 if ($ahead) { # Must be after getline, which creates the cache
1032 142         421 $self->_cache_set ($_cache_id{_has_ahead}, 1);
1033 142         192 $self->{_AHEAD} = $ahead;
1034 142 100       584 $eol =~ m/^\r([^\n]|\z)/ and $self->eol ($eol);
1035             }
1036              
1037 279         582 my @hdr = @$row;
1038             ref $args{munge_column_names} eq "CODE" and
1039 279 100       584 @hdr = map { $args{munge_column_names}->($_) } @hdr;
  4         16  
1040             ref $args{munge_column_names} eq "HASH" and
1041 279 100       492 @hdr = map { $args{munge_column_names}->{$_} || $_ } @hdr;
  3 100       11  
1042 279         333 my %hdr; $hdr{$_}++ for @hdr;
  279         910  
1043 279 100       488 exists $hdr{""} and croak ($self->SetDiag (1012));
1044 277 100       573 unless (keys %hdr == @hdr) {
1045             croak ($self->_SetDiagInfo (1013, join ", " =>
1046 1         3 map { "$_ ($hdr{$_})" } grep { $hdr{$_} > 1 } keys %hdr));
  1         12  
  2         5  
1047             }
1048 276 100       859 $args{set_column_names} and $self->column_names (@hdr);
1049 276 100       2024 wantarray ? @hdr : $self;
1050             }
1051              
1052             sub bind_columns {
1053 27     27 1 7179 my ( $self, @refs ) = @_;
1054              
1055 27 100       113 @refs or return defined $self->{_BOUND_COLUMNS} ? @{$self->{_BOUND_COLUMNS}} : undef;
  2 100       11  
1056 23 100 100     145 @refs == 1 && ! defined $refs[0] and return $self->{_BOUND_COLUMNS} = undef;
1057              
1058 18 100 100     77 if ( $self->{_COLUMN_NAMES} && @refs != @{$self->{_COLUMN_NAMES}} ) {
  3         13  
1059 1         3 croak $self->SetDiag( 3003 );
1060             }
1061              
1062 17 100       184 if ( grep { ref $_ ne "SCALAR" } @refs ) { # why don't use grep?
  74606         111725  
1063 2         6 croak $self->SetDiag( 3004 );
1064             }
1065              
1066 15         110 $self->_set_attr_N("_is_bound", scalar @refs);
1067 15         6001 $self->{_BOUND_COLUMNS} = [ @refs ];
1068 15         1438 @refs;
1069             }
1070              
1071             sub getline_hr {
1072 120     120 1 12503 my ($self, @args, %hr) = @_;
1073 120 100       364 $self->{_COLUMN_NAMES} or croak ($self->SetDiag (3002));
1074 119 100       357 my $fr = $self->getline (@args) or return;
1075 117 100       335 if (ref $self->{_FFLAGS}) { # missing
1076             $self->{_FFLAGS}[$_] = IS_MISSING
1077 5 50       30 for (@$fr ? $#{$fr} + 1 : 0) .. $#{$self->{_COLUMN_NAMES}};
  5         10  
  5         20  
1078             @$fr == 1 && (!defined $fr->[0] || $fr->[0] eq "") and
1079 5 100 50     34 $self->{_FFLAGS}[0] ||= IS_MISSING;
      66        
      100        
1080             }
1081 117         200 @hr{@{$self->{_COLUMN_NAMES}}} = @$fr;
  117         429  
1082 117         652 \%hr;
1083             }
1084              
1085             sub getline_hr_all {
1086 205     205 1 436 my ( $self, $io, @args ) = @_;
1087              
1088 205 100       434 unless ( $self->{_COLUMN_NAMES} ) {
1089 2         8 croak $self->SetDiag( 3002 );
1090             }
1091              
1092 203         233 my @cn = @{$self->{_COLUMN_NAMES}};
  203         458  
1093              
1094 203         291 return [ map { my %h; @h{ @cn } = @$_; \%h } @{ $self->getline_all( $io, @args ) } ];
  292         369  
  292         884  
  292         1148  
  203         473  
1095             }
1096              
1097             sub say {
1098 13     13 1 2249 my ($self, $io, @f) = @_;
1099 13         39 my $eol = $self->eol;
1100 13 100 33     91 $eol eq "" and $self->eol ($\ || $/);
1101             # say ($fh, undef) does not propage actual undef to print ()
1102 13 100 66     80 my $state = $self->print ($io, @f == 1 && !defined $f[0] ? undef : @f);
1103 13         217 $self->eol ($eol);
1104 13         98 return $state;
1105             }
1106              
1107             sub print_hr {
1108 3     3 1 22 my ($self, $io, $hr) = @_;
1109 3 100       17 $self->{_COLUMN_NAMES} or croak($self->SetDiag(3009));
1110 2 100       16 ref $hr eq "HASH" or croak($self->SetDiag(3010));
1111 1         4 $self->print ($io, [ map { $hr->{$_} } $self->column_names ]);
  3         9  
1112             }
1113              
1114             sub fragment {
1115 58     58 1 29494 my ($self, $io, $spec) = @_;
1116              
1117 58         221 my $qd = qr{\s* [0-9]+ \s* }x; # digit
1118 58         136 my $qs = qr{\s* (?: [0-9]+ | \* ) \s*}x; # digit or star
1119 58         380 my $qr = qr{$qd (?: - $qs )?}x; # range
1120 58         311 my $qc = qr{$qr (?: ; $qr )*}x; # list
1121 58 100 100     1260 defined $spec && $spec =~ m{^ \s*
1122             \x23 ? \s* # optional leading #
1123             ( row | col | cell ) \s* =
1124             ( $qc # for row and col
1125             | $qd , $qd (?: - $qs , $qs)? # for cell (ranges)
1126             (?: ; $qd , $qd (?: - $qs , $qs)? )* # and cell (range) lists
1127             ) \s* $}xi or croak ($self->SetDiag (2013));
1128 38         190 my ($type, $range) = (lc $1, $2);
1129              
1130 38         117 my @h = $self->column_names ();
1131              
1132 38         73 my @c;
1133 38 100       94 if ($type eq "cell") {
1134 21         33 my @spec;
1135             my $min_row;
1136 21         39 my $max_row = 0;
1137 21         90 for (split m/\s*;\s*/ => $range) {
1138 37 100       224 my ($tlr, $tlc, $brr, $brc) = (m{
1139             ^ \s* ([0-9]+ ) \s* , \s* ([0-9]+ ) \s*
1140             (?: - \s* ([0-9]+ | \*) \s* , \s* ([0-9]+ | \*) \s* )?
1141             $}x) or croak ($self->SetDiag (2013));
1142 36 100       96 defined $brr or ($brr, $brc) = ($tlr, $tlc);
1143 36 100 100     329 $tlr == 0 || $tlc == 0 ||
      66        
      100        
      100        
      66        
      100        
      100        
1144             ($brr ne "*" && ($brr == 0 || $brr < $tlr)) ||
1145             ($brc ne "*" && ($brc == 0 || $brc < $tlc))
1146             and croak ($self->SetDiag (2013));
1147 28         42 $tlc--;
1148 28 100       54 $brc-- unless $brc eq "*";
1149 28 100       58 defined $min_row or $min_row = $tlr;
1150 28 100       49 $tlr < $min_row and $min_row = $tlr;
1151 28 100 100     94 $brr eq "*" || $brr > $max_row and
1152             $max_row = $brr;
1153 28         82 push @spec, [ $tlr, $tlc, $brr, $brc ];
1154             }
1155 12         24 my $r = 0;
1156 12         31 while (my $row = $self->getline ($io)) {
1157 77 100       258 ++$r < $min_row and next;
1158 33         61 my %row;
1159             my $lc;
1160 33         63 foreach my $s (@spec) {
1161 77         163 my ($tlr, $tlc, $brr, $brc) = @$s;
1162 77 100 100     309 $r < $tlr || ($brr ne "*" && $r > $brr) and next;
      100        
1163 45 100 100     119 !defined $lc || $tlc < $lc and $lc = $tlc;
1164 45 100       88 my $rr = $brc eq "*" ? $#$row : $brc;
1165 45         224 $row{$_} = $row->[$_] for $tlc .. $rr;
1166             }
1167 33         143 push @c, [ @row{sort { $a <=> $b } keys %row } ];
  62         183  
1168 33 100       82 if (@h) {
1169 2         6 my %h; @h{@h} = @{$c[-1]};
  2         3  
  2         8  
1170 2         6 $c[-1] = \%h;
1171             }
1172 33 100 100     185 $max_row ne "*" && $r == $max_row and last;
1173             }
1174 12         85 return \@c;
1175             }
1176              
1177             # row or col
1178 17         28 my @r;
1179 17         32 my $eod = 0;
1180 17         96 for (split m/\s*;\s*/ => $range) {
1181 25 50       151 my ($from, $to) = m/^\s* ([0-9]+) (?: \s* - \s* ([0-9]+ | \* ))? \s* $/x
1182             or croak ($self->SetDiag (2013));
1183 25   100     98 $to ||= $from;
1184 25 100       58 $to eq "*" and ($to, $eod) = ($from, 1);
1185             # $to cannot be <= 0 due to regex and ||=
1186 25 100 100     104 $from <= 0 || $to < $from and croak ($self->SetDiag (2013));
1187 22         85 $r[$_] = 1 for $from .. $to;
1188             }
1189              
1190 14         21 my $r = 0;
1191 14 100       40 $type eq "col" and shift @r;
1192 14   100     130 $_ ||= 0 for @r;
1193 14         46 while (my $row = $self->getline ($io)) {
1194 109         225 $r++;
1195 109 100       241 if ($type eq "row") {
1196 64 100 100     263 if (($r > $#r && $eod) || $r[$r]) {
      100        
1197 20         40 push @c, $row;
1198 20 100       43 if (@h) {
1199 3         5 my %h; @h{@h} = @{$c[-1]};
  3         5  
  3         14  
1200 3         81 $c[-1] = \%h;
1201             }
1202             }
1203 64         212 next;
1204             }
1205 45 100 100     111 push @c, [ map { ($_ > $#r && $eod) || $r[$_] ? $row->[$_] : () } 0..$#$row ];
  405         1469  
1206 45 100       192 if (@h) {
1207 9         12 my %h; @h{@h} = @{$c[-1]};
  9         11  
  9         29  
1208 9         39 $c[-1] = \%h;
1209             }
1210             }
1211              
1212 14         105 return \@c;
1213             }
1214              
1215             my $csv_usage = q{usage: my $aoa = csv (in => $file);};
1216              
1217             sub _csv_attr {
1218 266 100 66 266   1554 my %attr = (@_ == 1 && ref $_[0] eq "HASH" ? %{$_[0]} : @_) or croak;
  4 50       20  
1219              
1220 266         625 $attr{binary} = 1;
1221              
1222 266   100     1239 my $enc = delete $attr{enc} || delete $attr{encoding} || "";
1223 266 100       579 $enc eq "auto" and ($attr{detect_bom}, $enc) = (1, "");
1224 266 100       550 $enc =~ m/^[-\w.]+$/ and $enc = ":encoding($enc)";
1225              
1226 266         359 my $fh;
1227 266         330 my $sink = 0;
1228 266         338 my $cls = 0; # If I open a file, I have to close it
1229 266 100 100     1241 my $in = delete $attr{in} || delete $attr{file} or croak $csv_usage;
1230             my $out = exists $attr{out} && !$attr{out} ? \"skip"
1231 263 50 66     1244 : delete $attr{out} || delete $attr{file};
      100        
1232              
1233 263 100 100     933 ref $in eq "CODE" || ref $in eq "ARRAY" and $out ||= \*STDOUT;
      100        
1234              
1235 263 100 66     1122 $in && $out && !ref $in && !ref $out and croak join "\n" =>
      100        
      100        
1236             qq{Cannot use a string for both in and out. Instead use:},
1237             qq{ csv (in => csv (in => "$in"), out => "$out");\n};
1238              
1239 262 100       549 if ($out) {
1240 22 100 100     153 if ((ref $out and "SCALAR" ne ref $out) or "GLOB" eq ref \$out) {
    100 100        
      66        
      66        
      66        
1241 13         23 $fh = $out;
1242             }
1243             elsif (ref $out and "SCALAR" eq ref $out and defined $$out and $$out eq "skip") {
1244 1         2 delete $attr{out};
1245 1         2 $sink = 1;
1246             }
1247             else {
1248 8 100       763 open $fh, ">", $out or croak "$out: $!";
1249 7         27 $cls = 1;
1250             }
1251 21 100       66 if ($fh) {
1252 20 100       65 $enc and binmode $fh, $enc;
1253 20 100       125 unless (defined $attr{eol}) {
1254 17         29 my @layers = eval { PerlIO::get_layers ($fh) };
  17         101  
1255 17 100       109 $attr{eol} = (grep m/crlf/ => @layers) ? "\n" : "\r\n";
1256             }
1257             }
1258             }
1259              
1260 261 100 100     1602 if ( ref $in eq "CODE" or ref $in eq "ARRAY") {
    100 100        
    100          
1261             # All done
1262             }
1263             elsif (ref $in eq "SCALAR") {
1264             # Strings with code points over 0xFF may not be mapped into in-memory file handles
1265             # "<$enc" does not change that :(
1266 20 50   5   335 open $fh, "<", $in or croak "Cannot open from SCALAR using PerlIO";
  5         30  
  5         10  
  5         41  
1267 20         1851 $cls = 1;
1268             }
1269             elsif (ref $in or "GLOB" eq ref \$in) {
1270 16 50 66     38 if (!ref $in && $] < 5.008005) {
1271 0         0 $fh = \*$in; # uncoverable statement ancient perl version required
1272             }
1273             else {
1274 16         22 $fh = $in;
1275             }
1276             }
1277             else {
1278 206 100       8200 open $fh, "<$enc", $in or croak "$in: $!";
1279 204         15160 $cls = 1;
1280             }
1281 259 50 33     653 $fh || $sink or croak qq{No valid source passed. "in" is required};
1282              
1283 259         487 my $hdrs = delete $attr{headers};
1284 259         408 my $frag = delete $attr{fragment};
1285 259         389 my $key = delete $attr{key};
1286 259         377 my $val = delete $attr{value};
1287             my $kh = delete $attr{keep_headers} ||
1288             delete $attr{keep_column_names} ||
1289 259   100     1155 delete $attr{kh};
1290              
1291             my $cbai = delete $attr{callbacks}{after_in} ||
1292             delete $attr{after_in} ||
1293             delete $attr{callbacks}{after_parse} ||
1294 259   100     1653 delete $attr{after_parse};
1295             my $cbbo = delete $attr{callbacks}{before_out} ||
1296 259   100     723 delete $attr{before_out};
1297             my $cboi = delete $attr{callbacks}{on_in} ||
1298 259   100     682 delete $attr{on_in};
1299              
1300             my $hd_s = delete $attr{sep_set} ||
1301 259   100     626 delete $attr{seps};
1302             my $hd_b = delete $attr{detect_bom} ||
1303 259   100     618 delete $attr{bom};
1304             my $hd_m = delete $attr{munge} ||
1305 259   100     638 delete $attr{munge_column_names};
1306 259         349 my $hd_c = delete $attr{set_column_names};
1307              
1308 259         917 for ([ quo => "quote" ],
1309             [ esc => "escape" ],
1310             [ escape => "escape_char" ],
1311             ) {
1312 777         1178 my ($f, $t) = @$_;
1313 777 100 100     1714 exists $attr{$f} and !exists $attr{$t} and $attr{$t} = delete $attr{$f};
1314             }
1315              
1316 259         566 my $fltr = delete $attr{filter};
1317             my %fltr = (
1318 10 100 33 10   11 not_blank => sub { @{$_[1]} > 1 or defined $_[1][0] && $_[1][0] ne "" },
  10         38  
1319 10 50   10   11 not_empty => sub { grep { defined && $_ ne "" } @{$_[1]} },
  26         77  
  10         17  
1320 10 50   10   11 filled => sub { grep { defined && m/\S/ } @{$_[1]} },
  26         90  
  10         19  
1321 259         2220 );
1322             defined $fltr && !ref $fltr && exists $fltr{$fltr} and
1323 259 50 100     676 $fltr = { 0 => $fltr{$fltr} };
      66        
1324 259 100       560 ref $fltr eq "CODE" and $fltr = { 0 => $fltr };
1325 259 100       536 ref $fltr eq "HASH" or $fltr = undef;
1326              
1327             exists $attr{formula} and
1328 259 50       505 $attr{formula} = _supported_formula (undef, $attr{formula});
1329              
1330 259 100       636 defined $attr{auto_diag} or $attr{auto_diag} = 1;
1331 259 100       592 defined $attr{escape_null} or $attr{escape_null} = 0;
1332 259 50 66     1382 my $csv = delete $attr{csv} || Text::CSV_PP->new (\%attr)
1333             or croak $last_new_error;
1334              
1335             return {
1336 259         4727 csv => $csv,
1337             attr => { %attr },
1338             fh => $fh,
1339             cls => $cls,
1340             in => $in,
1341             sink => $sink,
1342             out => $out,
1343             enc => $enc,
1344             hdrs => $hdrs,
1345             key => $key,
1346             val => $val,
1347             kh => $kh,
1348             frag => $frag,
1349             fltr => $fltr,
1350             cbai => $cbai,
1351             cbbo => $cbbo,
1352             cboi => $cboi,
1353             hd_s => $hd_s,
1354             hd_b => $hd_b,
1355             hd_m => $hd_m,
1356             hd_c => $hd_c,
1357             };
1358             }
1359              
1360             sub csv {
1361 267 100 66 267 1 45847 @_ && (ref $_[0] eq __PACKAGE__ or ref $_[0] eq 'Text::CSV') and splice @_, 0, 0, "csv";
      100        
1362 267 100       828 @_ or croak $csv_usage;
1363              
1364 266         672 my $c = _csv_attr (@_);
1365              
1366 259         542 my ($csv, $in, $fh, $hdrs) = @{$c}{"csv", "in", "fh", "hdrs"};
  259         638  
1367 259         340 my %hdr;
1368 259 100       578 if (ref $hdrs eq "HASH") {
1369 2         8 %hdr = %$hdrs;
1370 2         4 $hdrs = "auto";
1371             }
1372              
1373 259 100 100     643 if ($c->{out} && !$c->{sink}) {
1374 19 100       75 if (ref $in eq "CODE") {
    100          
1375 3         6 my $hdr = 1;
1376 3         12 while (my $row = $in->($csv)) {
1377 7 100       54 if (ref $row eq "ARRAY") {
1378 3         8 $csv->print ($fh, $row);
1379 3         29 next;
1380             }
1381 4 50       8 if (ref $row eq "HASH") {
1382 4 100       9 if ($hdr) {
1383 2 50 100     7 $hdrs ||= [ map { $hdr{$_} || $_ } keys %$row ];
  3         13  
1384 2         9 $csv->print ($fh, $hdrs);
1385 2         26 $hdr = 0;
1386             }
1387 4         20 $csv->print ($fh, [ @{$row}{@$hdrs} ]);
  4         14  
1388             }
1389             }
1390             }
1391             elsif (ref $in->[0] eq "ARRAY") { # aoa
1392 9 50       24 ref $hdrs and $csv->print ($fh, $hdrs);
1393 9         15 for (@{$in}) {
  9         20  
1394 12 100       87 $c->{cboi} and $c->{cboi}->($csv, $_);
1395 12 50       1111 $c->{cbbo} and $c->{cbbo}->($csv, $_);
1396 12         27 $csv->print ($fh, $_);
1397             }
1398             }
1399             else { # aoh
1400 7 100       31 my @hdrs = ref $hdrs ? @{$hdrs} : keys %{$in->[0]};
  1         3  
  6         21  
1401 7 100       18 defined $hdrs or $hdrs = "auto";
1402             ref $hdrs || $hdrs eq "auto" and
1403 7 100 100     33 $csv->print ($fh, [ map { $hdr{$_} || $_ } @hdrs ]);
  8 100       40  
1404 7         88 for (@{$in}) {
  7         15  
1405 9         49 local %_;
1406 9         18 *_ = $_;
1407 9 50       22 $c->{cboi} and $c->{cboi}->($csv, $_);
1408 9 50       17 $c->{cbbo} and $c->{cbbo}->($csv, $_);
1409 9         13 $csv->print ($fh, [ @{$_}{@hdrs} ]);
  9         25  
1410             }
1411             }
1412              
1413 19 100       732 $c->{cls} and close $fh;
1414 19         261 return 1;
1415             }
1416              
1417 240         322 my @row1;
1418 240 100 100     1218 if (defined $c->{hd_s} || defined $c->{hd_b} || defined $c->{hd_m} || defined $c->{hd_c}) {
      100        
      100        
1419 145         214 my %harg;
1420 145 100       253 defined $c->{hd_s} and $harg{set_set} = $c->{hd_s};
1421 145 50       296 defined $c->{hd_d} and $harg{detect_bom} = $c->{hd_b};
1422 145 50       250 defined $c->{hd_m} and $harg{munge_column_names} = $hdrs ? "none" : $c->{hd_m};
    100          
1423 145 50       257 defined $c->{hd_c} and $harg{set_column_names} = $hdrs ? 0 : $c->{hd_c};
    100          
1424 145         341 @row1 = $csv->header ($fh, \%harg);
1425 145         353 my @hdr = $csv->column_names;
1426 145 100 50     699 @hdr and $hdrs ||= \@hdr;
1427             }
1428              
1429 240 100       531 if ($c->{kh}) {
1430 11 100       33 ref $c->{kh} eq "ARRAY" or croak ($csv->SetDiag (1501));
1431 6   100     15 $hdrs ||= "auto";
1432             }
1433              
1434 235         476 my $key = $c->{key};
1435 235 100       562 if ($key) {
1436 26 100 100     116 !ref $key or ref $key eq "ARRAY" && @$key > 1 or croak ($csv->SetDiag (1501));
      100        
1437 19   100     56 $hdrs ||= "auto";
1438             }
1439 228         344 my $val = $c->{val};
1440 228 100       401 if ($val) {
1441 9 100       21 $key or croak ($csv->SetDiag (1502));
1442 8 100 100     43 !ref $val or ref $val eq "ARRAY" && @$val > 0 or croak ($csv->SetDiag (1503));
      100        
1443             }
1444              
1445 224 100 100     464 $c->{fltr} && grep m/\D/ => keys %{$c->{fltr}} and $hdrs ||= "auto";
  16   100     109  
1446 224 100       419 if (defined $hdrs) {
1447 188 100       588 if (!ref $hdrs) {
    100          
1448 40 100       136 if ($hdrs eq "skip") {
    100          
    100          
    50          
1449 1         3 $csv->getline ($fh); # discard;
1450             }
1451             elsif ($hdrs eq "auto") {
1452 37 50       116 my $h = $csv->getline ($fh) or return;
1453 37 100       113 $hdrs = [ map { $hdr{$_} || $_ } @$h ];
  108         396  
1454             }
1455             elsif ($hdrs eq "lc") {
1456 1 50       3 my $h = $csv->getline ($fh) or return;
1457 1   33     4 $hdrs = [ map { lc ($hdr{$_} || $_) } @$h ];
  3         12  
1458             }
1459             elsif ($hdrs eq "uc") {
1460 1 50       3 my $h = $csv->getline ($fh) or return;
1461 1   33     3 $hdrs = [ map { uc ($hdr{$_} || $_) } @$h ];
  3         12  
1462             }
1463             }
1464             elsif (ref $hdrs eq "CODE") {
1465 1 50       3 my $h = $csv->getline ($fh) or return;
1466 1         2 my $cr = $hdrs;
1467 1   33     3 $hdrs = [ map { $cr->($hdr{$_} || $_) } @$h ];
  3         16  
1468             }
1469 188 100 66     518 $c->{kh} and $hdrs and @{$c->{kh}} = @$hdrs;
  6         14  
1470             }
1471              
1472 224 100       434 if ($c->{fltr}) {
1473 16         23 my %f = %{$c->{fltr}};
  16         43  
1474             # convert headers to index
1475 16         23 my @hdr;
1476 16 100       39 if (ref $hdrs) {
1477 7         8 @hdr = @{$hdrs};
  7         18  
1478 7         23 for (0 .. $#hdr) {
1479 21 100       59 exists $f{$hdr[$_]} and $f{$_ + 1} = delete $f{$hdr[$_]};
1480             }
1481             }
1482             $csv->callbacks (after_parse => sub {
1483 114     114   160 my ($CSV, $ROW) = @_; # lexical sub-variables in caps
1484 114         263 foreach my $FLD (sort keys %f) {
1485 115         290 local $_ = $ROW->[$FLD - 1];
1486 115         162 local %_;
1487 115 100       248 @hdr and @_{@hdr} = @$ROW;
1488 115 100       293 $f{$FLD}->($CSV, $ROW) or return \"skip";
1489 52         309 $ROW->[$FLD - 1] = $_;
1490             }
1491 16         90 });
1492             }
1493              
1494 224         340 my $frag = $c->{frag};
1495             my $ref = ref $hdrs
1496             ? # aoh
1497 224 100       543 do {
    100          
1498 187         424 my @h = $csv->column_names ($hdrs);
1499 187         248 my %h; $h{$_}++ for @h;
  187         576  
1500 187 50       463 exists $h{""} and croak ($csv->SetDiag (1012));
1501 187 50       428 unless (keys %h == @h) {
1502             croak ($csv->_SetDiagInfo (1013, join ", " =>
1503 0         0 map { "$_ ($h{$_})" } grep { $h{$_} > 1 } keys %h));
  0         0  
  0         0  
1504             }
1505             $frag ? $csv->fragment ($fh, $frag) :
1506 187 100       593 $key ? do {
    100          
1507 16 100       51 my ($k, $j, @f) = ref $key ? (undef, @$key) : ($key);
1508 16 100       30 if (my @mk = grep { !exists $h{$_} } grep { defined } $k, @f) {
  21         81  
  26         49  
1509 2         12 croak ($csv->_SetDiagInfo (4001, join ", " => @mk));
1510             }
1511             +{ map {
1512 25         33 my $r = $_;
1513 25 100       66 my $K = defined $k ? $r->{$k} : join $j => @{$r}{@f};
  4         10  
1514             ( $K => (
1515             $val
1516             ? ref $val
1517 4         20 ? { map { $_ => $r->{$_} } @$val }
1518 25 100       107 : $r->{$val}
    100          
1519             : $r ));
1520 14         24 } @{$csv->getline_hr_all ($fh)} }
  14         44  
1521             }
1522             : $csv->getline_hr_all ($fh);
1523             }
1524             : # aoa
1525             $frag ? $csv->fragment ($fh, $frag)
1526             : $csv->getline_all ($fh);
1527 222 50       445 if ($ref) {
1528 222 100 66     977 @row1 && !$c->{hd_c} && !ref $hdrs and unshift @$ref, \@row1;
      100        
1529             }
1530             else {
1531 0         0 Text::CSV_PP->auto_diag;
1532             }
1533 222 100       2558 $c->{cls} and close $fh;
1534 222 100 100     1326 if ($ref and $c->{cbai} || $c->{cboi}) {
      66        
1535             # Default is ARRAYref, but with key =>, you'll get a hashref
1536 22 100       71 foreach my $r (ref $ref eq "ARRAY" ? @{$ref} : values %{$ref}) {
  21         50  
  1         3  
1537 71         4833 local %_;
1538 71 100       154 ref $r eq "HASH" and *_ = $r;
1539 71 100       171 $c->{cbai} and $c->{cbai}->($csv, $r);
1540 71 100       2992 $c->{cboi} and $c->{cboi}->($csv, $r);
1541             }
1542             }
1543              
1544 222 100       1304 $c->{sink} and return;
1545              
1546             defined wantarray or
1547 221 100       467 return csv (%{$c->{attr}}, in => $ref, headers => $hdrs, %{$c->{attr}});
  1         5  
  1         14  
1548              
1549 220         3512 return $ref;
1550             }
1551              
1552             # The end of the common pure perl part.
1553              
1554             ################################################################################
1555             #
1556             # The following are methods implemented in XS in Text::CSV_XS or
1557             # helper methods for Text::CSV_PP only
1558             #
1559             ################################################################################
1560              
1561             sub _setup_ctx {
1562 27480     27480   42923 my $self = shift;
1563              
1564 27480         37464 $last_error = undef;
1565              
1566 27480         39690 my $ctx;
1567 27480 100       67728 if ($self->{_CACHE}) {
1568 26802         35769 %$ctx = %{$self->{_CACHE}};
  26802         370049  
1569             } else {
1570 678         1713 $ctx->{sep} = ',';
1571 678 50       1529 if (defined $self->{sep_char}) {
1572 678         1387 $ctx->{sep} = $self->{sep_char};
1573             }
1574 678 100 100     2007 if (defined $self->{sep} and $self->{sep} ne '') {
1575 32     32   19442 use bytes;
  32         455  
  32         167  
1576 5         10 $ctx->{sep} = $self->{sep};
1577 5         13 my $sep_len = length($ctx->{sep});
1578 5 50       15 $ctx->{sep_len} = $sep_len if $sep_len > 1;
1579             }
1580              
1581 678         1294 $ctx->{quo} = '"';
1582 678 50       1494 if (exists $self->{quote_char}) {
1583 678         1155 my $quote_char = $self->{quote_char};
1584 678 100 66     2415 if (defined $quote_char and length $quote_char) {
1585 674         1241 $ctx->{quo} = $quote_char;
1586             } else {
1587 4         11 $ctx->{quo} = "\0";
1588             }
1589             }
1590 678 100 100     1619 if (defined $self->{quote} and $self->{quote} ne '') {
1591 32     32   3383 use bytes;
  32         61  
  32         114  
1592 4         9 $ctx->{quo} = $self->{quote};
1593 4         10 my $quote_len = length($ctx->{quo});
1594 4 50       12 $ctx->{quo_len} = $quote_len if $quote_len > 1;
1595             }
1596              
1597 678         1268 $ctx->{escape_char} = '"';
1598 678 50       1349 if (exists $self->{escape_char}) {
1599 678         1029 my $escape_char = $self->{escape_char};
1600 678 100 100     2023 if (defined $escape_char and length $escape_char) {
1601 670         1200 $ctx->{escape_char} = $escape_char;
1602             } else {
1603 8         18 $ctx->{escape_char} = "\0";
1604             }
1605             }
1606              
1607 678 100       1407 if (defined $self->{eol}) {
1608 674         952 my $eol = $self->{eol};
1609 674         960 my $eol_len = length($eol);
1610 674         1045 $ctx->{eol} = $eol;
1611 674         986 $ctx->{eol_len} = $eol_len;
1612 674 100 100     1803 if ($eol_len == 1 and $eol eq "\015") {
1613 40         91 $ctx->{eol_is_cr} = 1;
1614             }
1615             }
1616              
1617 678         1151 $ctx->{undef_flg} = 0;
1618 678 100       1255 if (defined $self->{undef_str}) {
1619 1         2 $ctx->{undef_str} = $self->{undef_str};
1620 1 50       5 $ctx->{undef_flg} = 3 if utf8::is_utf8($self->{undef_str});
1621             } else {
1622 677         1136 $ctx->{undef_str} = undef;
1623             }
1624              
1625 678 100       1483 if (defined $self->{_types}) {
1626 1         3 $ctx->{types} = $self->{_types};
1627 1         3 $ctx->{types_len} = length($ctx->{types});
1628             }
1629              
1630 678 100       1396 if (defined $self->{_is_bound}) {
1631 4         14 $ctx->{is_bound} = $self->{_is_bound};
1632             }
1633              
1634 678 100       1323 if (defined $self->{callbacks}) {
1635 248         354 my $cb = $self->{callbacks};
1636 248         517 $ctx->{has_hooks} = 0;
1637 248 100 66     552 if (defined $cb->{after_parse} and ref $cb->{after_parse} eq 'CODE') {
1638 9         13 $ctx->{has_hooks} |= HOOK_AFTER_PARSE;
1639             }
1640 248 100 66     664 if (defined $cb->{before_print} and ref $cb->{before_print} eq 'CODE') {
1641 1         4 $ctx->{has_hooks} |= HOOK_BEFORE_PRINT;
1642             }
1643             }
1644              
1645 678         1561 for (qw/
1646             binary decode_utf8 always_quote strict quote_empty
1647             allow_loose_quotes allow_loose_escapes
1648             allow_unquoted_escape allow_whitespace blank_is_undef
1649             empty_is_undef verbatim auto_diag diag_verbose
1650             keep_meta_info formula
1651             /) {
1652 10848 50       22754 $ctx->{$_} = defined $self->{$_} ? $self->{$_} : 0;
1653             }
1654 678         1211 for (qw/quote_space escape_null quote_binary/) {
1655 2034 50       4288 $ctx->{$_} = defined $self->{$_} ? $self->{$_} : 1;
1656             }
1657 678 100       1545 if ($ctx->{escape_char} eq "\0") {
1658 8         17 $ctx->{escape_null} = 0;
1659             }
1660              
1661             # FIXME: readonly
1662 678         3009 %{$self->{_CACHE}} = %$ctx;
  678         5099  
1663             }
1664              
1665 27480         82243 $ctx->{utf8} = 0;
1666 27480         48234 $ctx->{size} = 0;
1667 27480         39761 $ctx->{used} = 0;
1668              
1669 27480 100       57811 if ($ctx->{is_bound}) {
1670 89         147 my $bound = $self->{_BOUND_COLUMNS};
1671 89 100 66     350 if ($bound and ref $bound eq 'ARRAY') {
1672 75         137 $ctx->{bound} = $bound;
1673             } else {
1674 14         26 $ctx->{is_bound} = 0;
1675             }
1676             }
1677              
1678 27480         39574 $ctx->{eol_pos} = -1;
1679             $ctx->{eolx} = $ctx->{eol_len}
1680             ? $ctx->{verbatim} || $ctx->{eol_len} >= 2
1681             ? 1
1682 27480 100 100     58474 : $ctx->{eol} =~ /\A[\015\012]/ ? 0 : 1
    100          
    100          
1683             : 0;
1684              
1685 27480 100 66     55095 if ($ctx->{sep_len} and $ctx->{sep_len} > 1 and _is_valid_utf8($ctx->{sep})) {
      100        
1686 14         23 $ctx->{utf8} = 1;
1687             }
1688 27480 50 66     48269 if ($ctx->{quo_len} and $ctx->{quo_len} > 1 and _is_valid_utf8($ctx->{quo})) {
      66        
1689 0         0 $ctx->{utf8} = 1;
1690             }
1691              
1692 27480         50391 $ctx;
1693             }
1694              
1695             sub _cache_set {
1696 23396     23396   39100 my ($self, $idx, $value) = @_;
1697 23396 100       44689 return unless exists $self->{_CACHE};
1698 22573         29932 my $cache = $self->{_CACHE};
1699              
1700 22573         37027 my $key = $_reverse_cache_id{$idx};
1701 22573 100       86936 if (!defined $key) {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
1702 1         15 warn (sprintf "Unknown cache index %d ignored\n", $idx);
1703             } elsif ($key eq 'sep_char') {
1704 3120         5483 $cache->{sep} = $value;
1705 3120         4749 $cache->{sep_len} = 0;
1706             }
1707             elsif ($key eq 'quote_char') {
1708 3368         5642 $cache->{quo} = $value;
1709 3368         5046 $cache->{quo_len} = 0;
1710             }
1711             elsif ($key eq '_has_ahead') {
1712 249         402 $cache->{has_ahead} = $value;
1713             }
1714             elsif ($key eq '_has_hooks') {
1715 11         22 $cache->{has_hooks} = $value;
1716             }
1717             elsif ($key eq '_is_bound') {
1718 11         28 $cache->{is_bound} = $value;
1719             }
1720             elsif ($key eq 'sep') {
1721 32     32   22951 use bytes;
  32         83  
  32         673  
1722 3219         7294 my $len = bytes::length($value);
1723 3219 100       15846 $cache->{sep} = $value if $len;
1724 3219 50       6569 $cache->{sep_len} = $len == 1 ? 0 : $len;
1725             }
1726             elsif ($key eq 'quote') {
1727 32     32   2284 use bytes;
  32         65  
  32         187  
1728 3376         8438 my $len = bytes::length($value);
1729 3376 100       13189 $cache->{quo} = $value if $len;
1730 3376 50       6731 $cache->{quo_len} = $len == 1 ? 0 : $len;
1731             }
1732             elsif ($key eq 'eol') {
1733 112 50       206 if (defined($value)) {
1734 112         195 $cache->{eol} = $value;
1735 112         176 $cache->{eol_len} = length($value);
1736             }
1737 112 100       256 $cache->{eol_is_cr} = $value eq "\015" ? 1 : 0;
1738             }
1739             elsif ($key eq 'undef_str') {
1740 11 100       18 if (defined $value) {
1741 9         18 $cache->{undef_str} = $value;
1742 9 100       26 $cache->{undef_flg} = 3 if utf8::is_utf8($value);
1743             } else {
1744 2         6 $cache->{undef_str} = undef;
1745 2         4 $cache->{undef_flg} = 0;
1746             }
1747             }
1748             else {
1749 9095         14533 $cache->{$key} = $value;
1750             }
1751 22573         37112 return 1;
1752             }
1753              
1754             sub _cache_diag {
1755 2     2   7 my $self = shift;
1756 2 100       9 unless (exists $self->{_CACHE}) {
1757 1         10 warn ("CACHE: invalid\n");
1758 1         9 return;
1759             }
1760              
1761 1         3 my $cache = $self->{_CACHE};
1762 1         121 warn ("CACHE:\n");
1763 1         18 $self->__cache_show_char(quote_char => $cache->{quo});
1764 1         56 $self->__cache_show_char(escape_char => $cache->{escape_char});
1765 1         7 $self->__cache_show_char(sep_char => $cache->{sep});
1766 1         8 for (qw/
1767             binary decode_utf8 allow_loose_escapes allow_loose_quotes allow_unquoted_escape
1768             allow_whitespace always_quote quote_empty quote_space
1769             escape_null quote_binary auto_diag diag_verbose formula strict
1770             has_error_input blank_is_undef empty_is_undef has_ahead
1771             keep_meta_info verbatim has_hooks eol_is_cr eol_len
1772             /) {
1773 24         102 $self->__cache_show_byte($_ => $cache->{$_});
1774             }
1775 1         11 $self->__cache_show_str(eol => $cache->{eol_len}, $cache->{eol});
1776 1         8 $self->__cache_show_byte(sep_len => $cache->{sep_len});
1777 1 50 33     10 if ($cache->{sep_len} and $cache->{sep_len} > 1) {
1778 1         5 $self->__cache_show_str(sep => $cache->{sep_len}, $cache->{sep});
1779             }
1780 1         7 $self->__cache_show_byte(quo_len => $cache->{quo_len});
1781 1 50 33     11 if ($cache->{quo_len} and $cache->{quo_len} > 1) {
1782 1         5 $self->__cache_show_str(quote => $cache->{quo_len}, $cache->{quo});
1783             }
1784             }
1785              
1786             sub __cache_show_byte {
1787 26     26   52 my ($self, $key, $value) = @_;
1788 26 100       372 warn (sprintf " %-21s %02x:%3d\n", $key, defined $value ? ord($value) : 0, defined $value ? $value : 0);
    100          
1789             }
1790              
1791             sub __cache_show_char {
1792 3     3   12 my ($self, $key, $value) = @_;
1793 3         7 my $v = $value;
1794 3 50       11 if (defined $value) {
1795 3         12 my @b = unpack "U0C*", $value;
1796 3         16 $v = pack "U*", $b[0];
1797             }
1798 3 50       18 warn (sprintf " %-21s %02x:%s\n", $key, defined $v ? ord($v) : 0, $self->__pretty_str($v, 1));
1799             }
1800              
1801             sub __cache_show_str {
1802 3     3   8 my ($self, $key, $len, $value) = @_;
1803 3         19 warn (sprintf " %-21s %02d:%s\n", $key, $len, $self->__pretty_str($value, $len));
1804             }
1805              
1806             sub __pretty_str { # FIXME
1807 6     6   15 my ($self, $str, $len) = @_;
1808 6 50       12 return '' unless defined $str;
1809 6         17 $str = substr($str, 0, $len);
1810 6         16 $str =~ s/"/\\"/g;
1811 6         12 $str =~ s/([^\x09\x20-\x7e])/sprintf '\\x{%x}', ord($1)/eg;
  0         0  
1812 6         115 qq{"$str"};
1813             }
1814              
1815             sub _hook {
1816 20394     20394   35426 my ($self, $name, $fields) = @_;
1817 20394 100       55893 return 0 unless $self->{callbacks};
1818              
1819 161         225 my $cb = $self->{callbacks}{$name};
1820 161 100 66     510 return 0 unless $cb && ref $cb eq 'CODE';
1821              
1822 125         214 my (@res) = $cb->($self, $fields);
1823 125 50       522 if (@res) {
1824 125 100 66     257 return 0 if ref $res[0] eq 'SCALAR' and ${$res[0]} eq "skip";
  64         209  
1825             }
1826 61         155 scalar @res;
1827             }
1828              
1829             ################################################################################
1830             # methods for combine
1831             ################################################################################
1832              
1833             sub __combine {
1834 21670     21670   41847 my ($self, $dst, $fields, $useIO) = @_;
1835              
1836 21670         50281 my $ctx = $self->_setup_ctx;
1837              
1838 21670         33764 my ($binary, $quot, $sep, $esc, $quote_space) = @{$ctx}{qw/binary quo sep escape_char quote_space/};
  21670         57866  
1839              
1840 21670 100 66     91583 if(!defined $quot or $quot eq "\0"){ $quot = ''; }
  1         3  
1841              
1842 21670         31698 my $re_esc;
1843 21670 100 66     67724 if ($esc ne '' and $esc ne "\0") {
1844 21668 100       36900 if ($quot ne '') {
1845 21667   66     67226 $re_esc = $self->{_re_comb_escape}->{$quot}->{$esc} ||= qr/(\Q$quot\E|\Q$esc\E)/;
1846             } else {
1847 1   33     21 $re_esc = $self->{_re_comb_escape}->{$quot}->{$esc} ||= qr/(\Q$esc\E)/;
1848             }
1849             }
1850              
1851 21670         28077 my $bound = 0;
1852 21670         34210 my $n = @$fields - 1;
1853 21670 100 100     40434 if ($n < 0 and $ctx->{is_bound}) {
1854 5         7 $n = $ctx->{is_bound} - 1;
1855 5         8 $bound = 1;
1856             }
1857              
1858 21670 100 66     52391 my $check_meta = ($ctx->{keep_meta_info} >= 10 and @{$self->{_FFLAGS} || []} >= $n) ? 1 : 0;
1859              
1860 21670         32034 my $must_be_quoted;
1861             my @results;
1862 21670         45300 for(my $i = 0; $i <= $n; $i++) {
1863 53867         69077 my $v_ref;
1864 53867 100       83611 if ($bound) {
1865 14         39 $v_ref = $self->__bound_field($ctx, $i, 1);
1866             } else {
1867 53853 50       90757 if (@$fields > $i) {
1868 53853         88561 $v_ref = \($fields->[$i]);
1869             }
1870             }
1871 53867 50       105805 next unless $v_ref;
1872              
1873 53867         80383 my $value = $$v_ref;
1874              
1875 53867 100       93775 if (!defined $value) {
1876 56 100       112 if ($ctx->{undef_str}) {
1877 8 100       16 if ($ctx->{undef_flg}) {
1878 3         5 $ctx->{utf8} = 1;
1879 3         5 $ctx->{binary} = 1;
1880             }
1881 8         15 push @results, $ctx->{undef_str};
1882             } else {
1883 48         86 push @results, '';
1884             }
1885 56         131 next;
1886             }
1887              
1888 53811 100 100     2477239 if ( substr($value, 0, 1) eq '=' && $ctx->{formula} ) {
1889 10         24 $value = $self->_formula($ctx, $value, $i);
1890 6 100       15 if (!defined $value) {
1891 2         5 push @results, '';
1892 2         4 next;
1893             }
1894             }
1895              
1896 53805 100       106934 $must_be_quoted = $ctx->{always_quote} ? 1 : 0;
1897 53805 100       92998 if ($value eq '') {
1898 1402 100 100     4648 $must_be_quoted++ if $ctx->{quote_empty} or ($check_meta && $self->is_quoted($i));
      100        
1899             }
1900             else {
1901              
1902 52403 100       122526 if (utf8::is_utf8 $value) {
1903 20041         31217 $ctx->{utf8} = 1;
1904 20041         28801 $ctx->{binary} = 1;
1905             }
1906              
1907 52403 100 100     104928 $must_be_quoted++ if $check_meta && $self->is_quoted($i);
1908              
1909 52403 100 100     155492 if (!$must_be_quoted and $quot ne '') {
1910 32     32   37232 use bytes;
  32         76  
  32         173  
1911             $must_be_quoted++ if
1912             ($value =~ /\Q$quot\E/) ||
1913             ($sep ne '' and $sep ne "\0" and $value =~ /\Q$sep\E/) ||
1914             ($esc ne '' and $esc ne "\0" and $value =~ /\Q$esc\E/) ||
1915             ($ctx->{quote_binary} && $value =~ /[\x00-\x1f\x7f-\xa0]/) ||
1916 46764 100 66     842693 ($ctx->{quote_space} && $value =~ /[\x09\x20]/);
      100        
      100        
      66        
      100        
      100        
      100        
      100        
      100        
      100        
1917             }
1918              
1919 52403 100 100     132156 if (!$ctx->{binary} and $value =~ /[^\x09\x20-\x7E]/) {
1920             # an argument contained an invalid character...
1921 7         21 $self->{_ERROR_INPUT} = $value;
1922 7         61 $self->SetDiag(2110);
1923 7         54 return 0;
1924             }
1925              
1926 52396 100       94649 if ($re_esc) {
1927 52394         2560985 $value =~ s/($re_esc)/$esc$1/g;
1928             }
1929 52396 100       114976 if ($ctx->{escape_null}) {
1930 52296         2424600 $value =~ s/\0/${esc}0/g;
1931             }
1932             }
1933              
1934 53798 100       93148 if ($must_be_quoted) {
1935 29446         325491 $value = $quot . $value . $quot;
1936             }
1937 53798         170465 push @results, $value;
1938             }
1939              
1940 21659 100       569635 $$dst = join($sep, @results) . ( defined $ctx->{eol} ? $ctx->{eol} : '' );
1941              
1942 21659         155333 return 1;
1943             }
1944              
1945             sub _formula {
1946 22     22   48 my ($self, $ctx, $value, $i) = @_;
1947              
1948 22 50       48 my $fa = $ctx->{formula} or return;
1949 22 100       41 if ($fa == 1) { die "Formulas are forbidden\n" }
  3         57  
1950 19 100       34 if ($fa == 2) { die "Formulas are forbidden\n" } # XS croak behaves like PP's "die"
  3         53  
1951              
1952 16 100       32 if ($fa == 3) {
1953 6         10 my $rec = '';
1954 6 100       15 if ($ctx->{recno}) {
1955 3         14 $rec = sprintf " in record %lu", $ctx->{recno} + 1;
1956             }
1957 6         8 my $field = '';
1958 6         11 my $column_names = $self->{_COLUMN_NAMES};
1959 6 100 66     21 if (ref $column_names eq 'ARRAY' and @$column_names >= $i - 1) {
1960 1         3 my $column_name = $column_names->[$i - 1];
1961 1 50       7 $field = sprintf " (column: '%.100s')", $column_name if defined $column_name;
1962             }
1963 6         62 warn sprintf("Field %d%s%s contains formula '%s'\n", $i, $field, $rec, $value);
1964 6         42 return $value;
1965             }
1966              
1967 10 100       21 if ($fa == 4) {
1968 5         12 return '';
1969             }
1970 5 50       11 if ($fa == 5) {
1971 5         11 return undef;
1972             }
1973 0         0 return;
1974             }
1975              
1976             sub print {
1977 20277     20277 1 37050059 my ($self, $io, $fields) = @_;
1978              
1979 20277         111993 require IO::Handle;
1980              
1981 20277 100       139472 if (!defined $fields) {
    100          
1982 5         14 $fields = [];
1983             } elsif(ref($fields) ne 'ARRAY'){
1984 5         445 Carp::croak("Expected fields to be an array ref");
1985             }
1986              
1987 20272         52826 $self->_hook(before_print => $fields);
1988              
1989 20272         31565 my $str = "";
1990 20272 100       41726 $self->__combine(\$str, $fields, 1) or return '';
1991              
1992 20266         86756 local $\ = '';
1993              
1994 20266 100       75159 $io->print( $str ) or $self->_set_error_diag(2200);
1995             }
1996              
1997             ################################################################################
1998             # methods for parse
1999             ################################################################################
2000              
2001              
2002             sub __parse { # cx_xsParse
2003 3358     3358   6716 my ($self, $fields, $fflags, $src, $useIO) = @_;
2004              
2005 3358         7541 my $ctx = $self->_setup_ctx;
2006              
2007 3358         8178 my $state = $self->___parse($ctx, $fields, $fflags, $src, $useIO);
2008 3355 100 100     14282 if ($state and ($ctx->{has_hooks} || 0) & HOOK_AFTER_PARSE) {
      100        
2009 5         18 $self->_hook(after_parse => $fields);
2010             }
2011 3355   100     20625 return $state || !$last_error;
2012             }
2013              
2014             sub ___parse { # cx_c_xsParse
2015 4172     4172   8729 my ($self, $ctx, $fields, $fflags, $src, $useIO) = @_;
2016              
2017 4172 100 100     16776 local $/ = $ctx->{eol} if $ctx->{eolx} or $ctx->{eol_is_cr};
2018              
2019 4172 100       8362 if ($ctx->{useIO} = $useIO) {
2020 2249         17839 require IO::Handle;
2021              
2022 2249         75031 $ctx->{tmp} = undef;
2023 2249 100 66     5022 if ($ctx->{has_ahead} and defined $self->{_AHEAD}) {
2024 168         243 $ctx->{tmp} = $self->{_AHEAD};
2025 168         283 $ctx->{size} = length $ctx->{tmp};
2026 168         220 $ctx->{used} = 0;
2027             }
2028             } else {
2029 1923         2939 $ctx->{tmp} = $src;
2030 1923         3018 $ctx->{size} = length $src;
2031 1923         2486 $ctx->{used} = 0;
2032 1923         4445 $ctx->{utf8} = utf8::is_utf8($src);
2033             }
2034 4172 50       8345 if ($ctx->{has_error_input}) {
2035 0         0 $self->{_ERROR_INPUT} = undef;
2036 0         0 $ctx->{has_error_input} = 0;
2037             }
2038              
2039 4172         8818 my $result = $self->____parse($ctx, $src, $fields, $fflags);
2040 4169         8174 $self->{_RECNO} = ++($ctx->{recno});
2041 4169         6983 $self->{_EOF} = '';
2042              
2043 4169 100       7870 if ($ctx->{strict}) {
2044 15   66     48 $ctx->{strict_n} ||= $ctx->{fld_idx};
2045 15 100       35 if ($ctx->{strict_n} != $ctx->{fld_idx}) {
2046 6 100       19 unless ($ctx->{useIO} & useIO_EOF) {
2047 4         11 $self->__parse_error($ctx, 2014, $ctx->{used});
2048             }
2049 6         11 $result = undef;
2050             }
2051             }
2052              
2053 4169 100       6858 if ($ctx->{useIO}) {
2054 2249 100 66     8143 if (defined $ctx->{tmp} and $ctx->{used} < $ctx->{size} and $ctx->{has_ahead}) {
      100        
2055 30         117 $self->{_AHEAD} = substr($ctx->{tmp}, $ctx->{used}, $ctx->{size} - $ctx->{used});
2056             } else {
2057 2219         3162 $ctx->{has_ahead} = 0;
2058 2219 100       4019 if ($ctx->{useIO} & useIO_EOF) {
2059 451         685 $self->{_EOF} = 1;
2060             }
2061             }
2062 2249         15815 %{$self->{_CACHE}} = %$ctx;
  2249         27338  
2063              
2064 2249 100       7860 if ($fflags) {
2065 1435 100       2968 if ($ctx->{keep_meta_info}) {
2066 11         27 $self->{_FFLAGS} = $fflags;
2067             } else {
2068 1424         2192 undef $fflags;
2069             }
2070             }
2071             } else {
2072 1920         17400 %{$self->{_CACHE}} = %$ctx;
  1920         32000  
2073             }
2074              
2075 4169 100 100     17044 if ($result and $ctx->{types}) {
2076 2         3 my $len = @$fields;
2077 2   66     20 for(my $i = 0; $i <= $len && $i <= $ctx->{types_len}; $i++) {
2078 8         24 my $value = $fields->[$i];
2079 8 100       18 next unless defined $value;
2080 6         12 my $type = ord(substr($ctx->{types}, $i, 1));
2081 6 100       10 if ($type == IV) {
    100          
2082 2         23 $fields->[$i] = int($value);
2083             } elsif ($type == NV) {
2084 2         10 $fields->[$i] = $value + 0.0;
2085             }
2086             }
2087             }
2088              
2089 4169         10038 $result;
2090             }
2091              
2092             sub ____parse { # cx_Parse
2093 4176     4176   7866 my ($self, $ctx, $src, $fields, $fflags) = @_;
2094              
2095 4176         5678 my ($quot, $sep, $esc, $eol) = @{$ctx}{qw/quo sep escape_char eol/};
  4176         10196  
2096              
2097 4176 100 100     15277 utf8::encode($sep) if !$ctx->{utf8} and $ctx->{sep_len};
2098 4176 100 100     12441 utf8::encode($quot) if !$ctx->{utf8} and $ctx->{quo_len};
2099 4176 100 100     14227 utf8::encode($eol) if !$ctx->{utf8} and $ctx->{eol_len};
2100              
2101 4176         5439 my $seenSomething = 0;
2102 4176         5431 my $waitingForField = 1;
2103 4176         5640 my ($value, $v_ref);
2104 4176         5846 $ctx->{fld_idx} = my $fnum = 0;
2105 4176         5400 $ctx->{flag} = 0;
2106              
2107 4176 100       7422 my $re_str = join '|', map({$_ eq "\0" ? '[\\0]' : quotemeta($_)} sort {length $b <=> length $a} grep {defined $_ and $_ ne ''} $sep, $quot, $esc, $eol), "\015", "\012", "\x09", " ";
  13542 100       33954  
  13912         23164  
  16704         55257  
2108 4176         58923 $ctx->{_re} = qr/$re_str/;
2109 4176         57999 my $re = qr/$re_str|[^\x09\x20-\x7E]|$/;
2110              
2111             LOOP:
2112 4176         13228 while($self->__get_from_src($ctx, $src)) {
2113 4311         76959 while($ctx->{tmp} =~ /\G(.*?)($re)/gs) {
2114 73939         187718 my ($hit, $c) = ($1, $2);
2115 73939         113419 $ctx->{used} = pos($ctx->{tmp});
2116 73939 100 100     198791 if (!$waitingForField and $c eq '' and $hit ne '' and $ctx->{useIO} and !($ctx->{useIO} & useIO_EOF)) {
      100        
      100        
      100        
2117 147         241 $self->{_AHEAD} = $hit;
2118 147         215 $ctx->{has_ahead} = 1;
2119 147         187 $ctx->{has_leftover} = 1;
2120 147         398 last;
2121             }
2122 73792 100 100     235914 last if $seenSomething and $hit eq '' and $c eq ''; # EOF
      100        
2123              
2124             # new field
2125 73440 100       118808 if (!$v_ref) {
2126 21981 100       35501 if ($ctx->{is_bound}) {
2127 87         237 $v_ref = $self->__bound_field($ctx, $fnum, 0);
2128             } else {
2129 21894         28437 $value = '';
2130 21894         30774 $v_ref = \$value;
2131             }
2132 21981         29101 $fnum++;
2133 21981 100       35511 return unless $v_ref;
2134 21977         28012 $ctx->{flag} = 0;
2135 21977         28115 $ctx->{fld_idx}++;
2136             }
2137              
2138 73436         89527 $seenSomething = 1;
2139              
2140 73436 100 66     199327 if (defined $hit and $hit ne '') {
2141 45080 100       74584 if ($waitingForField) {
2142 9336         11138 $waitingForField = 0;
2143             }
2144 45080 50       87180 if ($hit =~ /[^\x09\x20-\x7E]/) {
2145 0         0 $ctx->{flag} |= IS_BINARY;
2146             }
2147 45080         67328 $$v_ref .= $hit;
2148             }
2149              
2150             RESTART:
2151 74085 100 66     777356 if (defined $c and defined $sep and $c eq $sep) {
    100 100        
    100 66        
    100 100        
    100 100        
      66        
      100        
      100        
      66        
      66        
      100        
      100        
2152 11291 100       23726 if ($waitingForField) {
    100          
2153             # ,1,"foo, 3",,bar,
2154             # ^ ^
2155 1165 100 100     3879 if ($ctx->{blank_is_undef} or $ctx->{empty_is_undef}) {
2156 53         87 $$v_ref = undef;
2157             } else {
2158 1112         1810 $$v_ref = "";
2159             }
2160 1165 50       2258 unless ($ctx->{is_bound}) {
2161 1165         2535 push @$fields, $$v_ref;
2162             }
2163 1165         1688 $v_ref = undef;
2164 1165 100 66     2684 if ($ctx->{keep_meta_info} and $fflags) {
2165 8         16 push @$fflags, $ctx->{flag};
2166             }
2167             } elsif ($ctx->{flag} & IS_QUOTED) {
2168             # ,1,"foo, 3",,bar,
2169             # ^
2170 2186         3306 $$v_ref .= $c;
2171             } else {
2172             # ,1,"foo, 3",,bar,
2173             # ^ ^ ^
2174 7940         20297 $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum);
2175 7938         10189 $v_ref = undef;
2176 7938         9802 $waitingForField = 1;
2177             }
2178             }
2179             elsif (defined $c and defined $quot and $quot ne "\0" and $c eq $quot) {
2180 22864 100       38681 if ($waitingForField) {
2181             # ,1,"foo, 3",,bar,\r\n
2182             # ^
2183 10906         16901 $ctx->{flag} |= IS_QUOTED;
2184 10906         13574 $waitingForField = 0;
2185 10906         57108 next;
2186             }
2187 11958 100       22618 if ($ctx->{flag} & IS_QUOTED) {
2188             # ,1,"foo, 3",,bar,\r\n
2189             # ^
2190 11904         15654 my $quoesc = 0;
2191 11904         25354 my $c2 = $self->__get($ctx);
2192              
2193 11904 100       24074 if ($ctx->{allow_whitespace}) {
2194             # , 1 , "foo, 3" , , bar , \r\n
2195             # ^
2196 4290         9390 while($self->__is_whitespace($ctx, $c2)) {
2197 90 100 33     246 if ($ctx->{allow_loose_quotes} and !(defined $esc and $c2 eq $esc)) {
      66        
2198 1         2 $$v_ref .= $c;
2199 1         2 $c = $c2;
2200             }
2201 90         183 $c2 = $self->__get($ctx);
2202             }
2203             }
2204              
2205 11904 100       21640 if (!defined $c2) { # EOF
2206             # ,1,"foo, 3"
2207             # ^
2208 1311         3586 $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum);
2209 1311         5936 return 1;
2210             }
2211              
2212 10593 100 33     42306 if (defined $c2 and defined $sep and $c2 eq $sep) {
      66        
2213             # ,1,"foo, 3",,bar,\r\n
2214             # ^
2215 9017         23109 $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum);
2216 9017         12405 $v_ref = undef;
2217 9017         11589 $waitingForField = 1;
2218 9017         48814 next;
2219             }
2220 1576 100 100     7152 if (defined $c2 and ($c2 eq "\012" or (defined $eol and $c2 eq $eol))) { # FIXME: EOLX
      66        
2221             # ,1,"foo, 3",,"bar"\n
2222             # ^
2223 301         783 $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum);
2224 301         1067 return 1;
2225             }
2226              
2227 1275 100 66     4065 if (defined $esc and $c eq $esc) {
2228 1254         1616 $quoesc = 1;
2229 1254 100 66     3483 if (defined $c2 and $c2 eq '0') {
2230             # ,1,"foo, 3"056",,bar,\r\n
2231             # ^
2232 51         83 $$v_ref .= "\0";
2233 51         254 next;
2234             }
2235 1203 100 33     4868 if (defined $c2 and defined $quot and $c2 eq $quot) {
      66        
2236             # ,1,"foo, 3""56",,bar,\r\n
2237             # ^
2238 1077 100       1956 if ($ctx->{utf8}) {
2239 1         3 $ctx->{flag} |= IS_BINARY;
2240             }
2241 1077         1740 $$v_ref .= $c2;
2242 1077         5275 next;
2243             }
2244 126 100 66     341 if ($ctx->{allow_loose_escapes} and defined $c2 and $c2 ne "\015") {
      100        
2245             # ,1,"foo, 3"56",,bar,\r\n
2246             # ^
2247 4         11 $$v_ref .= $c;
2248 4         8 $c = $c2;
2249 4         269 goto RESTART;
2250             }
2251             }
2252 143 100 66     489 if (defined $c2 and $c2 eq "\015") {
2253 88 50       187 if ($ctx->{eol_is_cr}) {
2254             # ,1,"foo, 3"\r
2255             # ^
2256 0         0 $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum);
2257 0         0 return 1;
2258             }
2259              
2260 88         162 my $c3 = $self->__get($ctx);
2261 88 100 100     279 if (defined $c3 and $c3 eq "\012") {
2262             # ,1,"foo, 3"\r\n
2263             # ^
2264 74         187 $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum);
2265 74         253 return 1;
2266             }
2267              
2268 14 50 66     43 if ($ctx->{useIO} and !$ctx->{eol_len} and $c3 !~ /[^\x09\x20-\x7E]/) {
      66        
2269             # ,1,"foo\n 3",,"bar"\r
2270             # baz,4
2271             # ^
2272 1         15 $self->__set_eol_is_cr($ctx);
2273 1         2 $ctx->{used}--;
2274 1         2 $ctx->{has_ahead} = 1;
2275 1         4 $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum);
2276 1         4 return 1;
2277             }
2278              
2279 13 100       53 $self->__parse_error($ctx, $quoesc ? 2023 : 2010, $ctx->{used} - 2);
2280 13         48 return;
2281             }
2282              
2283 55 100 100     160 if ($ctx->{allow_loose_quotes} and !$quoesc) {
2284             # ,1,"foo, 3"456",,bar,\r\n
2285             # ^
2286 10         19 $$v_ref .= $c;
2287 10         15 $c = $c2;
2288 10         589 goto RESTART;
2289             }
2290             # 1,"foo" ",3
2291             # ^
2292 45 100       138 if ($quoesc) {
2293 37         78 $ctx->{used}--;
2294 37         126 $self->__error_inside_quotes($ctx, 2023);
2295 37         158 return;
2296             }
2297 8         23 $self->__error_inside_quotes($ctx, 2011);
2298 8         28 return;
2299             }
2300             # !waitingForField, !InsideQuotes
2301 54 100       134 if ($ctx->{allow_loose_quotes}) { # 1,foo "boo" d'uh,1
2302 4         13 $ctx->{flag} |= IS_ERROR;
2303 4         7 $$v_ref .= $c;
2304             } else {
2305 50         169 $self->__error_inside_field($ctx, 2034);
2306 50         185 return;
2307             }
2308             }
2309             elsif (defined $c and defined $esc and $esc ne "\0" and $c eq $esc) {
2310             # This means quote_char != escape_char
2311 4655 100       10700 if ($waitingForField) {
    100          
    50          
2312 34         46 $waitingForField = 0;
2313 34 100       79 if ($ctx->{allow_unquoted_escape}) {
2314             # The escape character is the first character of an
2315             # unquoted field
2316             # ... get and store next character
2317 4         13 my $c2 = $self->__get($ctx);
2318 4         11 $$v_ref = "";
2319              
2320 4 100       13 if (!defined $c2) { # EOF
2321 1         2 $ctx->{used}--;
2322 1         3 $self->__error_inside_field($ctx, 2035);
2323 1         5 return;
2324             }
2325 3 100 33     37 if ($c2 eq '0') {
    50 33        
      33        
      0        
      33        
      0        
2326 1         3 $$v_ref .= "\0";
2327             }
2328             elsif (
2329             (defined $quot and $c2 eq $quot) or
2330             (defined $sep and $c2 eq $sep) or
2331             (defined $esc and $c2 eq $esc) or
2332             $ctx->{allow_loose_escapes}
2333             ) {
2334 2 50       8 if ($ctx->{utf8}) {
2335 0         0 $ctx->{flag} |= IS_BINARY;
2336             }
2337 2         7 $$v_ref .= $c2;
2338             } else {
2339 0         0 $self->__parse_inside_quotes($ctx, 2025);
2340 0         0 return;
2341             }
2342             }
2343             }
2344             elsif ($ctx->{flag} & IS_QUOTED) {
2345 4612         10153 my $c2 = $self->__get($ctx);
2346 4612 100       9140 if (!defined $c2) { # EOF
2347 3         6 $ctx->{used}--;
2348 3         10 $self->__error_inside_quotes($ctx, 2024);
2349 3         9 return;
2350             }
2351 4609 100 66     26755 if ($c2 eq '0') {
    100 66        
      100        
      66        
      100        
      66        
2352 2         4 $$v_ref .= "\0";
2353             }
2354             elsif (
2355             (defined $quot and $c2 eq $quot) or
2356             (defined $sep and $c2 eq $sep) or
2357             (defined $esc and $c2 eq $esc) or
2358             $ctx->{allow_loose_escapes}
2359             ) {
2360 4581 50       9560 if ($ctx->{utf8}) {
2361 0         0 $ctx->{flag} |= IS_BINARY;
2362             }
2363 4581         7684 $$v_ref .= $c2;
2364             } else {
2365 26         40 $ctx->{used}--;
2366 26         118 $self->__error_inside_quotes($ctx, 2025);
2367 26         135 return;
2368             }
2369             }
2370             elsif ($v_ref) {
2371 9         30 my $c2 = $self->__get($ctx);
2372 9 100       24 if (!defined $c2) { # EOF
2373 4         6 $ctx->{used}--;
2374 4         15 $self->__error_inside_field($ctx, 2035);
2375 4         14 return;
2376             }
2377 5         9 $$v_ref .= $c2;
2378             }
2379             else {
2380 0         0 $self->__error_inside_field($ctx, 2036);
2381 0         0 return;
2382             }
2383             }
2384             elsif (defined $c and ($c eq "\012" or $c eq '' or (defined $eol and $c eq $eol and $eol ne "\015"))) { # EOL
2385             EOLX:
2386 2354 100       4326 if ($waitingForField) {
2387             # ,1,"foo, 3",,bar,
2388             # ^
2389 121 100 100     422 if ($ctx->{blank_is_undef} or $ctx->{empty_is_undef}) {
2390 8         11 $$v_ref = undef;
2391             } else {
2392 113         161 $$v_ref = "";
2393             }
2394 121 100       233 unless ($ctx->{is_bound}) {
2395 120         214 push @$fields, $$v_ref;
2396             }
2397 121 100 66     303 if ($ctx->{keep_meta_info} and $fflags) {
2398 6         11 push @$fflags, $ctx->{flag};
2399             }
2400 121         442 return 1;
2401             }
2402 2233 100       4756 if ($ctx->{flag} & IS_QUOTED) {
    100          
2403             # ,1,"foo\n 3",,bar,
2404             # ^
2405 767         1092 $ctx->{flag} |= IS_BINARY;
2406 767 100       1436 unless ($ctx->{binary}) {
2407 29         99 $self->__error_inside_quotes($ctx, 2021);
2408 29         93 return;
2409             }
2410 738         1137 $$v_ref .= $c;
2411             }
2412             elsif ($ctx->{verbatim}) {
2413             # ,1,foo\n 3,,bar,
2414             # This feature should be deprecated
2415 11         17 $ctx->{flag} |= IS_BINARY;
2416 11 100       22 unless ($ctx->{binary}) {
2417 1         5 $self->__error_inside_field($ctx, 2030);
2418 1         5 return;
2419             }
2420 10 100 100     33 $$v_ref .= $c unless $ctx->{eol} eq $c and $ctx->{useIO};
2421             }
2422             else {
2423             # sep=,
2424             # ^
2425 1455 100 100     3713 if (!$ctx->{recno} and $ctx->{fld_idx} == 1 and $ctx->{useIO} and $hit =~ /^sep=(.{1,16})$/i) {
      100        
      100        
2426 4         10 $ctx->{sep} = $1;
2427 32     32   82705 use bytes;
  32         80  
  32         133  
2428 4         7 my $len = length $ctx->{sep};
2429 4 50       5 if ($len <= 16) {
2430 4 100       9 $ctx->{sep_len} = $len == 1 ? 0 : $len;
2431 4         25 return $self->____parse($ctx, $src, $fields, $fflags);
2432             }
2433             }
2434              
2435             # ,1,"foo\n 3",,bar
2436             # ^
2437 1451         3795 $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum);
2438 1451         5404 return 1;
2439             }
2440             }
2441             elsif (defined $c and $c eq "\015" and !$ctx->{verbatim}) {
2442 962 100       1861 if ($waitingForField) {
2443 92         120 $waitingForField = 0;
2444 92 100       203 if ($ctx->{eol_is_cr}) {
2445             # ,1,"foo\n 3",,bar,\r
2446             # ^
2447 18         23 $c = "\012";
2448 18         880 goto RESTART;
2449             }
2450              
2451 74         195 my $c2 = $self->__get($ctx);
2452 74 100       173 if (!defined $c2) { # EOF
2453             # ,1,"foo\n 3",,bar,\r
2454             # ^
2455 5         7 $c = undef;
2456 5         295 goto RESTART;
2457             }
2458 69 100       145 if ($c2 eq "\012") { # \r is not optional before EOLX!
2459             # ,1,"foo\n 3",,bar,\r\n
2460             # ^
2461 60         93 $c = $c2;
2462 60         2812 goto RESTART;
2463             }
2464              
2465 9 100 66     58 if ($ctx->{useIO} and !$ctx->{eol_len} and $c2 !~ /[^\x09\x20-\x7E]/) {
      100        
2466             # ,1,"foo\n 3",,bar,\r
2467             # baz,4
2468             # ^
2469 1         7 $self->__set_eol_is_cr($ctx);
2470 1         2 $ctx->{used}--;
2471 1         3 $ctx->{has_ahead} = 1;
2472 1         4 $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum);
2473 1         5 return 1;
2474             }
2475              
2476             # ,1,"foo\n 3",,bar,\r\t
2477             # ^
2478 8         15 $ctx->{used}--;
2479 8         25 $self->__error_inside_field($ctx, 2031);
2480 8         28 return;
2481             }
2482 870 100       1572 if ($ctx->{flag} & IS_QUOTED) {
2483             # ,1,"foo\r 3",,bar,\r\t
2484             # ^
2485 593         869 $ctx->{flag} |= IS_BINARY;
2486 593 100       1091 unless ($ctx->{binary}) {
2487 70         187 $self->__error_inside_quotes($ctx, 2022);
2488 70         225 return;
2489             }
2490 523         796 $$v_ref .= $c;
2491             }
2492             else {
2493 277 100       570 if ($ctx->{eol_is_cr}) {
2494             # ,1,"foo\n 3",,bar\r
2495             # ^
2496 154         429 $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum);
2497 154         639 return 1;
2498             }
2499              
2500 123         317 my $c2 = $self->__get($ctx);
2501 123 100 100     485 if (defined $c2 and $c2 eq "\012") { # \r is not optional before EOLX!
2502             # ,1,"foo\n 3",,bar\r\n
2503             # ^
2504 108         336 $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum);
2505 108         357 return 1;
2506             }
2507              
2508 15 100 66     100 if ($ctx->{useIO} and !$ctx->{eol_len} and $c2 !~ /[^\x09\x20-\x7E]/) {
      100        
2509             # ,1,"foo\n 3",,bar\r
2510             # baz,4
2511             # ^
2512 4         41 $self->__set_eol_is_cr($ctx);
2513 4         11 $ctx->{used}--;
2514 4         10 $ctx->{has_ahead} = 1;
2515 4         17 $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum);
2516 4         20 return 1;
2517             }
2518              
2519             # ,1,"foo\n 3",,bar\r\t
2520             # ^
2521 11         34 $self->__error_inside_field($ctx, 2032);
2522 11         38 return;
2523             }
2524             }
2525             else {
2526 31959 50 66     64537 if ($ctx->{eolx} and $c eq $eol) {
2527 0         0 $c = '';
2528 0         0 goto EOLX;
2529             }
2530              
2531 31959 100       49443 if ($waitingForField) {
2532 553 100 100     1492 if ($ctx->{allow_whitespace} and $self->__is_whitespace($ctx, $c)) {
2533 231         332 do {
2534 341         626 $c = $self->__get($ctx);
2535 341 100       904 last if !defined $c;
2536             } while $self->__is_whitespace($ctx, $c);
2537 230         9939 goto RESTART;
2538             }
2539 322         510 $waitingForField = 0;
2540 322         14331 goto RESTART;
2541             }
2542 31406 100       49886 if ($ctx->{flag} & IS_QUOTED) {
2543 29395 100 66     93712 if (!defined $c or $c =~ /[^\x09\x20-\x7E]/) {
2544 3249         5082 $ctx->{flag} |= IS_BINARY;
2545 3249 100 100     5868 unless ($ctx->{binary} or $ctx->{utf8}) {
2546 2         6 $self->__error_inside_quotes($ctx, 2026);
2547 2         7 return;
2548             }
2549             }
2550 29393         43629 $$v_ref .= $c;
2551             } else {
2552 2011 100 100     6547 if (!defined $c or $c =~ /[^\x09\x20-\x7E]/) {
2553 407         635 $ctx->{flag} |= IS_BINARY;
2554 407 50 66     744 unless ($ctx->{binary} or $ctx->{utf8}) {
2555 9         41 $self->__error_inside_field($ctx, 2037);
2556 9         30 return;
2557             }
2558             }
2559 2002         3027 $$v_ref .= $c;
2560             }
2561             }
2562 48580 100 100     276927 last LOOP if $ctx->{useIO} and $ctx->{verbatim} and $ctx->{used} == $ctx->{size};
      100        
2563             }
2564             }
2565              
2566 368 100       772 if ($waitingForField) {
2567 316 100 66     1236 if ($seenSomething or !$ctx->{useIO}) {
2568             # new field
2569 32 100       78 if (!$v_ref) {
2570 31 50       80 if ($ctx->{is_bound}) {
2571 0         0 $v_ref = $self->__bound_field($ctx, $fnum, 0);
2572             } else {
2573 31         53 $value = '';
2574 31         50 $v_ref = \$value;
2575             }
2576 31         107 $fnum++;
2577 31 50       69 return unless $v_ref;
2578 31         48 $ctx->{flag} = 0;
2579 31         45 $ctx->{fld_idx}++;
2580             }
2581 32 100 100     133 if ($ctx->{blank_is_undef} or $ctx->{empty_is_undef}) {
2582 9         19 $$v_ref = undef;
2583             } else {
2584 23         44 $$v_ref = "";
2585             }
2586 32 50       82 unless ($ctx->{is_bound}) {
2587 32         66 push @$fields, $$v_ref;
2588             }
2589 32 100 66     115 if ($ctx->{keep_meta_info} and $fflags) {
2590 3         5 push @$fflags, $ctx->{flag};
2591             }
2592 32         129 return 1;
2593             }
2594 284         846 $self->SetDiag(2012);
2595 284         887 return;
2596             }
2597              
2598 52 100       145 if ($ctx->{flag} & IS_QUOTED) {
2599 14         51 $self->__error_inside_quotes($ctx, 2027);
2600 13         40 return;
2601             }
2602              
2603 38 50       90 if ($v_ref) {
2604 38         95 $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum);
2605             }
2606 38         132 return 1;
2607             }
2608              
2609             sub __get_from_src {
2610 4676     4676   8763 my ($self, $ctx, $src) = @_;
2611 4676 100 100     17684 return 1 if defined $ctx->{tmp} and $ctx->{used} <= 0;
2612 2585 50       5101 return 1 if $ctx->{used} < $ctx->{size};
2613 2585 100       4745 return unless $ctx->{useIO};
2614 2524         53898 my $res = $src->getline;
2615 2524 100       66238 if (defined $res) {
    100          
2616 2073 50       3958 if ($ctx->{has_ahead}) {
2617 0         0 $ctx->{tmp} = $self->{_AHEAD};
2618 0 0       0 $ctx->{tmp} .= $ctx->{eol} if $ctx->{eol_len};
2619 0         0 $ctx->{tmp} .= $res;
2620 0         0 $ctx->{has_ahead} = 0;
2621             } else {
2622 2073         3253 $ctx->{tmp} = $res;
2623             }
2624 2073 50       4886 if ($ctx->{size} = length $ctx->{tmp}) {
2625 2073         2864 $ctx->{used} = -1;
2626 2073 100       5089 $ctx->{utf8} = 1 if utf8::is_utf8($ctx->{tmp});
2627 2073         5458 pos($ctx->{tmp}) = 0;
2628 2073         6086 return 1;
2629             }
2630             } elsif (delete $ctx->{has_leftover}) {
2631 147         301 $ctx->{tmp} = $self->{_AHEAD};
2632 147         201 $ctx->{has_ahead} = 0;
2633 147         198 $ctx->{useIO} |= useIO_EOF;
2634 147 50       296 if ($ctx->{size} = length $ctx->{tmp}) {
2635 147         179 $ctx->{used} = -1;
2636 147 50       368 $ctx->{utf8} = 1 if utf8::is_utf8($ctx->{tmp});
2637 147         292 pos($ctx->{tmp}) = 0;
2638 147         395 return 1;
2639             }
2640             }
2641 304 100       883 $ctx->{tmp} = '' unless defined $ctx->{tmp};
2642 304         510 $ctx->{useIO} |= useIO_EOF;
2643 304         760 return;
2644             }
2645              
2646             sub __set_eol_is_cr {
2647 6     6   17 my ($self, $ctx) = @_;
2648 6         15 $ctx->{eol} = "\015";
2649 6         16 $ctx->{eol_is_cr} = 1;
2650 6         12 $ctx->{eol_len} = 1;
2651 6         39 %{$self->{_CACHE}} = %$ctx;
  6         102  
2652              
2653 6         34 $self->{eol} = $ctx->{eol};
2654             }
2655              
2656             sub __bound_field {
2657 101     101   216 my ($self, $ctx, $i, $keep) = @_;
2658 101 100       208 if ($i >= $ctx->{is_bound}) {
2659 3         18 $self->SetDiag(3006);
2660 3         7 return;
2661             }
2662 98 50       242 if (ref $ctx->{bound} eq 'ARRAY') {
2663 98         153 my $ref = $ctx->{bound}[$i];
2664 98 50       188 if (ref $ref) {
2665 98 100       211 if ($keep) {
2666 14         28 return $ref;
2667             }
2668 84 100       226 unless (Scalar::Util::readonly($$ref)) {
2669 83         129 $$ref = "";
2670 83         169 return $ref;
2671             }
2672             }
2673             }
2674 1         7 $self->SetDiag(3008);
2675 1         3 return;
2676             }
2677              
2678             sub __get {
2679 17245     17245   25892 my ($self, $ctx) = @_;
2680 17245 50       31031 return unless defined $ctx->{used};
2681 17245 100       33798 return if $ctx->{used} >= $ctx->{size};
2682 15910         22746 my $pos = pos($ctx->{tmp});
2683 15910 50       106839 if ($ctx->{tmp} =~ /\G($ctx->{_re}|.)/gs) {
2684 15910         34312 my $c = $1;
2685 15910 100       35117 if ($c =~ /[^\x09\x20-\x7e]/) {
2686 1896         3126 $ctx->{flag} |= IS_BINARY;
2687             }
2688 15910         24397 $ctx->{used} = pos($ctx->{tmp});
2689 15910         44144 return $c;
2690             } else {
2691 0         0 pos($ctx->{tmp}) = $pos;
2692 0         0 return;
2693             }
2694             }
2695              
2696             sub __error_inside_quotes {
2697 189     189   365 my ($self, $ctx, $error) = @_;
2698 189         502 $self->__parse_error($ctx, $error, $ctx->{used} - 1);
2699             }
2700              
2701             sub __error_inside_field {
2702 84     84   169 my ($self, $ctx, $error) = @_;
2703 84         229 $self->__parse_error($ctx, $error, $ctx->{used} - 1);
2704             }
2705              
2706             sub __parse_error {
2707 290     290   495 my ($self, $ctx, $error, $pos) = @_;
2708 290         446 $self->{_ERROR_POS} = $pos;
2709 290         441 $self->{_ERROR_FLD} = $ctx->{fld_idx};
2710 290 50       641 $self->{_ERROR_INPUT} = $ctx->{tmp} if $ctx->{tmp};
2711 290         685 $self->SetDiag($error);
2712 289         457 return;
2713             }
2714              
2715             sub __is_whitespace {
2716 5064     5064   9356 my ($self, $ctx, $c) = @_;
2717 5064 100       9629 return unless defined $c;
2718             return (
2719             (!defined $ctx->{sep} or $c ne $ctx->{sep}) &&
2720             (!defined $ctx->{quo} or $c ne $ctx->{quo}) &&
2721 4529   33     24989 (!defined $ctx->{escape_char} or $c ne $ctx->{escape_char}) &&
2722             ($c eq " " or $c eq "\t")
2723             );
2724             }
2725              
2726             sub __push_value { # AV_PUSH (part of)
2727 20400     20400   35902 my ($self, $ctx, $v_ref, $fields, $fflags, $flag, $fnum) = @_;
2728 20400 100       36785 utf8::encode($$v_ref) if $ctx->{utf8};
2729 20400 100 66     39094 if ($ctx->{formula} && $$v_ref && substr($$v_ref, 0, 1) eq '=') {
      100        
2730 12         42 my $value = $self->_formula($ctx, $$v_ref, $fnum);
2731 10 100       27 push @$fields, defined $value ? $value : undef;
2732 10         17 return;
2733             }
2734 20388 100 66     72675 if (
      100        
      100        
2735             (!defined $$v_ref or $$v_ref eq '') and
2736             ($ctx->{empty_is_undef} or (!($flag & IS_QUOTED) and $ctx->{blank_is_undef}))
2737             ) {
2738 20         36 $$v_ref = undef;
2739             } else {
2740 20368 100 100     46556 if ($ctx->{allow_whitespace} && !($flag & IS_QUOTED)) {
2741 1756         3857 $$v_ref =~ s/[ \t]+$//;
2742             }
2743 20368 100 66     47062 if ($flag & IS_BINARY and $ctx->{decode_utf8} and ($ctx->{utf8} || _is_valid_utf8($$v_ref))) {
      100        
      66        
2744 2266         6086 utf8::decode($$v_ref);
2745             }
2746             }
2747 20388 100       37026 unless ($ctx->{is_bound}) {
2748 20307         42133 push @$fields, $$v_ref;
2749             }
2750 20388 100 66     45345 if ($ctx->{keep_meta_info} and $fflags) {
2751 96         182 push @$fflags, $flag;
2752             }
2753             }
2754              
2755             sub getline {
2756 1435     1435 1 330142 my ($self, $io) = @_;
2757              
2758 1435         2179 my (@fields, @fflags);
2759 1435         3655 my $res = $self->__parse(\@fields, \@fflags, $io, 1);
2760 1435 100       6823 $res ? \@fields : undef;
2761             }
2762              
2763             sub getline_all {
2764 264     264 1 538 my ( $self, $io, $offset, $len ) = @_;
2765              
2766 264         491 my $ctx = $self->_setup_ctx;
2767              
2768 264         365 my $tail = 0;
2769 264         356 my $n = 0;
2770 264   100     964 $offset ||= 0;
2771              
2772 264 100       488 if ( $offset < 0 ) {
2773 12         26 $tail = -$offset;
2774 12         18 $offset = -1;
2775             }
2776              
2777 264         405 my (@row, @list);
2778 264         747 while ($self->___parse($ctx, \@row, undef, $io, 1)) {
2779 562         1261 $ctx = $self->_setup_ctx;
2780              
2781 562 100       1222 if ($offset > 0) {
2782 12         20 $offset--;
2783 12         27 @row = ();
2784 12         35 next;
2785             }
2786 550 100 100     1682 if ($n++ >= $tail and $tail) {
2787 12         18 shift @list;
2788 12         26 $n--;
2789             }
2790 550 100 100     1753 if (($ctx->{has_hooks} || 0) & HOOK_AFTER_PARSE) {
2791 117 100       240 unless ($self->_hook(after_parse => \@row)) {
2792 63         108 @row = ();
2793 63         134 next;
2794             }
2795             }
2796 487         1388 push @list, [@row];
2797 487         1049 @row = ();
2798              
2799 487 100 100     1673 last if defined $len && $n >= $len and $offset >= 0; # exceeds limit size
      100        
2800             }
2801              
2802 264 100 100     711 if ( defined $len && $n > $len ) {
2803 8         27 @list = splice( @list, 0, $len);
2804             }
2805              
2806 264         1475 return \@list;
2807             }
2808              
2809             sub _is_valid_utf8 {
2810 3900 100   3900   53850 return ( $_[0] =~ /^(?:
2811             [\x00-\x7F]
2812             |[\xC2-\xDF][\x80-\xBF]
2813             |[\xE0][\xA0-\xBF][\x80-\xBF]
2814             |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
2815             |[\xED][\x80-\x9F][\x80-\xBF]
2816             |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
2817             |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
2818             |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
2819             |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
2820             )+$/x ) ? 1 : 0;
2821             }
2822              
2823             ################################################################################
2824             # methods for errors
2825             ################################################################################
2826              
2827             sub _set_error_diag {
2828 1     1   37 my ( $self, $error, $pos ) = @_;
2829              
2830 1         4 $self->SetDiag($error);
2831              
2832 1 50       20 if (defined $pos) {
2833 0         0 $_[0]->{_ERROR_POS} = $pos;
2834             }
2835              
2836 1         10 return;
2837             }
2838              
2839             sub error_input {
2840 8     8 1 599 my $self = shift;
2841 8 100 66     54 if ($self and ((Scalar::Util::reftype($self) || '') eq 'HASH' or (ref $self) =~ /^Text::CSV/)) {
      66        
2842 4         35 return $self->{_ERROR_INPUT};
2843             }
2844 4         18 return;
2845             }
2846              
2847             sub _sv_diag {
2848 3227     3227   5343 my ($self, $error) = @_;
2849 3227         12267 bless [$error, $ERRORS->{$error}], 'Text::CSV::ErrorDiag';
2850             }
2851              
2852             sub _set_diag {
2853 1626     1626   3016 my ($self, $ctx, $error) = @_;
2854              
2855 1626         2863 $last_error = $self->_sv_diag($error);
2856 1626         3703 $self->{_ERROR_DIAG} = $last_error;
2857 1626 100       3496 if ($error == 0) {
2858 4         9 $self->{_ERROR_POS} = 0;
2859 4         8 $self->{_ERROR_FLD} = 0;
2860 4         9 $self->{_ERROR_INPUT} = undef;
2861 4         7 $ctx->{has_error_input} = 0;
2862             }
2863 1626 100       3184 if ($error == 2012) { # EOF
2864 285         444 $self->{_EOF} = 1;
2865             }
2866 1626 100       3067 if ($ctx->{auto_diag}) {
2867 239         619 $self->error_diag;
2868             }
2869 1625         6604 return $last_error;
2870             }
2871              
2872             sub SetDiag {
2873 3227     3227 1 8445 my ($self, $error, $errstr) = @_;
2874 3227         4101 my $res;
2875 3227 100       6274 if (ref $self) {
2876 1626         3470 my $ctx = $self->_setup_ctx;
2877 1626         3892 $res = $self->_set_diag($ctx, $error);
2878              
2879             } else {
2880 1601         3119 $res = $self->_sv_diag($error);
2881             }
2882 3226 100       7073 if (defined $errstr) {
2883 796         2136 $res->[1] = $errstr;
2884             }
2885 3226         28369 $res;
2886             }
2887              
2888             ################################################################################
2889             package Text::CSV::ErrorDiag;
2890              
2891 32     32   89214 use strict;
  32         68  
  32         4150  
2892             use overload (
2893 32         261 '""' => \&stringify,
2894             '+' => \&numeric,
2895             '-' => \&numeric,
2896             '*' => \&numeric,
2897             '/' => \&numeric,
2898             fallback => 1,
2899 32     32   35650 );
  32         29741  
2900              
2901              
2902             sub numeric {
2903 4302     4302   8162 my ($left, $right) = @_;
2904 4302 50       14747 return ref $left ? $left->[0] : $right->[0];
2905             }
2906              
2907              
2908             sub stringify {
2909 2292     2292   463141 $_[0]->[1];
2910             }
2911             ################################################################################
2912             1;
2913             __END__