← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:50 2015

Filename/usr/lib/x86_64-linux-gnu/perl5/5.20/Text/CSV_XS.pm
StatementsExecuted 22 statements in 5.29ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11128µs34µsText::CSV_XS::::BEGIN@24Text::CSV_XS::BEGIN@24
11126µs26µsText::CSV_XS::::bootstrapText::CSV_XS::bootstrap (xsub)
11111µs22µsText::CSV_XS::::BEGIN@23Text::CSV_XS::BEGIN@23
1116µs34µsText::CSV_XS::::BEGIN@28Text::CSV_XS::BEGIN@28
1116µs37µsText::CSV_XS::::BEGIN@30Text::CSV_XS::BEGIN@30
1113µs3µsText::CSV_XS::::BEGIN@27Text::CSV_XS::BEGIN@27
1113µs3µsText::CSV_XS::::SetDiagText::CSV_XS::SetDiag (xsub)
0000s0sText::CSV_XS::::IVText::CSV_XS::IV
0000s0sText::CSV_XS::::NVText::CSV_XS::NV
0000s0sText::CSV_XS::::PVText::CSV_XS::PV
0000s0sText::CSV_XS::::_check_sanityText::CSV_XS::_check_sanity
0000s0sText::CSV_XS::::_csv_attrText::CSV_XS::_csv_attr
0000s0sText::CSV_XS::::_set_attr_CText::CSV_XS::_set_attr_C
0000s0sText::CSV_XS::::_set_attr_NText::CSV_XS::_set_attr_N
0000s0sText::CSV_XS::::_set_attr_XText::CSV_XS::_set_attr_X
0000s0sText::CSV_XS::::_unhealthy_whitespaceText::CSV_XS::_unhealthy_whitespace
0000s0sText::CSV_XS::::allow_loose_escapesText::CSV_XS::allow_loose_escapes
0000s0sText::CSV_XS::::allow_loose_quotesText::CSV_XS::allow_loose_quotes
0000s0sText::CSV_XS::::allow_unquoted_escapeText::CSV_XS::allow_unquoted_escape
0000s0sText::CSV_XS::::allow_whitespaceText::CSV_XS::allow_whitespace
0000s0sText::CSV_XS::::always_quoteText::CSV_XS::always_quote
0000s0sText::CSV_XS::::auto_diagText::CSV_XS::auto_diag
0000s0sText::CSV_XS::::binaryText::CSV_XS::binary
0000s0sText::CSV_XS::::bind_columnsText::CSV_XS::bind_columns
0000s0sText::CSV_XS::::blank_is_undefText::CSV_XS::blank_is_undef
0000s0sText::CSV_XS::::callbacksText::CSV_XS::callbacks
0000s0sText::CSV_XS::::column_namesText::CSV_XS::column_names
0000s0sText::CSV_XS::::combineText::CSV_XS::combine
0000s0sText::CSV_XS::::csvText::CSV_XS::csv
0000s0sText::CSV_XS::::decode_utf8Text::CSV_XS::decode_utf8
0000s0sText::CSV_XS::::diag_verboseText::CSV_XS::diag_verbose
0000s0sText::CSV_XS::::empty_is_undefText::CSV_XS::empty_is_undef
0000s0sText::CSV_XS::::eofText::CSV_XS::eof
0000s0sText::CSV_XS::::eolText::CSV_XS::eol
0000s0sText::CSV_XS::::error_diagText::CSV_XS::error_diag
0000s0sText::CSV_XS::::escape_charText::CSV_XS::escape_char
0000s0sText::CSV_XS::::fieldsText::CSV_XS::fields
0000s0sText::CSV_XS::::fragmentText::CSV_XS::fragment
0000s0sText::CSV_XS::::getline_hrText::CSV_XS::getline_hr
0000s0sText::CSV_XS::::getline_hr_allText::CSV_XS::getline_hr_all
0000s0sText::CSV_XS::::is_binaryText::CSV_XS::is_binary
0000s0sText::CSV_XS::::is_missingText::CSV_XS::is_missing
0000s0sText::CSV_XS::::is_quotedText::CSV_XS::is_quoted
0000s0sText::CSV_XS::::keep_meta_infoText::CSV_XS::keep_meta_info
0000s0sText::CSV_XS::::meta_infoText::CSV_XS::meta_info
0000s0sText::CSV_XS::::newText::CSV_XS::new
0000s0sText::CSV_XS::::parseText::CSV_XS::parse
0000s0sText::CSV_XS::::print_hrText::CSV_XS::print_hr
0000s0sText::CSV_XS::::quoteText::CSV_XS::quote
0000s0sText::CSV_XS::::quote_binaryText::CSV_XS::quote_binary
0000s0sText::CSV_XS::::quote_charText::CSV_XS::quote_char
0000s0sText::CSV_XS::::quote_nullText::CSV_XS::quote_null
0000s0sText::CSV_XS::::quote_spaceText::CSV_XS::quote_space
0000s0sText::CSV_XS::::record_numberText::CSV_XS::record_number
0000s0sText::CSV_XS::::sepText::CSV_XS::sep
0000s0sText::CSV_XS::::sep_charText::CSV_XS::sep_char
0000s0sText::CSV_XS::::statusText::CSV_XS::status
0000s0sText::CSV_XS::::stringText::CSV_XS::string
0000s0sText::CSV_XS::::typesText::CSV_XS::types
0000s0sText::CSV_XS::::verbatimText::CSV_XS::verbatim
0000s0sText::CSV_XS::::versionText::CSV_XS::version
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Text::CSV_XS;
2
3# Copyright (c) 2007-2014 H.Merijn Brand. All rights reserved.
4# Copyright (c) 1998-2001 Jochen Wiedmann. All rights reserved.
5# Copyright (c) 1997 Alan Citterman. All rights reserved.
6#
7# This program is free software; you can redistribute it and/or
8# modify it under the same terms as Perl itself.
9
10# HISTORY
11#
12# Written by:
13# Jochen Wiedmann <joe@ispsoft.de>
14#
15# Based on Text::CSV by:
16# Alan Citterman <alan@mfgrtl.com>
17#
18# Extended and Remodelled by:
19# H.Merijn Brand (h.m.brand@xs4all.nl)
20
21115µsrequire 5.006001;
22
23226µs232µs
# spent 22µs (11+11) within Text::CSV_XS::BEGIN@23 which was called: # once (11µs+11µs) by Text::CSV::BEGIN@1 at line 23
use strict;
# spent 22µs making 1 call to Text::CSV_XS::BEGIN@23 # spent 11µs making 1 call to strict::import
24226µs239µs
# spent 34µs (28+6) within Text::CSV_XS::BEGIN@24 which was called: # once (28µs+6µs) by Text::CSV::BEGIN@1 at line 24
use warnings;
# spent 34µs making 1 call to Text::CSV_XS::BEGIN@24 # spent 6µs making 1 call to warnings::import
25
2611µsrequire Exporter;
27218µs13µs
# spent 3µs within Text::CSV_XS::BEGIN@27 which was called: # once (3µs+0s) by Text::CSV::BEGIN@1 at line 27
use DynaLoader ();
# spent 3µs making 1 call to Text::CSV_XS::BEGIN@27
28229µs262µs
# spent 34µs (6+28) within Text::CSV_XS::BEGIN@28 which was called: # once (6µs+28µs) by Text::CSV::BEGIN@1 at line 28
use Carp;
# spent 34µs making 1 call to Text::CSV_XS::BEGIN@28 # spent 28µs making 1 call to Exporter::import
29
3025.11ms268µs
# spent 37µs (6+31) within Text::CSV_XS::BEGIN@30 which was called: # once (6µs+31µs) by Text::CSV::BEGIN@1 at line 30
use vars qw( $VERSION @ISA @EXPORT_OK );
# spent 37µs making 1 call to Text::CSV_XS::BEGIN@30 # spent 31µs making 1 call to vars::import
311400ns$VERSION = "1.11";
32113µs@ISA = qw( DynaLoader Exporter );
331500ns@EXPORT_OK = qw( csv );
34112µs1892µsbootstrap Text::CSV_XS $VERSION;
# spent 892µs making 1 call to DynaLoader::bootstrap
35
36sub PV { 0 }
37sub IV { 1 }
38sub NV { 2 }
39
40# version
41#
42# class/object method expecting no arguments and returning the version
43# number of Text::CSV. there are no side-effects.
44
45sub version
46{
47 return $VERSION;
48 } # version
49
50# new
51#
52# class/object method expecting no arguments and returning a reference to
53# a newly created Text::CSV object.
54
55111µsmy %def_attr = (
56 eol => '',
57 sep_char => ',',
58 quote_char => '"',
59 escape_char => '"',
60 binary => 0,
61 decode_utf8 => 1,
62 auto_diag => 0,
63 diag_verbose => 0,
64 blank_is_undef => 0,
65 empty_is_undef => 0,
66 allow_whitespace => 0,
67 allow_loose_quotes => 0,
68 allow_loose_escapes => 0,
69 allow_unquoted_escape => 0,
70 always_quote => 0,
71 quote_space => 1,
72 quote_null => 1,
73 quote_binary => 1,
74 keep_meta_info => 0,
75 verbatim => 0,
76 types => undef,
77 callbacks => undef,
78
79 _EOF => 0,
80 _RECNO => 0,
81 _STATUS => undef,
82 _FIELDS => undef,
83 _FFLAGS => undef,
84 _STRING => undef,
85 _ERROR_INPUT => undef,
86 _COLUMN_NAMES => undef,
87 _BOUND_COLUMNS => undef,
88 _AHEAD => undef,
89 );
9011µsmy %attr_alias = (
91 quote_always => "always_quote",
92 verbose_diag => "diag_verbose",
93 );
9417µs13µsmy $last_new_err = Text::CSV_XS->SetDiag (0);
# spent 3µs making 1 call to Text::CSV_XS::SetDiag
95
96# NOT a method: is also used before bless
97sub _unhealthy_whitespace
98{
99 my $self = shift;
100 $_[0] or return 0; # no checks needed without allow_whitespace
101
102 my $quo = $self->{quote};
103 defined $quo && length ($quo) or $quo = $self->{quote_char};
104 my $esc = $self->{escape_char};
105
106 (defined $quo && $quo =~ m/^[ \t]/) || (defined $esc && $esc =~ m/^[ \t]/) and
107 return 1002;
108
109 return 0;
110 } # _sane_whitespace
111
112sub _check_sanity
113{
114 my $self = shift;
115
116 my $sep = $self->{sep};
117 defined $sep && length ($sep) or $sep = $self->{sep_char};
118 my $quo = $self->{quote};
119 defined $quo && length ($quo) or $quo = $self->{quote_char};
120 my $esc = $self->{escape_char};
121
122# use DP;::diag ("SEP: '", DPeek ($sep),
123# "', QUO: '", DPeek ($quo),
124# "', ESC: '", DPeek ($esc),"'");
125 # sep_char cannot be undefined
126 defined $quo && $quo eq $sep and return 1001;
127 defined $esc && $esc eq $sep and return 1001;
128
129 defined $_ && $_ =~ m/[\r\n]/ and return 1003 for $sep, $quo, $esc;
130
131 return _unhealthy_whitespace ($self, $self->{allow_whitespace});
132 } # _check_sanity
133
134sub new
135{
136 $last_new_err = Text::CSV_XS->SetDiag (1000,
137 "usage: my \$csv = Text::CSV_XS->new ([{ option => value, ... }]);");
138
139 my $proto = shift;
140 my $class = ref ($proto) || $proto or return;
141 @_ > 0 && ref $_[0] ne "HASH" and return;
142 my $attr = shift || {};
143 my %attr = map {
144 my $k = m/^[a-zA-Z]\w+$/ ? lc $_ : $_;
145 exists $attr_alias{$k} and $k = $attr_alias{$k};
146 $k => $attr->{$_};
147 } keys %$attr;
148
149 my $sep_aliased = 0;
150 if (defined $attr{sep}) {
151 $attr{sep_char} = delete $attr{sep};
152 $sep_aliased = 1;
153 }
154 my $quote_aliased = 0;
155 if (defined $attr{quote}) {
156 $attr{quote_char} = delete $attr{quote};
157 $quote_aliased = 1;
158 }
159 for (keys %attr) {
160 if (m/^[a-z]/ && exists $def_attr{$_}) {
161 # uncoverable condition false
162 defined $attr{$_} && $] >= 5.008002 && m/_char$/ and
163 utf8::decode ($attr{$_});
164 next;
165 }
166# croak?
167 $last_new_err = Text::CSV_XS->SetDiag (1000, "INI - Unknown attribute '$_'");
168 $attr{auto_diag} and error_diag ();
169 return;
170 }
171 if ($sep_aliased) {
172 my @b = unpack "U0C*", $attr{sep_char};
173 if (@b > 1) {
174 $attr{sep} = $attr{sep_char};
175 $attr{sep_char} = "\0";
176 }
177 else {
178 $attr{sep} = undef;
179 }
180 }
181 if ($quote_aliased) {
182 my @b = unpack "U0C*", $attr{quote_char};
183 if (@b > 1) {
184 $attr{quote} = $attr{quote_char};
185 $attr{quote_char} = "\0";
186 }
187 else {
188 $attr{quote} = undef;
189 }
190 }
191
192 my $self = { %def_attr, %attr };
193 if (my $ec = _check_sanity ($self)) {
194 $last_new_err = Text::CSV_XS->SetDiag ($ec);
195 $attr{auto_diag} and error_diag ();
196 return;
197 }
198 if (defined $self->{callbacks} && ref $self->{callbacks} ne "HASH") {
199 warn "The 'callbacks' attribute is set but is not a hash: ignored\n";
200 $self->{callbacks} = undef;
201 }
202
203 $last_new_err = Text::CSV_XS->SetDiag (0);
204 defined $\ && !exists $attr{eol} and $self->{eol} = $\;
205 bless $self, $class;
206 defined $self->{types} and $self->types ($self->{types});
207 $self;
208 } # new
209
210# Keep in sync with XS!
21116µsmy %_cache_id = ( # Only expose what is accessed from within PM
212 quote_char => 0,
213 escape_char => 1,
214 sep_char => 2,
215 sep => 38, # 38 .. 54
216 binary => 3,
217 keep_meta_info => 4,
218 always_quote => 5,
219 allow_loose_quotes => 6,
220 allow_loose_escapes => 7,
221 allow_unquoted_escape => 8,
222 allow_whitespace => 9,
223 blank_is_undef => 10,
224 eol => 11,
225 quote => 15,
226 verbatim => 22,
227 empty_is_undef => 23,
228 auto_diag => 24,
229 diag_verbose => 33,
230 quote_space => 25,
231 quote_null => 31,
232 quote_binary => 32,
233 decode_utf8 => 35,
234 _has_hooks => 36,
235 _is_bound => 26, # 26 .. 29
236 );
237
238# A `character'
239sub _set_attr_C
240{
241 my ($self, $name, $val, $ec) = @_;
242 defined $val or $val = 0;
243 $] >= 5.008002 and utf8::decode ($val);
244 $self->{$name} = $val;
245 $ec = _check_sanity ($self) and
246 croak ($self->SetDiag ($ec));
247 $self->_cache_set ($_cache_id{$name}, $val);
248 } # _set_attr_C
249
250# A flag
251sub _set_attr_X
252{
253 my ($self, $name, $val) = @_;
254 defined $val or $val = 0;
255 $self->{$name} = $val;
256 $self->_cache_set ($_cache_id{$name}, 0 + $val);
257 } # _set_attr_X
258
259# A number
260sub _set_attr_N
261{
262 my ($self, $name, $val) = @_;
263 $self->{$name} = $val;
264 $self->_cache_set ($_cache_id{$name}, 0 + $val);
265 } # _set_attr_N
266
267# Accessor methods.
268# It is unwise to change them halfway through a single file!
269sub quote_char
270{
271 my $self = shift;
272 if (@_) {
273 $self->_set_attr_C ("quote_char", shift);
274 $self->_cache_set ($_cache_id{quote}, "");
275 }
276 $self->{quote_char};
277 } # quote_char
278
279sub quote
280{
281 my $self = shift;
282 if (@_) {
283 my $quote = shift;
284 defined $quote or $quote = "";
285 $] >= 5.008002 and utf8::decode ($quote);
286 my @b = unpack "U0C*", $quote;
287 if (@b > 1) {
288 $self->quote_char ("\0");
289 }
290 else {
291 $self->quote_char ($quote);
292 $quote = "";
293 }
294 $self->{quote} = $quote;
295
296 my $ec = _check_sanity ($self);
297 $ec and croak ($self->SetDiag ($ec));
298
299 $self->_cache_set ($_cache_id{quote}, $quote);
300 }
301 my $quote = $self->{quote};
302 defined $quote && length ($quote) ? $quote : $self->{quote_char};
303 } # quote
304
305sub escape_char
306{
307 my $self = shift;
308 @_ and $self->_set_attr_C ("escape_char", shift);
309 $self->{escape_char};
310 } # escape_char
311
312sub sep_char
313{
314 my $self = shift;
315 if (@_) {
316 $self->_set_attr_C ("sep_char", shift);
317 $self->_cache_set ($_cache_id{sep}, "");
318 }
319 $self->{sep_char};
320 } # sep_char
321
322sub sep
323{
324 my $self = shift;
325 if (@_) {
326 my $sep = shift;
327 defined $sep or $sep = "";
328 $] >= 5.008002 and utf8::decode ($sep);
329 my @b = unpack "U0C*", $sep;
330 if (@b > 1) {
331 $self->sep_char ("\0");
332 }
333 else {
334 $self->sep_char ($sep);
335 $sep = "";
336 }
337 $self->{sep} = $sep;
338
339 my $ec = _check_sanity ($self);
340 $ec and croak ($self->SetDiag ($ec));
341
342 $self->_cache_set ($_cache_id{sep}, $sep);
343 }
344 my $sep = $self->{sep};
345 defined $sep && length ($sep) ? $sep : $self->{sep_char};
346 } # sep
347
348sub eol
349{
350 my $self = shift;
351 if (@_) {
352 my $eol = shift;
353 defined $eol or $eol = "";
354 $self->{eol} = $eol;
355 $self->_cache_set ($_cache_id{eol}, $eol);
356 }
357 $self->{eol};
358 } # eol
359
360sub always_quote
361{
362 my $self = shift;
363 @_ and $self->_set_attr_X ("always_quote", shift);
364 $self->{always_quote};
365 } # always_quote
366
367sub quote_space
368{
369 my $self = shift;
370 @_ and $self->_set_attr_X ("quote_space", shift);
371 $self->{quote_space};
372 } # quote_space
373
374sub quote_null
375{
376 my $self = shift;
377 @_ and $self->_set_attr_X ("quote_null", shift);
378 $self->{quote_null};
379 } # quote_null
380
381sub quote_binary
382{
383 my $self = shift;
384 @_ and $self->_set_attr_X ("quote_binary", shift);
385 $self->{quote_binary};
386 } # quote_binary
387
388sub binary
389{
390 my $self = shift;
391 @_ and $self->_set_attr_X ("binary", shift);
392 $self->{binary};
393 } # binary
394
395sub decode_utf8
396{
397 my $self = shift;
398 @_ and $self->_set_attr_X ("decode_utf8", shift);
399 $self->{decode_utf8};
400 } # decode_utf8
401
402sub keep_meta_info
403{
404 my $self = shift;
405 @_ and $self->_set_attr_X ("keep_meta_info", shift);
406 $self->{keep_meta_info};
407 } # keep_meta_info
408
409sub allow_loose_quotes
410{
411 my $self = shift;
412 @_ and $self->_set_attr_X ("allow_loose_quotes", shift);
413 $self->{allow_loose_quotes};
414 } # allow_loose_quotes
415
416sub allow_loose_escapes
417{
418 my $self = shift;
419 @_ and $self->_set_attr_X ("allow_loose_escapes", shift);
420 $self->{allow_loose_escapes};
421 } # allow_loose_escapes
422
423sub allow_whitespace
424{
425 my $self = shift;
426 if (@_) {
427 my $aw = shift;
428 _unhealthy_whitespace ($self, $aw) and
429 croak ($self->SetDiag (1002));
430 $self->_set_attr_X ("allow_whitespace", $aw);
431 }
432 $self->{allow_whitespace};
433 } # allow_whitespace
434
435sub allow_unquoted_escape
436{
437 my $self = shift;
438 @_ and $self->_set_attr_X ("allow_unquoted_escape", shift);
439 $self->{allow_unquoted_escape};
440 } # allow_unquoted_escape
441
442sub blank_is_undef
443{
444 my $self = shift;
445 @_ and $self->_set_attr_X ("blank_is_undef", shift);
446 $self->{blank_is_undef};
447 } # blank_is_undef
448
449sub empty_is_undef
450{
451 my $self = shift;
452 @_ and $self->_set_attr_X ("empty_is_undef", shift);
453 $self->{empty_is_undef};
454 } # empty_is_undef
455
456sub verbatim
457{
458 my $self = shift;
459 @_ and $self->_set_attr_X ("verbatim", shift);
460 $self->{verbatim};
461 } # verbatim
462
463sub auto_diag
464{
465 my $self = shift;
466 if (@_) {
467 my $v = shift;
468 !defined $v || $v eq "" and $v = 0;
469 $v =~ m/^[0-9]/ or $v = lc $v eq "false" ? 0 : 1; # true/truth = 1
470 $self->_set_attr_X ("auto_diag", $v);
471 }
472 $self->{auto_diag};
473 } # auto_diag
474
475sub diag_verbose
476{
477 my $self = shift;
478 if (@_) {
479 my $v = shift;
480 !defined $v || $v eq "" and $v = 0;
481 $v =~ m/^[0-9]/ or $v = lc $v eq "false" ? 0 : 1; # true/truth = 1
482 $self->_set_attr_X ("diag_verbose", $v);
483 }
484 $self->{diag_verbose};
485 } # diag_verbose
486
487# status
488#
489# object method returning the success or failure of the most recent
490# combine () or parse (). there are no side-effects.
491
492sub status
493{
494 my $self = shift;
495 return $self->{_STATUS};
496 } # status
497
498sub eof
499{
500 my $self = shift;
501 return $self->{_EOF};
502 } # status
503
504sub types
505{
506 my $self = shift;
507 if (@_) {
508 if (my $types = shift) {
509 $self->{_types} = join "", map { chr $_ } @{$types};
510 $self->{types} = $types;
511 }
512 else {
513 delete $self->{types};
514 delete $self->{_types};
515 undef;
516 }
517 }
518 else {
519 $self->{types};
520 }
521 } # types
522
523sub callbacks
524{
525 my $self = shift;
526 if (@_) {
527 my $cb;
528 my $hf = 0x00;
529 if (defined $_[0]) {
530 grep { !defined $_ } @_ and croak ($self->SetDiag (1004));
531 $cb = @_ == 1 && ref $_[0] eq "HASH" ? shift
532 : @_ % 2 == 0 ? { @_ }
533 : croak ($self->SetDiag (1004));
534 foreach my $cbk (keys %$cb) {
535 (!ref $cbk && $cbk =~ m/^[\w.]+$/) && ref $cb->{$cbk} eq "CODE" or
536 croak ($self->SetDiag (1004));
537 }
538 exists $cb->{error} and $hf |= 0x01;
539 exists $cb->{after_parse} and $hf |= 0x02;
540 exists $cb->{before_print} and $hf |= 0x04;
541 }
542 elsif (@_ > 1) {
543 # (undef, whatever)
544 croak ($self->SetDiag (1004));
545 }
546 $self->_set_attr_X ("_has_hooks", $hf);
547 $self->{callbacks} = $cb;
548 }
549 $self->{callbacks};
550 } # callbacks
551
552# erro_diag
553#
554# If (and only if) an error occurred, this function returns a code that
555# indicates the reason of failure
556
557sub error_diag
558{
559 my $self = shift;
560 my @diag = (0 + $last_new_err, $last_new_err, 0, 0);
561
562 if ($self && ref $self && # Not a class method or direct call
563 $self->isa (__PACKAGE__) && exists $self->{_ERROR_DIAG}) {
564 $diag[0] = 0 + $self->{_ERROR_DIAG};
565 $diag[1] = $self->{_ERROR_DIAG};
566 $diag[2] = 1 + $self->{_ERROR_POS} if exists $self->{_ERROR_POS};
567 $diag[3] = $self->{_RECNO};
568
569 $diag[0] && $self && $self->{callbacks} && $self->{callbacks}{error} and
570 return $self->{callbacks}{error}->(@diag);
571 }
572
573 my $context = wantarray;
574 unless (defined $context) { # Void context, auto-diag
575 if ($diag[0] && $diag[0] != 2012) {
576 my $msg = "# CSV_XS ERROR: $diag[0] - $diag[1] \@ rec $diag[3] pos $diag[2]\n";
577 if ($self && ref $self) { # auto_diag
578 if ($self->{diag_verbose} and $self->{_ERROR_INPUT}) {
579 $msg .= "$self->{_ERROR_INPUT}'\n";
580 $msg .= " " x ($diag[2] - 1);
581 $msg .= "^\n";
582 }
583
584 my $lvl = $self->{auto_diag};
585 if ($lvl < 2) {
586 my @c = caller (2);
587 if (@c >= 11 && $c[10] && ref $c[10] eq "HASH") {
588 my $hints = $c[10];
589 (exists $hints->{autodie} && $hints->{autodie} or
590 exists $hints->{"guard Fatal"} &&
591 !exists $hints->{"no Fatal"}) and
592 $lvl++;
593 # Future releases of autodie will probably set $^H{autodie}
594 # to "autodie @args", like "autodie :all" or "autodie open"
595 # so we can/should check for "open" or "new"
596 }
597 }
598 $lvl > 1 ? die $msg : warn $msg;
599 }
600 else { # called without args in void context
601 warn $msg;
602 }
603 }
604 return;
605 }
606 return $context ? @diag : $diag[1];
607 } # error_diag
608
609sub record_number
610{
611 my $self = shift;
612 return $self->{_RECNO};
613 } # record_number
614
615# string
616#
617# object method returning the result of the most recent combine () or the
618# input to the most recent parse (), whichever is more recent. there are
619# no side-effects.
620
621sub string
622{
623 my $self = shift;
624 return ref $self->{_STRING} ? ${$self->{_STRING}} : undef;
625 } # string
626
627# fields
628#
629# object method returning the result of the most recent parse () or the
630# input to the most recent combine (), whichever is more recent. there
631# are no side-effects.
632
633sub fields
634{
635 my $self = shift;
636 return ref $self->{_FIELDS} ? @{$self->{_FIELDS}} : undef;
637 } # fields
638
639# meta_info
640#
641# object method returning the result of the most recent parse () or the
642# input to the most recent combine (), whichever is more recent. there
643# are no side-effects. meta_info () returns (if available) some of the
644# field's properties
645
646sub meta_info
647{
648 my $self = shift;
649 return ref $self->{_FFLAGS} ? @{$self->{_FFLAGS}} : undef;
650 } # meta_info
651
652sub is_quoted
653{
654 my ($self, $idx, $val) = @_;
655 ref $self->{_FFLAGS} &&
656 $idx >= 0 && $idx < @{$self->{_FFLAGS}} or return;
657 $self->{_FFLAGS}[$idx] & 0x0001 ? 1 : 0;
658 } # is_quoted
659
660sub is_binary
661{
662 my ($self, $idx, $val) = @_;
663 ref $self->{_FFLAGS} &&
664 $idx >= 0 && $idx < @{$self->{_FFLAGS}} or return;
665 $self->{_FFLAGS}[$idx] & 0x0002 ? 1 : 0;
666 } # is_binary
667
668sub is_missing
669{
670 my ($self, $idx, $val) = @_;
671 $idx < 0 || !ref $self->{_FFLAGS} and return;
672 $idx >= @{$self->{_FFLAGS}} and return 1;
673 $self->{_FFLAGS}[$idx] & 0x0010 ? 1 : 0;
674 } # is_missing
675
676# combine
677#
678# Object method returning success or failure. The given arguments are
679# combined into a single comma-separated value. Failure can be the
680# result of no arguments or an argument containing an invalid character.
681# side-effects include:
682# setting status ()
683# setting fields ()
684# setting string ()
685# setting error_input ()
686
687sub combine
688{
689 my $self = shift;
690 my $str = "";
691 $self->{_FIELDS} = \@_;
692 $self->{_FFLAGS} = undef;
693 $self->{_STATUS} = (@_ > 0) && $self->Combine (\$str, \@_, 0);
694 $self->{_STRING} = \$str;
695 $self->{_STATUS};
696 } # combine
697
698# parse
699#
700# Object method returning success or failure. The given argument is
701# expected to be a valid comma-separated value. Failure can be the
702# result of no arguments or an argument containing an invalid sequence
703# of characters. Side-effects include:
704# setting status ()
705# setting fields ()
706# setting meta_info ()
707# setting string ()
708# setting error_input ()
709
710sub parse
711{
712 my ($self, $str) = @_;
713
714 my $fields = [];
715 my $fflags = [];
716 $self->{_STRING} = \$str;
717 if (defined $str && $self->Parse ($str, $fields, $fflags)) {
718 $self->{_FIELDS} = $fields;
719 $self->{_FFLAGS} = $fflags;
720 $self->{_STATUS} = 1;
721 }
722 else {
723 $self->{_FIELDS} = undef;
724 $self->{_FFLAGS} = undef;
725 $self->{_STATUS} = 0;
726 }
727 $self->{_STATUS};
728 } # parse
729
730sub column_names
731{
732 my ($self, @keys) = @_;
733 @keys or
734 return defined $self->{_COLUMN_NAMES} ? @{$self->{_COLUMN_NAMES}} : ();
735
736 @keys == 1 && ! defined $keys[0] and
737 return $self->{_COLUMN_NAMES} = undef;
738
739 if (@keys == 1 && ref $keys[0] eq "ARRAY") {
740 @keys = @{$keys[0]};
741 }
742 elsif (join "", map { defined $_ ? ref $_ : "" } @keys) {
743 croak ($self->SetDiag (3001));
744 }
745
746 $self->{_BOUND_COLUMNS} && @keys != @{$self->{_BOUND_COLUMNS}} and
747 croak ($self->SetDiag (3003));
748
749 $self->{_COLUMN_NAMES} = [ map { defined $_ ? $_ : "\cAUNDEF\cA" } @keys ];
750 @{$self->{_COLUMN_NAMES}};
751 } # column_names
752
753sub bind_columns
754{
755 my ($self, @refs) = @_;
756 @refs or
757 return defined $self->{_BOUND_COLUMNS} ? @{$self->{_BOUND_COLUMNS}} : undef;
758
759 if (@refs == 1 && ! defined $refs[0]) {
760 $self->{_COLUMN_NAMES} = undef;
761 return $self->{_BOUND_COLUMNS} = undef;
762 }
763
764 $self->{_COLUMN_NAMES} && @refs != @{$self->{_COLUMN_NAMES}} and
765 croak ($self->SetDiag (3003));
766
767 join "", map { ref $_ eq "SCALAR" ? "" : "*" } @refs and
768 croak ($self->SetDiag (3004));
769
770 $self->_set_attr_N ("_is_bound", scalar @refs);
771 $self->{_BOUND_COLUMNS} = [ @refs ];
772 @refs;
773 } # bind_columns
774
775sub getline_hr
776{
777 my ($self, @args, %hr) = @_;
778 $self->{_COLUMN_NAMES} or croak ($self->SetDiag (3002));
779 my $fr = $self->getline (@args) or return;
780 if (ref $self->{_FFLAGS}) {
781 $self->{_FFLAGS}[$_] = 0x0010 for ($#{$fr} + 1) .. $#{$self->{_COLUMN_NAMES}};
782 }
783 @hr{@{$self->{_COLUMN_NAMES}}} = @$fr;
784 \%hr;
785 } # getline_hr
786
787sub getline_hr_all
788{
789 my ($self, @args, %hr) = @_;
790 $self->{_COLUMN_NAMES} or croak ($self->SetDiag (3002));
791 my @cn = @{$self->{_COLUMN_NAMES}};
792 [ map { my %h; @h{@cn} = @$_; \%h } @{$self->getline_all (@args)} ];
793 } # getline_hr_all
794
795sub print_hr
796{
797 my ($self, $io, $hr) = @_;
798 $self->{_COLUMN_NAMES} or croak ($self->SetDiag (3009));
799 ref $hr eq "HASH" or croak ($self->SetDiag (3010));
800 $self->print ($io, [ map { $hr->{$_} } $self->column_names ]);
801 } # print_hr
802
803sub fragment
804{
805 my ($self, $io, $spec) = @_;
806
807 my $qd = qr{\s* [0-9]+ \s* }x; # digit
808 my $qs = qr{\s* (?: [0-9]+ | \* ) \s*}x; # digit or star
809 my $qr = qr{$qd (?: - $qs )?}x; # range
810 my $qc = qr{$qr (?: ; $qr )*}x; # list
811 defined $spec && $spec =~ m{^ \s*
812 \x23 ? \s* # optional leading #
813 ( row | col | cell ) \s* =
814 ( $qc # for row and col
815 | $qd , $qd (?: - $qs , $qs)? # for cell (ranges)
816 (?: ; $qd , $qd (?: - $qs , $qs)? )* # and cell (range) lists
817 ) \s* $}xi or croak ($self->SetDiag (2013));
818 my ($type, $range) = (lc $1, $2);
819
820 my @h = $self->column_names ();
821
822 my @c;
823 if ($type eq "cell") {
824 my @spec;
825 my $min_row;
826 my $max_row = 0;
827 for (split m/\s*;\s*/ => $range) {
828 my ($tlr, $tlc, $brr, $brc) = (m{
829 ^ \s* ([0-9]+ ) \s* , \s* ([0-9]+ ) \s*
830 (?: - \s* ([0-9]+ | \*) \s* , \s* ([0-9]+ | \*) \s* )?
831 $}x) or croak ($self->SetDiag (2013));
832 defined $brr or ($brr, $brc) = ($tlr, $tlc);
833 $tlr == 0 || $tlc == 0 ||
834 ($brr ne "*" && ($brr == 0 || $brr < $tlr)) ||
835 ($brc ne "*" && ($brc == 0 || $brc < $tlc))
836 and croak ($self->SetDiag (2013));
837 $tlc--;
838 $brc-- unless $brc eq "*";
839 defined $min_row or $min_row = $tlr;
840 $tlr < $min_row and $min_row = $tlr;
841 $brr eq "*" || $brr > $max_row and
842 $max_row = $brr;
843 push @spec, [ $tlr, $tlc, $brr, $brc ];
844 }
845 my $r = 0;
846 while (my $row = $self->getline ($io)) {
847 ++$r < $min_row and next;
848 my %row;
849 my $lc;
850 foreach my $s (@spec) {
851 my ($tlr, $tlc, $brr, $brc) = @$s;
852 $r < $tlr || ($brr ne "*" && $r > $brr) and next;
853 !defined $lc || $tlc < $lc and $lc = $tlc;
854 my $rr = $brc eq "*" ? $#$row : $brc;
855 $row{$_} = $row->[$_] for $tlc .. $rr;
856 }
857 push @c, [ @row{sort { $a <=> $b } keys %row } ];
858 if (@h) {
859 my %h; @h{@h} = @{$c[-1]};
860 $c[-1] = \%h;
861 }
862 $max_row ne "*" && $r == $max_row and last;
863 }
864 return \@c;
865 }
866
867 # row or col
868 my @r;
869 my $eod = 0;
870 for (split m/\s*;\s*/ => $range) {
871 my ($from, $to) = m/^\s* ([0-9]+) (?: \s* - \s* ([0-9]+ | \* ))? \s* $/x
872 or croak ($self->SetDiag (2013));
873 $to ||= $from;
874 $to eq "*" and ($to, $eod) = ($from, 1);
875 $from <= 0 || $to <= 0 || $to < $from and croak ($self->SetDiag (2013));
876 $r[$_] = 1 for $from .. $to;
877 }
878
879 my $r = 0;
880 $type eq "col" and shift @r;
881 $_ ||= 0 for @r;
882 while (my $row = $self->getline ($io)) {
883 $r++;
884 if ($type eq "row") {
885 if (($r > $#r && $eod) || $r[$r]) {
886 push @c, $row;
887 if (@h) {
888 my %h; @h{@h} = @{$c[-1]};
889 $c[-1] = \%h;
890 }
891 }
892 next;
893 }
894 push @c, [ map { ($_ > $#r && $eod) || $r[$_] ? $row->[$_] : () } 0..$#$row ];
895 if (@h) {
896 my %h; @h{@h} = @{$c[-1]};
897 $c[-1] = \%h;
898 }
899 }
900
901 return \@c;
902 } # fragment
903
9041300nsmy $csv_usage = q{usage: my $aoa = csv (in => $file);};
905
906sub _csv_attr
907{
908 my %attr = (@_ == 1 && ref $_[0] eq "HASH" ? %{$_[0]} : @_) or croak;
909
910 $attr{binary} = 1;
911
912 my $enc = delete $attr{encoding} || "";
913 $enc =~ m/^[-\w.]+$/ and $enc = ":encoding($enc)";
914
915 my $fh;
916 my $cls = 0; # If I open a file, I have to close it
917 my $in = delete $attr{in} || delete $attr{file} or croak $csv_usage;
918 my $out = delete $attr{out} || delete $attr{file};
919
920 ref $in eq "CODE" || ref $in eq "ARRAY" and $out ||= \*STDOUT;
921
922 if ($out) {
923 $in or croak $csv_usage; # No out without in
924 defined $attr{eol} or $attr{eol} = "\r\n";
925 if ((ref $out and ref $out ne "SCALAR") or "GLOB" eq ref \$out) {
926 $fh = $out;
927 }
928 else {
929 open $fh, ">$enc", $out or croak "$out: $!";
930 $cls = 1;
931 }
932 }
933
934 if ( ref $in eq "CODE" or ref $in eq "ARRAY") {
935 # All done
936 }
937 elsif (ref $in eq "SCALAR") {
938 # Strings with code points over 0xFF may not be mapped into in-memory file handles
939 # "<$enc" does not change that :(
940 open $fh, "<", $in or croak "Cannot open from SCALAR using PerlIO";
941 $cls = 1;
942 }
943 elsif (ref $in or "GLOB" eq ref \$in) {
944 if (!ref $in && $] < 5.008005) {
945 $fh = \*$in;
946 }
947 else {
948 $fh = $in;
949 }
950 }
951 else {
952 open $fh, "<$enc", $in or croak "$in: $!";
953 $cls = 1;
954 }
955 $fh or croak qq{No valid source passed. "in" is required};
956
957 my $hdrs = delete $attr{headers};
958 my $frag = delete $attr{fragment};
959 my $key = delete $attr{key};
960
961 my $cbai = delete $attr{callbacks}{after_in} ||
962 delete $attr{after_in} ||
963 delete $attr{callbacks}{after_parse} ||
964 delete $attr{after_parse};
965 my $cbbo = delete $attr{callbacks}{before_out} ||
966 delete $attr{before_out};
967 my $cboi = delete $attr{callbacks}{on_in} ||
968 delete $attr{on_in};
969
970 defined $attr{auto_diag} or $attr{auto_diag} = 1;
971 my $csv = Text::CSV_XS->new (\%attr) or croak $last_new_err;
972
973 return {
974 csv => $csv,
975 fh => $fh,
976 cls => $cls,
977 in => $in,
978 out => $out,
979 hdrs => $hdrs,
980 key => $key,
981 frag => $frag,
982 cbai => $cbai,
983 cbbo => $cbbo,
984 cboi => $cboi,
985 };
986 } # _csv_attr
987
988sub csv
989{
990 # This is a function, not a method
991 @_ && ref $_[0] ne __PACKAGE__ or croak $csv_usage;
992
993 my $c = _csv_attr (@_);
994
995 my ($csv, $in, $fh, $hdrs) = @{$c}{"csv", "in", "fh", "hdrs"};
996
997 if ($c->{out}) {
998 if (ref $in eq "CODE") {
999 my $hdr = 1;
1000 while (my $row = $in->($csv)) {
1001 if (ref $row eq "ARRAY") {
1002 $csv->print ($fh, $row);
1003 next;
1004 }
1005 if (ref $row eq "HASH") {
1006 if ($hdr) {
1007 $hdrs ||= [ keys %$row ];
1008 $csv->print ($fh, $hdrs);
1009 $hdr = 0;
1010 }
1011 $csv->print ($fh, [ @{$row}{@$hdrs} ]);
1012 }
1013 }
1014 }
1015 elsif (ref $in->[0] eq "ARRAY") { # aoa
1016 ref $hdrs and $csv->print ($fh, $hdrs);
1017 for (@{$in}) {
1018 $c->{cboi} and $c->{cboi}->($csv, $_);
1019 $c->{cbbo} and $c->{cbbo}->($csv, $_);
1020 $csv->print ($fh, $_);
1021 }
1022 }
1023 else { # aoh
1024 my @hdrs = ref $hdrs ? @{$hdrs} : keys %{$in->[0]};
1025 defined $hdrs or $hdrs = "auto";
1026 ref $hdrs || $hdrs eq "auto" and $csv->print ($fh, \@hdrs);
1027 for (@{$in}) {
1028 $c->{cboi} and $c->{cboi}->($csv, $_);
1029 $c->{cbbo} and $c->{cbbo}->($csv, $_);
1030 $csv->print ($fh, [ @{$_}{@hdrs} ]);
1031 }
1032 }
1033
1034 $c->{cls} and close $fh;
1035 return 1;
1036 }
1037
1038 ref $in eq "CODE" and croak "CODE only valid fro in when using out";
1039
1040 my $key = $c->{key} and $hdrs ||= "auto";
1041 if (defined $hdrs && !ref $hdrs) {
1042 $hdrs eq "skip" and $csv->getline ($fh);
1043 $hdrs eq "auto" and $hdrs = $csv->getline ($fh);
1044 }
1045
1046 my $frag = $c->{frag};
1047 my $ref = ref $hdrs
1048 ? # aoh
1049 do {
1050 $csv->column_names ($hdrs);
1051 $frag ? $csv->fragment ($fh, $frag) :
1052 $key ? { map { $_->{$key} => $_ } @{$csv->getline_hr_all ($fh)} }
1053 : $csv->getline_hr_all ($fh);
1054 }
1055 : # aoa
1056 $frag ? $csv->fragment ($fh, $frag)
1057 : $csv->getline_all ($fh);
1058 $ref or Text::CSV_XS->auto_diag;
1059 $c->{cls} and close $fh;
1060 if ($ref and $c->{cbai} || $c->{cboi}) {
1061 for (@{$ref}) {
1062 $c->{cbai} and $c->{cbai}->($csv, $_);
1063 $c->{cboi} and $c->{cboi}->($csv, $_);
1064 }
1065 }
1066 return $ref;
1067 } # csv
1068
1069111µs1;
1070
1071__END__
 
# spent 3µs within Text::CSV_XS::SetDiag which was called: # once (3µs+0s) by Text::CSV::BEGIN@1 at line 94
sub Text::CSV_XS::SetDiag; # xsub
# spent 26µs within Text::CSV_XS::bootstrap which was called: # once (26µs+0s) by DynaLoader::bootstrap at line 210 of DynaLoader.pm
sub Text::CSV_XS::bootstrap; # xsub
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.