Text-CSV-2.06/0000755000175100017510000000000014761120517013166 5ustar ishigakiishigakiText-CSV-2.06/Makefile.PL0000644000175100017510000000425714600712237015146 0ustar ishigakiishigakiuse 5.006001; use ExtUtils::MakeMaker; use lib qw( ./lib ); $ENV{PERL_TEXT_CSV} = 'Text::CSV_PP'; eval q| require Text::CSV |; if ($@) { print "Loading lib/Text/CSV.pm failed. No B module?\n"; print "perl says : $@"; print "Set the environmental variable 'PERL_DL_NONLAZY' with 0.\n"; print "No Makefile created.\n"; exit 0; } my $version = Text::CSV->VERSION; my $req_xs_ver = Text::CSV->require_xs_version; my $has_xs = 0; my $message; eval q| require Text::CSV_XS |; $has_xs = 1 unless ($@); my %xs_prereq; if ($has_xs) { my $xs_version = Text::CSV_XS->VERSION; if ($xs_version >= $req_xs_ver) { $message = "You have Text::CSV_XS (v.$xs_version), so Text::CSV can work very fast!!"; } else { %xs_prereq = ('Text::CSV_XS' => $req_xs_ver); $message = "Your Text::CSV_XS version is $xs_version. If you install v.$req_xs_ver,\n" . "Text::CSV will work faster."; } } else { $message = "If you install Text::CSV_XS v.$req_xs_ver, it makes Text::CSV faster."; } print < 'Text::CSV', 'MIN_PERL_VERSION' => '5.006001', 'VERSION_FROM' => 'lib/Text/CSV.pm', # finds $VERSION 'ABSTRACT_FROM' => 'lib/Text/CSV.pm', # retrieve abstract from module 'AUTHOR' => 'Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE', 'PREREQ_PM' => { "IO::Handle" => 0, "Test::More" => '0.92', "Test::Harness" => 0, %xs_prereq, }, ( $ExtUtils::MakeMaker::VERSION >= 6.3002 ? ('LICENSE' => 'perl', ) : () ), ( $ExtUtils::MakeMaker::VERSION >= 6.46 ? ( 'META_MERGE' => { recommends => { 'Text::CSV_XS' => Text::CSV->require_xs_version, }, resources => { repository => 'https://github.com/makamaka/Text-CSV', bugtracker => 'https://github.com/makamaka/Text-CSV/issues', license => 'http://dev.perl.org/licenses/', }, } ) : () ), ); Text-CSV-2.06/META.json0000664000175100017510000000263014761120517014612 0ustar ishigakiishigaki{ "abstract" : "comma-separated values manipulator (using XS or PurePerl)", "author" : [ "Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Text-CSV", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "recommends" : { "Text::CSV_XS" : "1.60" }, "requires" : { "IO::Handle" : "0", "Test::Harness" : "0", "Test::More" : "0.92", "perl" : "5.006001" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/makamaka/Text-CSV/issues" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/makamaka/Text-CSV" } }, "version" : "2.06", "x_serialization_backend" : "JSON::PP version 4.16" } Text-CSV-2.06/MANIFEST0000644000175100017510000000152114761120517014316 0ustar ishigakiishigakiChanges files/macosx.csv files/utf8.csv lib/Text/CSV.pm lib/Text/CSV_PP.pm Makefile.PL MANIFEST This list of files README.md t/00_pod.t t/01_is_pp.t t/10_base.t t/12_acc.t t/15_flags.t t/16_import.t t/20_file.t t/21_lexicalio.t t/22_scalario.t t/30_types.t t/40_misc.t t/41_null.t t/45_eol.t t/46_eol_si.t t/47_comment.t t/50_utf8.t t/51_utf8.t t/55_combi.t t/60_samples.t t/65_allow.t t/66_formula.t t/67_emptrow.t t/68_header.t t/70_rt.t t/71_pp.t t/71_strict.t t/75_hashref.t t/76_magic.t t/77_getall.t t/78_fragment.t t/79_callbacks.t t/80_diag.t t/81_subclass.t t/85_util.t t/90_csv.t t/91_csv_cb.t t/92_stream.t t/csv_method.t t/fields_containing_0.t t/rt99774.t t/util.pl META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Text-CSV-2.06/t/0000755000175100017510000000000014761120516013430 5ustar ishigakiishigakiText-CSV-2.06/t/10_base.t0000644000175100017510000001004514760113543015030 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; # use warnings core since 5.6 use Test::More tests => 64; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; } # empty subclass test # package Empty_Subclass; @Empty_Subclass::ISA = qw( Text::CSV ); package main; ok (new Text::CSV, "Indirect object notation"); # Important: Do not modify these tests unless you have a good # reason. This file ought to guarantee compatibility to Text::CSV. # my $empty = Empty_Subclass->new (); is (ref $empty, "Empty_Subclass", "Empty Subclass"); is ($empty->version (), Text::CSV->version (), "Version"); ok ($empty->parse (""), "Subclass parse ()"); ok ($empty->combine (""), "Subclass combine ()"); ok ($empty->new, "new () based on object"); my $csv; ok ($csv = Text::CSV->new, "new ()"); is ($csv->fields, undef, "fields () before parse ()"); is ($csv->string, undef, "string () undef before combine"); # Important: Do not modify these tests unless you have a good # reason. This file ought to guarantee compatibility to Text::CSV. # ok (1, "combine () & string () tests"); ok (!$csv->combine (), "Missing arguments"); ok (!$csv->combine ("abc", "def\n", "ghi"), "Bad character"); is ( $csv->error_input, "def\n", "Error_input ()"); ok ( $csv->combine (""), "Empty string - combine ()"); is ( $csv->string, '', "Empty string - string ()"); ok ( $csv->combine ("", " "), "Two fields, one space - combine ()"); is ( $csv->string, '," "', "Two fields, one space - string ()"); ok ( $csv->combine ("", 'I said, "Hi!"', ""), "Hi! - combine ()"); is ( $csv->string, ',"I said, ""Hi!""",', "Hi! - string ()"); ok ( $csv->combine ('"', "abc"), "abc - combine ()"); is ( $csv->string, '"""",abc', "abc - string ()"); ok ( $csv->combine (","), "comma - combine ()"); is ( $csv->string, '","', "comma - string ()"); ok ( $csv->combine ("abc", '"'), "abc + \" - combine ()"); is ( $csv->string, 'abc,""""', "abc + \" - string ()"); ok ( $csv->combine ("abc", "def", "ghi", "j,k"), "abc .. j,k - combine ()"); is ( $csv->string, 'abc,def,ghi,"j,k"', "abc .. j,k - string ()"); ok ( $csv->combine ("abc\tdef", "ghi"), "abc + TAB - combine ()"); is ( $csv->string, qq("abc\tdef",ghi), "abc + TAB - string ()"); ok (1, "parse () tests"); ok (!$csv->parse (), "Missing arguments"); ok ( $csv->parse ("\n"), "Single newline"); ok (!$csv->parse ('"abc'), "Missing closing \""); ok (!$csv->parse ('ab"c'), "\" outside of \"'s"); ok (!$csv->parse ('"ab"c"'), "Bad character sequence"); ok (!$csv->parse (qq("abc\nc")), "Bad character (NL)"); ok (!$csv->status (), "Wrong status ()"); ok ( $csv->parse ('","'), "comma - parse ()"); is ( scalar $csv->fields (), 1, "comma - fields () - count"); is (($csv->fields ())[0], ",", "comma - fields () - content"); ok ( $csv->parse (qq("","I said,\t""Hi!""","")), "Hi! - parse ()"); is ( scalar $csv->fields (), 3, "Hi! - fields () - count"); is (($csv->fields ())[0], "", "Hi! - fields () - field 1"); is (($csv->fields ())[1], qq(I said,\t"Hi!"), "Hi! - fields () - field 2"); is (($csv->fields ())[2], "", "Hi! - fields () - field 3"); ok ( $csv->status (), "status ()"); ok ( $csv->parse (""), "Empty line"); is ( scalar $csv->fields (), 1, "Empty - count"); is (($csv->fields ())[0], "", "One empty field"); # Are Integers and Reals quoted? # # Important: Do not modify these tests unless you have a good # reason. This file ought to guarantee compatibility to Text::CSV. # ok (1, "Integers and Reals"); ok ( $csv->combine ("", 2, 3.25, "a", "a b"), "Mixed - combine ()"); is ( $csv->string, ',2,3.25,a,"a b"', "Mixed - string ()"); # New from object ok ($csv->new (), "\$csv->new ()"); my $state; for ( [ 0, 0 ], [ 0, "foo" ], [ 0, {} ], [ 0, \0 ], [ 0, *STDOUT ], ) { eval { $state = $csv->print (@$_) }; ok (!$state, "print needs (IO, ARRAY_REF)"); ok ($@ =~ m/^Expected fields to be an array ref/, "Error msg"); } 1; Text-CSV-2.06/t/rt99774.t0000644000175100017510000000177514600712237014677 0ustar ishigakiishigaki $^W = 1; use strict; use Test::More tests => 8; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; require_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } my $csv = Text::CSV->new ( { binary => 1, sep_char => ';', allow_whitespace => 1, quote_char => '"' } ); # https://rt.cpan.org/Public/Bug/Display.html?id=99774 while ( my $line = ) { my $text = $line; chomp($text); $text =~ s/"//g; my $expect = [ split/;/, $text ]; $csv->parse($line); is_deeply( [$csv->fields], $expect, $line ); } # https://rt.cpan.org/Public/Bug/Display.html?id=92509 for my $allow_whitespace ( 0, 1 ) { $csv = Text::CSV->new ( { allow_whitespace => $allow_whitespace } ); $csv->parse(q{"value1","0","value3"}); is_deeply( [$csv->fields], ["value1","0","value3"], 'allow_whitespace:' . $allow_whitespace ); } __DATA__ "data_quality_id";"language_version_id";"name" "0";"2";"0%" "10";"2";"33%" "20";"2";"66%" "30";"2";"100%" Text-CSV-2.06/t/00_pod.t0000644000175100017510000000043614600712237014700 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More; print STDERR "# PERL_TEXT_CSV: ", (defined $ENV{TEST_PERL_TEXT_CSV} ? "$ENV{TEST_PERL_TEXT_CSV}" : "undef"), "\n"; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok (); Text-CSV-2.06/t/01_is_pp.t0000644000175100017510000000104514600712237015226 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; # use warnings core since 5.6 use Test::More tests => 4; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; } if (!$ENV{PERL_TEXT_CSV} or $ENV{PERL_TEXT_CSV} eq 'Text::CSV_PP' or !eval { require Text::CSV_XS; 1 }) { ok my $csv = Text::CSV->new; ok $csv->is_pp; is $csv->module => 'Text::CSV_PP'; } else { ok my $csv = Text::CSV->new; ok $csv->is_xs; is $csv->module => 'Text::CSV_XS'; } Text-CSV-2.06/t/85_util.t0000644000175100017510000002755314760113543015123 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More; my $ebcdic = ord ("A") == 0xC1; my $pu; BEGIN { $pu = $ENV{PERL_UNICODE}; $pu = defined $pu && ($pu eq "" || $pu =~ m/[oD]/ || ($pu =~ m/^[0-9]+$/ && $pu & 16)); if ($] < 5.008002) { plan skip_all => "This test unit requires perl-5.8.2 or higher"; } else { my $n = 1448; $pu and $n -= 120; plan tests => $n; } $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", "csv"; # Encode up to and including 2.01 have an error in a regex: # False [] range "\s-" in regex; marked by <-- HERE in m/\bkoi8[\s- <-- HERE _]*([ru])$/ # in Encode::Alias. This however does not influence this test, as then *all* encodings # are skipped as unsupported require Encode; require "./t/util.pl"; } $| = 1; ok (my $csv = Text::CSV->new, "new for header tests"); is ($csv->sep_char, ",", "Sep = ,"); my $hdr_lc = [qw( bar foo )]; foreach my $sep (",", ";") { my $data = "bAr,foo\n1,2\n3,4,5\n"; $data =~ s/,/$sep/g; $csv->column_names (undef); { open my $fh, "<", \$data; ok (my $slf = $csv->header ($fh), "header"); is ($slf, $csv, "Return self"); is ($csv->sep_char, $sep, "Sep = $sep"); is_deeply ([ $csv->column_names ], $hdr_lc, "headers"); is_deeply ($csv->getline ($fh), [ 1, 2 ], "Line 1"); is_deeply ($csv->getline ($fh), [ 3, 4, 5 ], "Line 2"); close $fh; } $csv->column_names (undef); { open my $fh, "<", \$data; ok (my @hdr = $csv->header ($fh), "header"); is_deeply (\@hdr, $hdr_lc, "Return headers"); close $fh; } $csv->column_names (undef); { open my $fh, "<", \$data; ok (my $slf = $csv->header ($fh), "header"); is ($slf, $csv, "Return self"); is ($csv->sep_char, $sep, "Sep = $sep"); is_deeply ([ $csv->column_names ], $hdr_lc, "headers"); is_deeply ($csv->getline_hr ($fh), { bar => 1, foo => 2 }, "Line 1"); is_deeply ($csv->getline_hr ($fh), { bar => 3, foo => 4 }, "Line 2"); close $fh; } { open my $fh, "<", \$data; is_deeply (csv (in => $fh, bom => 1), [{ bar => 1, foo => 2 }, { bar => 3, foo => 4 }], "use header () from csv () with $sep"); } { open my $fh, "<", \$data; is_deeply (csv (in => $fh, seps => [ ",", ";" ]), [{ bar => 1, foo => 2 }, { bar => 3, foo => 4 }], "use header () from csv () with $sep"); } { open my $fh, "<", \$data; is_deeply (csv (in => $fh, bom => 1, key => "bar"), { 1 => { bar => 1, foo => 2 }, 3 => { bar => 3, foo => 4 }}, "use header () from csv (key) with $sep"); } { open my $fh, "<", \$data; is_deeply (csv (in => $fh, munge => "uc", key => "BAR"), { 1 => { BAR => 1, FOO => 2 }, 3 => { BAR => 3, FOO => 4 }}, "use header () from csv (key, uc) with $sep"); } { open my $fh, "<", \$data; is_deeply (csv (in => $fh, set_column_names => 0), [[ "bar", "foo" ], [ 1, 2 ], [ 3, 4, 5 ]], "use header () from csv () with $sep to ARRAY not setting column names"); } { open my $fh, "<", \$data; is_deeply (csv (in => $fh, set_column_names => 0, munge => "none"), [[ "bAr", "foo" ], [ 1, 2 ], [ 3, 4, 5 ]], "use header () from csv () with $sep to ARRAY not setting column names not lc"); } } my $sep_utf = byte_utf8a_to_utf8n ("\xe2\x81\xa3"); # U+2063 INVISIBLE SEPARATOR my $sep_ok = [ "\t", "|", ",", ";", "##", $sep_utf ]; unless ($pu) { foreach my $sep (@$sep_ok) { my $data = "bAr,foo\n1,2\n3,4,5\n"; $data =~ s/,/$sep/g; $csv->column_names (undef); { open my $fh, "<", \$data; ok (my $slf = $csv->header ($fh, $sep_ok), "header with specific sep set"); is ($slf, $csv, "Return self"); is (Encode::encode ("utf-8", $csv->sep), $sep, "Sep = $sep"); is_deeply ([ $csv->column_names ], $hdr_lc, "headers"); is_deeply ($csv->getline ($fh), [ 1, 2 ], "Line 1"); is_deeply ($csv->getline ($fh), [ 3, 4, 5 ], "Line 2"); close $fh; } $csv->column_names (undef); { open my $fh, "<", \$data; ok (my @hdr = $csv->header ($fh, $sep_ok), "header with specific sep set"); is_deeply (\@hdr, $hdr_lc, "Return headers"); close $fh; } $csv->column_names (undef); { open my $fh, "<", \$data; ok (my $slf = $csv->header ($fh, { sep_set => $sep_ok }), "header with specific sep set as opt"); is ($slf, $csv, "Return self"); is (Encode::encode ("utf-8", $csv->sep), $sep, "Sep = $sep"); is_deeply ([ $csv->column_names ], $hdr_lc, "headers"); is_deeply ($csv->getline ($fh), [ 1, 2 ], "Line 1"); is_deeply ($csv->getline ($fh), [ 3, 4, 5 ], "Line 2"); close $fh; } $csv->column_names (undef); { open my $fh, "<", \$data; ok (my $slf = $csv->header ($fh, $sep_ok), "header with specific sep set"); is ($slf, $csv, "Return self"); is (Encode::encode ("utf-8", $csv->sep), $sep, "Sep = $sep"); is_deeply ([ $csv->column_names ], $hdr_lc, "headers"); is_deeply ($csv->getline_hr ($fh), { bar => 1, foo => 2 }, "Line 1"); is_deeply ($csv->getline_hr ($fh), { bar => 3, foo => 4 }, "Line 2"); close $fh; } } } for ( [ 1010, 0, qq{} ], # Empty header [ 1011, 0, qq{a,b;c,d} ], # Multiple allowed separators [ 1012, 0, qq{a,,b} ], # Empty header field [ 1013, 0, qq{a,a,b} ], # Non-unique headers [ 2027, 1, qq{a,"b\nc",c} ], # Embedded newline binary on [ 2021, 0, qq{a,"b\nc",c} ], # Embedded newline binary off ) { my ($err, $bin, $data) = @$_; $csv->binary ($bin); open my $fh, "<", \$data; my $self = eval { $csv->header ($fh); }; is ($self, undef, "FAIL for '$data'"); ok ($@, "Error"); is (0 + $csv->error_diag, $err, "Error code $err"); close $fh; } { open my $fh, "<", \"bar,bAr,bAR,BAR\n1,2,3,4"; $csv->column_names (undef); ok ($csv->header ($fh, { munge_column_names => "none", detect_bom => 0 }), "non-unique unfolded headers"); is_deeply ([ $csv->column_names ], [qw( bar bAr bAR BAR )], "Headers"); close $fh; } { open my $fh, "<", \"bar,bAr,bAR,BAR\n1,2,3,4"; $csv->column_names (undef); ok (my @hdr = $csv->header ($fh, { munge_column_names => "none" }), "non-unique unfolded headers"); is_deeply (\@hdr, [qw( bar bAr bAR BAR )], "Headers from method"); is_deeply ([ $csv->column_names ], [qw( bar bAr bAR BAR )], "Headers from column_names"); close $fh; } foreach my $sep (",", ";") { my $data = "bAr,foo\n1,2\n3,4,5\n"; $data =~ s/,/$sep/g; $csv->column_names (undef); { open my $fh, "<", \$data; ok (my $slf = $csv->header ($fh, { set_column_names => 0 }), "Header without column setting"); is ($slf, $csv, "Return self"); is ($csv->sep_char, $sep, "Sep = $sep"); is_deeply ([ $csv->column_names ], [], "headers"); is_deeply ($csv->getline ($fh), [ 1, 2 ], "Line 1"); is_deeply ($csv->getline ($fh), [ 3, 4, 5 ], "Line 2"); close $fh; } $csv->column_names (undef); { open my $fh, "<", \$data; ok (my @hdr = $csv->header ($fh, { set_column_names => 0 }), "Header without column setting"); is_deeply (\@hdr, $hdr_lc, "Headers from method"); is_deeply ([ $csv->column_names ], [], "Headers from column_names"); close $fh; } } foreach my $ss ("", "bad", sub { 1; }, \*STDOUT, +{}) { my $dta = "a,b\n1,2\n"; open my $fh, "<", \$dta; my @hdr = eval { $csv->header ($fh, { sep_set => $ss }) }; is (scalar @hdr, 0, "No header on invalid sep_set"); is (0 + $csv->error_diag, 1500, "Error code"); } foreach my $dta ("", "\xfe\xff", "\xf7\x64\x4c", "\xdd\x73\x66\x73", "\x0e\xfe\xff", "\xfb\xee\x28", "\x84\x31\x95\x33") { open my $fh, "<", \$dta; my @hdr = eval { $csv->header ($fh) }; is (scalar @hdr, 0, "No header on empty stream"); is (0 + $csv->error_diag, 1010, "Error code"); } my $n; for ([ undef, "_bar" ], [ "lc", "_bar" ], [ "uc", "_BAR" ], [ "none", "_bAr" ], [ sub { "column_".$n++ }, "column_0" ], [ "db", "bar" ]) { my ($munge, $hdr) = @$_; my $data = "_bAr,foo\n1,2\n3,4,5\n"; my $how = defined $munge ? ref $munge ? "CB" : $munge : "undef"; $n = 0; $csv->column_names (undef); open my $fh, "<", \$data; ok (my $slf = $csv->header ($fh, { munge_column_names => $munge }), "munge header with $how"); is (($csv->column_names)[0], $hdr, "folded header to $hdr"); close $fh; $n = 0; $csv->column_names (undef); open $fh, "<", \$data; ok (my @hdr = $csv->header ($fh, { munge_column_names => $munge }), "munge header with $how"); is ($hdr[0], $hdr, "folded header to $hdr"); close $fh; } my $fnm = "_85hdr.csv"; END { unlink $fnm; } my $a_ring = chr (utf8::unicode_to_native (0xe5)); foreach my $irs ("\n", chr (utf8::unicode_to_native (0xaa))) { local $/ = $irs; foreach my $eol ("\n", "\r\n", "\r") { my $str = join $eol => qq{zoo,b${a_ring}r}, qq{1,"1 \x{20ac} each"}, ""; for ( [ "none" => "" ], [ "utf-8" => "\xef\xbb\xbf" ], [ "utf-16be" => "\xfe\xff" ], [ "utf-16le" => "\xff\xfe" ], [ "utf-32be" => "\x00\x00\xfe\xff" ], [ "utf-32le" => "\xff\xfe\x00\x00" ], # Below 5 not (yet) supported by Encode [ "utf-1" => "\xf7\x64\x4c" ], [ "utf-ebcdic" => "\xdd\x73\x66\x73" ], [ "scsu" => "\x0e\xfe\xff" ], [ "bocu-1" => "\xfb\xee\x28" ], [ "gb-18030" => "\x84\x31\x95" ], # [ "UTF-8" => "\x{feff}" ], ) { my ($enc, $bom) = @$_; my ($enx, $box, $has_enc) = ($enc, $bom, 0); $enc eq "UTF-8" || $enc eq "none" or $box = eval { Encode::encode ($enc, chr (0xfeff)) }; $enc eq "none" and $enx = "utf-8"; # On os390, Encode only supports the following EBCDIC # cp37, cp500, cp875, cp1026, cp1047, and posix-bc # utf-ebcdic is not in the list eval { no warnings "utf8"; open my $fh, ">", $fnm; binmode $fh; if (defined $box) { print $fh byte_utf8a_to_utf8n ($box); print $fh Encode::encode ($enx, $str); $has_enc = 1; } else { print $fh Encode::encode ("utf-8", $str); } close $fh; }; #$ebcdic and $has_enc = 0; # TODO $csv = Text::CSV->new ({ binary => 1, auto_diag => 9 }); SKIP: { $has_enc or skip "Encoding $enc not supported", $enc =~ m/^utf/ ? 10 : 9; $csv->column_names (undef); open my $fh, "<", $fnm; binmode $fh; ok (1, "$fnm opened for enc $enc"); ok ($csv->header ($fh), "headers with BOM for $enc"); $enc =~ m/^utf/ and is ($csv->{ENCODING}, uc $enc, "Encoding inquirable"); is (($csv->column_names)[1], "b${a_ring}r", "column name was decoded"); ok (my $row = $csv->getline_hr ($fh), "getline_hr"); is ($row->{"b${a_ring}r"}, "1 \x{20ac} each", "Returned in Unicode"); close $fh; my $aoh; ok ($aoh = csv (in => $fnm, bom => 1), "csv (bom => 1)"); is_deeply ($aoh, [{ zoo => 1, "b${a_ring}r" => "1 \x{20ac} each" }], "Returned data bom = 1"); ok ($aoh = csv (in => $fnm, encoding => "auto"), "csv (encoding => auto)"); is_deeply ($aoh, [{ zoo => 1, "b${a_ring}r" => "1 \x{20ac} each" }], "Returned data auto"); } SKIP: { $has_enc or skip "Encoding $enc not supported", 7; $csv->column_names (undef); open my $fh, "<", $fnm; $enc eq "none" or binmode $fh, ":encoding($enc)"; ok (1, "$fnm opened for enc $enc"); ok ($csv->header ($fh), "headers with BOM for $enc"); is (($csv->column_names)[1], "b${a_ring}r", "column name was decoded"); ok (my $row = $csv->getline_hr ($fh), "getline_hr"); is ($row->{"b${a_ring}r"}, "1 \x{20ac} each", "Returned in Unicode"); close $fh; ok (my $aoh = csv (in => $fnm, bom => 1), "csv (bom => 1)"); is_deeply ($aoh, [{ zoo => 1, "b${a_ring}r" => "1 \x{20ac} each" }], "Returned data"); } unlink $fnm; } } } { # Header after first line with sep= open my $fh, ">", $fnm or die "$fnm: $!"; print $fh "sep=;\n"; print $fh "a;b 1;c\n"; print $fh "1;2;3\n"; close $fh; ok (my $aoh = csv (in => $fnm, munge => "db"), "Read header with sep=;"); is_deeply ($aoh, [{ a => 1, "b_1" => 2, c => 3 }], "Munged to db with sep"); } Text-CSV-2.06/t/81_subclass.t0000644000175100017510000000130714760113543015746 0ustar ishigakiishigaki#!/usr/bin/perl package Text::CSV::Subclass; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; } BEGIN { require Text::CSV; } # needed for perl5.005 use strict; $^W = 1; use base "Text::CSV"; use Test::More tests => 6; ok (1, "Subclassed"); my $csvs = Text::CSV::Subclass->new (); is ($csvs->error_diag (), "", "Last failure for new () - OK"); my $sc_csv; eval { $sc_csv = Text::CSV::Subclass->new ({ ecs_char => ":" }); }; is ($sc_csv, undef, "Unsupported option"); is ($@, "", "error"); is (Text::CSV::Subclass->error_diag (), "INI - Unknown attribute 'ecs_char'", "Last failure for new () - FAIL"); is (Text::CSV::Subclass->new ({ fail_me => "now" }), undef, "bad new ()"); 1; Text-CSV-2.06/t/75_hashref.t0000644000175100017510000001541214760113543015554 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; #use Test::More "no_plan"; use Test::More tests => 102; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", (); plan skip_all => "Cannot load Text::CSV" if $@; } my $tfn = "_75hashref.csv"; END { -f $tfn and unlink $tfn; } open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh <new (), "new"); is ($csv->column_names, undef, "No headers yet"); foreach my $args ([\1], ["foo", \1], [{ 1 => 2 }]) { eval { $csv->column_names (@$args) }; like ($@, qr/^EHR/, "croak"); is ($csv->error_diag () + 0, 3001, "Bad args to column_names"); } ok ($csv->column_names ("name"), "One single name"); is ($csv->column_names (undef), undef, "reset column_names"); eval { $csv->column_names (\undef) }; is ($csv->error_diag () + 0, 3001, "No hash please"); eval { $csv->column_names ({ 1 => 2 }) }; is ($csv->error_diag () + 0, 3001, "No hash please"); my $hr; eval { $hr = $csv->getline_hr ($fh) }; is ($hr, undef, "getline_hr before column_names"); like ($@, qr/^EHR/, "croak"); is ($csv->error_diag () + 0, 3002, "error code"); ok ($csv->column_names ("name", "code"), "column_names (list)"); is_deeply ([ $csv->column_names ], [ "name", "code" ], "well set"); open $fh, "<", $tfn or die "$tfn: $!\n"; my $row; ok ($row = $csv->getline ($fh), "getline headers"); is ($row->[0], "code", "Header line"); ok ($csv->column_names ($row), "column_names from array_ref"); is_deeply ([ $csv->column_names ], [ @$row ], "Keys set"); while (my $hr = $csv->getline_hr ($fh)) { ok (exists $hr->{code}, "Line has a code field"); like ($hr->{code}, qr/^[0-9]+$/, "Code is numeric"); ok (exists $hr->{name}, "Line has a name field"); like ($hr->{name}, qr/^[A-Z][a-z]+$/, "Name"); } close $fh; my ($code, $name, $price, $desc) = (1..4); is ($csv->bind_columns (), undef, "No bound columns yet"); eval { $csv->bind_columns (\$code) }; is ($csv->error_diag () + 0, 3003, "Arg cound mismatch"); eval { $csv->bind_columns ({}, {}, {}, {}) }; is ($csv->error_diag () + 0, 3004, "bad arg types"); is ($csv->column_names (undef), undef, "reset column_names"); ok ($csv->bind_columns (\($code, $name, $price)), "Bind columns"); eval { $csv->column_names ("foo") }; is ($csv->error_diag () + 0, 3003, "Arg cound mismatch"); $csv->bind_columns (undef); eval { $csv->bind_columns ([undef]) }; is ($csv->error_diag () + 0, 3004, "legal header defenition"); my @bcr = \($code, $name, $price, $desc); open $fh, "<", $tfn or die "$tfn: $!\n"; ok ($row = $csv->getline ($fh), "getline headers"); ok ($csv->bind_columns (@bcr), "Bind columns"); ok ($csv->column_names ($row), "column_names from array_ref"); is_deeply ([ $csv->column_names ], [ @$row ], "Keys set"); $row = $csv->getline ($fh); is_deeply ([ $csv->bind_columns ], [ @bcr ], "check refs"); is_deeply ($row, [], "return from getline with bind_columns"); is ($csv->column_names (undef), undef, "reset column headers"); is ($csv->bind_columns (undef), undef, "reset bound columns"); my $foo; ok ($csv->bind_columns (@bcr, \$foo), "bind too many columns"); ($code, $name, $price, $desc, $foo) = (101 .. 105); ok ($csv->getline ($fh), "fetch less than expected"); is_deeply ([ $code, $name, $price, $desc, $foo ], [ 2, "Drinks", "82.78", "Drinks", 105 ], "unfetched not reset"); my @foo = (0) x 0x012345; ok ($csv->bind_columns (\(@foo)), "bind a lot of columns"); ok ($csv->bind_columns (\1, \2, \3, \""), "bind too constant columns"); is ($csv->getline ($fh), undef, "fetch to read-only ref"); is ($csv->error_diag () + 0, 3008, "Read-only"); ok ($csv->bind_columns (\$code), "bind not enough columns"); eval { $row = $csv->getline ($fh) }; is ($csv->error_diag () + 0, 3006, "cannot read all fields"); close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; is ($csv->column_names (undef), undef, "reset column headers"); is ($csv->bind_columns (undef), undef, "reset bound columns"); is_deeply ([ $csv->column_names (undef, "", "name", "name") ], [ "\cAUNDEF\cA", "", "name", "name" ], "undefined column header"); ok ($hr = $csv->getline_hr ($fh), "getline_hr ()"); is (ref $hr, "HASH", "returned a hashref"); is_deeply ($hr, { "\cAUNDEF\cA" => "code", "" => "name", "name" => "description" }, "Discarded 3rd field"); close $fh; open $fh, ">", $tfn or die "$tfn: $!\n"; $hr = { c_foo => 1, foo => "poison", zebra => "Of course" }; is ($csv->column_names (undef), undef, "reset column headers"); ok ($csv->column_names (sort keys %$hr), "set column names"); ok ($csv->eol ("\n"), "set eol for output"); ok ($csv->print ($fh, [ $csv->column_names ]), "print header"); ok ($csv->print_hr ($fh, $hr), "print_hr"); ok ($csv->print ($fh, []), "empty print"); close $fh; ok ($csv->keep_meta_info (1), "keep meta info"); open $fh, "<", $tfn or die "$tfn: $!\n"; ok ($csv->column_names ($csv->getline ($fh)), "get column names"); is_deeply ($csv->getline_hr ($fh), $hr, "compare to written hr"); is_deeply ($csv->getline_hr ($fh), { c_foo => "", foo => undef, zebra => undef }, "compare to written hr"); is ($csv->is_missing (1), 1, "No col 1"); close $fh; open $fh, ">", $tfn or die "$tfn: $!\n"; print $fh <<"EOC"; a,b 2 EOC close $fh; ok ($csv = Text::CSV->new (), "new"); open $fh, "<", $tfn or die "$tfn: $!\n"; ok ($csv->column_names ("code", "foo"), "set column names"); ok ($hr = $csv->getline_hr ($fh), "get header line"); is ($csv->is_missing (0), undef, "not is_missing () - no meta"); is ($csv->is_missing (1), undef, "not is_missing () - no meta"); ok ($hr = $csv->getline_hr ($fh), "get empty line"); is ($csv->is_missing (0), undef, "not is_missing () - no meta"); is ($csv->is_missing (1), undef, "not is_missing () - no meta"); ok ($hr = $csv->getline_hr ($fh), "get partial data line"); is (int $hr->{code}, 2, "code == 2"); is ($csv->is_missing (0), undef, "not is_missing () - no meta"); is ($csv->is_missing (1), undef, "not is_missing () - no meta"); close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; $csv->keep_meta_info (1); ok ($csv->column_names ("code", "foo"), "set column names"); ok ($hr = $csv->getline_hr ($fh), "get header line"); is ($csv->is_missing (0), 0, "not is_missing () - with meta"); is ($csv->is_missing (1), 0, "not is_missing () - with meta"); ok ($hr = $csv->getline_hr ($fh), "get empty line"); is ($csv->is_missing (0), 1, "not is_missing () - with meta"); is ($csv->is_missing (1), 1, "not is_missing () - with meta"); ok ($hr = $csv->getline_hr ($fh), "get partial data line"); is (int $hr->{code}, 2, "code == 2"); is ($csv->is_missing (0), 0, "not is_missing () - with meta"); is ($csv->is_missing (1), 1, "not is_missing () - with meta"); close $fh; Text-CSV-2.06/t/70_rt.t0000644000175100017510000007167114760113543014565 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; #use Test::More "no_plan"; use Test::More tests => 20469; use Config; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", (); plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } my $tfn = "_70test.csv"; END { unlink $tfn, "_$tfn"; } my $ebcdic = $Config{ebcdic}; my ($rt, %input, %desc); while () { if (s/^«(x?[0-9]+)»\s*-?\s*//) { chomp; $rt = $1; $desc{$rt} = $_; next; } s/\\([0-7]{1,3})/chr oct $1/ge; push @{$input{$rt}}, $_; } # Regression Tests based on RT reports { # http://rt.cpan.org/Ticket/Display.html?id=24386 $rt = 24386; # \t doesn't work in _XS, works in _PP my @lines = @{$input{$rt}}; ok (my $csv = Text::CSV->new ({ sep_char => "\t" }), "RT-$rt: $desc{$rt}"); is ($csv->sep_char, "\t", "sep_char = TAB"); foreach my $line (0 .. $#lines) { ok ($csv->parse ($lines[$line]), "parse line $line"); ok (my @fld = $csv->fields, "Fields for line $line"); is (scalar @fld, 25, "Line $line has 25 fields"); # print STDERR "# $fld[2] - $fld[3]\t- $fld[4]\n"; } } { # http://rt.cpan.org/Ticket/Display.html?id=21530 $rt = 21530; # getline () does not return documented value at end of # filehandle IO::Handle was first released with perl 5.00307 open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh @{$input{$rt}}; close $fh; ok (my $csv = Text::CSV->new ({ binary => 1 }), "RT-$rt: $desc{$rt}"); open $fh, "<", $tfn or die "$tfn: $!\n"; my $row; foreach my $line (1 .. 5) { ok ($row = $csv->getline ($fh), "getline $line"); is (ref $row, "ARRAY", "is arrayref"); is ($row->[0], $line, "Line $line"); } ok (eof $fh, "EOF"); is ($row = $csv->getline ($fh), undef, "getline EOF"); close $fh; unlink $tfn; } { # http://rt.cpan.org/Ticket/Display.html?id=21530 $rt = 18703; # Fails to use quote_char of '~' my ($csv, @fld); ok ($csv = Text::CSV->new ({ quote_char => "~" }), "RT-$rt: $desc{$rt}"); is ($csv->quote_char, "~", "quote_char is '~'"); ok ($csv->parse ($input{$rt}[0]), "Line 1"); ok (@fld = $csv->fields, "Fields"); is (scalar @fld, 1, "Line 1 has only one field"); is ($fld[0], "Style Name", "Content line 1"); # The line has invalid escape. the escape should only be # used for the special characters ok (!$csv->parse ($input{$rt}[1]), "Line 2"); } { # http://rt.cpan.org/Ticket/Display.html?id=15076 $rt = 15076; # escape_char before characters that do not need to be escaped. my ($csv, @fld); ok ($csv = Text::CSV->new ({ sep_char => ";", escape_char => "\\", allow_loose_escapes => 1, }), "RT-$rt: $desc{$rt}"); ok ($csv->parse ($input{$rt}[0]), "Line 1"); ok (@fld = $csv->fields, "Fields"); is (scalar @fld, 2, "Line 1 has two fields"); is ($fld[0], "Example", "Content field 1"); is ($fld[1], "It's an apostrophee", "Content field 2"); } { # http://rt.cpan.org/Ticket/Display.html?id=34474 $rt = 34474; # wish: integrate row-as-hashref feature from Parse::CSV open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh @{$input{$rt}}; close $fh; ok (my $csv = Text::CSV->new (), "RT-$rt: $desc{$rt}"); is ($csv->column_names, undef, "No headers yet"); open $fh, "<", $tfn or die "$tfn: $!\n"; my $row; ok ($row = $csv->getline ($fh), "getline headers"); is ($row->[0], "code", "Header line"); $csv->column_names (@$row); is_deeply ([ $csv->column_names ], [ @$row ], "Keys set"); while (my $hr = $csv->getline_hr ($fh)) { ok (exists $hr->{code}, "Line has a code field"); like ($hr->{code}, qr/^[0-9]+$/, "Code is numeric"); ok (exists $hr->{name}, "Line has a name field"); like ($hr->{name}, qr/^[A-Z][a-z]+$/, "Name"); } close $fh; unlink $tfn; } { # http://rt.cpan.org/Ticket/Display.html?id=38960 $rt = 38960; # print () on invalid filehandle warns and returns success open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh ""; close $fh; my $err = ""; open $fh, "<", $tfn or die "$tfn: $!\n"; ok (my $csv = Text::CSV->new (), "RT-$rt: $desc{$rt}"); local $SIG{__WARN__} = sub { $err = "Warning" }; ok (!$csv->print ($fh, [ 1 .. 4 ]), "print ()"); is ($err, "Warning", "IO::Handle triggered a warning"); is (($csv->error_diag)[0], 2200, "error 2200"); close $fh; unlink $tfn; } { # http://rt.cpan.org/Ticket/Display.html?id=40507 $rt = 40507; # Parsing fails on escaped null byte ok (my $csv = Text::CSV->new ({ binary => 1 }), "RT-$rt: $desc{$rt}"); my $str = $input{$rt}[0]; ok ($csv->parse ($str), "parse () correctly escaped NULL"); is_deeply ([ $csv->fields ], [ qq{Audit active: "TRUE \0}, qq{Desired:}, qq{Audit active: "TRUE \0} ], "fields ()"); $str = $input{$rt}[1]; is ($csv->parse ($str), 0, "parse () badly escaped NULL"); my @diag = $csv->error_diag; is ($diag[0], 2023, "Error 2023"); is ($diag[2], 23, "Position 23"); $csv->allow_loose_escapes (1); ok ($csv->parse ($str), "parse () badly escaped NULL"); } { # http://rt.cpan.org/Ticket/Display.html?id=42642 $rt = 42642; # failure on unusual quote/sep values SKIP: { $] < 5.008002 and skip "UTF8 unreliable in perl $]", 6; open my $fh, ">:raw", $tfn or die "$tfn: $!\n"; print $fh @{$input{$rt}}; close $fh; my ($sep, $quo) = $ebcdic ? ("\x3c", "\x8e") : ("\x14", "\xfe"); chop ($_ = "$_\x{20ac}") for $sep, $quo; ok (my $csv = Text::CSV->new ({ binary => 1, sep_char => $sep }), "RT-$rt: $desc{$rt}"); ok ($csv->quote_char ($quo), "Set quote_char"); open $fh, "<:raw", $tfn or die "$tfn: $!\n"; ok (my $row = $csv->getline ($fh), "getline () with decode sep/quo"); $csv->error_diag (); close $fh; unlink $tfn; is_deeply ($row, [qw( DOG CAT WOMBAT BANDERSNATCH )], "fields ()"); ok ($csv->parse ($input{$rt}[1]), "parse () with decoded sep/quo"); is_deeply ([ $csv->fields ], [ 0..3 ], "fields ()"); } } { # http://rt.cpan.org/Ticket/Display.html?id=43927 $rt = 43927; # Is bind_columns broken or am I using it wrong? open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh @{$input{$rt}}; close $fh; my ($c1, $c2); ok (my $csv = Text::CSV->new ({ binary => 1 }), "RT-$rt: $desc{$rt}"); ok ($csv->bind_columns (\$c1, \$c2), "bind columns"); open $fh, "<", $tfn or die "$tfn: $!\n"; ok (my $row = $csv->getline ($fh), "getline () with bound columns"); $csv->error_diag (); close $fh; unlink $tfn; is_deeply ($row, [], "should return empty ref"); is_deeply ([ $c1, $c2], [ 1, 2 ], "fields ()"); } { # http://rt.cpan.org/Ticket/Display.html?id=44402 $rt = 44402; # Unexpected results parsing tab-separated spaces open my $fh, ">", $tfn or die "$tfn: $!\n"; my @ws = ("", " ", " "); foreach my $f1 (@ws) { foreach my $f2 (@ws) { foreach my $f3 (@ws) { print $fh "$f1\t$f2\t$f3\r\n"; } } } close $fh; my $csv; ok ($csv = Text::CSV->new ({ sep_char => "\t", }), "RT-$rt: $desc{$rt}"); open $fh, "<", $tfn or die "$tfn: $!\n"; while (my $row = $csv->getline ($fh)) { ok ($row, "getline $."); my @row = @$row; is ($#row, 2, "Got 3 fields"); like ($row[$_], qr{^ *$}, "field $_ with only spaces") for 0..2; } ok ($csv->eof, "read complete file"); close $fh; ok ($csv = Text::CSV->new ({ sep_char => "\t", allow_whitespace => 1, }), "RT-$rt: $desc{$rt}"); open $fh, "<", $tfn or die "$tfn: $!\n"; while (my $row = $csv->getline ($fh)) { ok ($row, "getline $."); my @row = @$row; is ($#row, 2, "Got 3 fields"); is ($row[$_], "", "field $_ empty") for 0..2; } ok ($csv->eof, "read complete file"); close $fh; unlink $tfn; ok ($csv->parse (" \t \t "), "parse ()"); is_deeply ([$csv->fields],["","",""],"3 empty fields"); } { # Detlev reported an inconsistent difference between _XS and _PP $rt = "x1000"; open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh @{$input{$rt}}; close $fh; my ($c1, $c2); ok (my $csv = Text::CSV->new ({ binary => 1, eol => "\n", sep_char => "\t", escape_char => undef, quote_char => undef, binary => 1 }), "RT-$rt: $desc{$rt}"); open $fh, "<", $tfn or die "$tfn: $!\n"; for (1 .. 4) { ok (my $row = $csv->getline ($fh), "getline ()"); is (scalar @$row, 27, "Line $_: 27 columns"); } for (5 .. 6) { ok (my $row = $csv->getline ($fh), "getline ()"); is (scalar @$row, 1, "Line $_: 1 column"); } $csv->error_diag (); close $fh; unlink $tfn; } { # Ruslan reported a case where only Text::CSV_PP misbehaved (regression test) $rt = "x1001"; open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh @{$input{$rt}}; close $fh; my ($c1, $c2); ok (my $csv = Text::CSV->new (), "RT-$rt: $desc{$rt}"); open $fh, "<", $tfn or die "$tfn: $!\n"; for (1 .. 4) { ok (my $row = $csv->getline ($fh), "getline ($_)"); is (scalar @$row, 2, "Line $_: 2 columns"); my @exp = $_ <= 2 ? ("0", "A") : ("A", "0"); is_deeply ($row, \@exp, "@exp"); } close $fh; unlink $tfn; } { # http://rt.cpan.org/Ticket/Display.html?id=58356 $rt = "58356"; # Incorrect CSV generated if "quote_space => 0" ok (my $csv = Text::CSV->new ({ binary => 1, quote_space => 0 }), "RT-$rt: $desc{$rt}"); my @list = ("a a", "b,b", "c ,c"); ok ($csv->combine (@list), "combine ()"); is ($csv->string, q{a a,"b,b","c ,c"}, "string ()"); } { # http://rt.cpan.org/Ticket/Display.html?id=61525 $rt = "61525"; # eol not working for values other than "\n"? # First try with eol in constructor foreach my $eol ("\n", "\r", "!") { $/ = "\n"; my $s_eol = _readable ($eol); ok (my $csv = Text::CSV->new ({ binary => 1, sep_char => ":", quote_char => '"', escape_char => '"', eol => $eol, auto_diag => 1, }), "RT-$rt: $desc{$rt} - eol = $s_eol (1)"); open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh join $eol => qw( "a":"b" "c":"d" "e":"x!y" "!!":"z" ); close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; is_deeply ($csv->getline ($fh), [ "a", "b" ], "Pair 1"); is_deeply ($csv->getline ($fh), [ "c", "d" ], "Pair 2"); is_deeply ($csv->getline ($fh), [ "e", "x!y" ], "Pair 3"); is_deeply ($csv->getline ($fh), [ "!!", "z" ], "Pair 4"); is ($csv->getline ($fh), undef, "no more pairs"); ok ($csv->eof, "EOF"); close $fh; unlink $tfn; } # And secondly with eol as method only if not one of the defaults foreach my $eol ("\n", "\r", "!") { $/ = "\n"; my $s_eol = _readable ($eol); ok (my $csv = Text::CSV->new ({ binary => 1, sep_char => ":", quote_char => '"', escape_char => '"', auto_diag => 1, }), "RT-$rt: $desc{$rt} - eol = $s_eol (2)"); $eol eq "!" and $csv->eol ($eol); open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh join $eol => qw( "a":"b" "c":"d" "e":"x!y" "!!":"z" ); close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; is_deeply ($csv->getline ($fh), [ "a", "b" ], "Pair 1"); is_deeply ($csv->getline ($fh), [ "c", "d" ], "Pair 2"); is_deeply ($csv->getline ($fh), [ "e", "x!y" ], "Pair 3"); is_deeply ($csv->getline ($fh), [ "!!", "z" ], "Pair 4"); is ($csv->getline ($fh), undef, "no more pairs"); ok ($csv->eof, "EOF"); close $fh; unlink $tfn; } } { # http://rt.cpan.org/Ticket/Display.html?id=74216 $rt = "74216"; # setting 'eol' affects global input record separator open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh @{$input{$rt}}; close $fh; my $slurp_check = sub { open $fh, "<", $tfn or die "$tfn: $!\n"; is (scalar @{[<$fh>]}, 4); close $fh; }; $slurp_check->(); my $crlf = "\015\012"; open my $fhx, ">", "_$tfn" or die "_$tfn: $!\n"; print $fhx "a,b,c" . $crlf . "1,2,3" . $crlf; close $fhx; open $fhx, "<", "_$tfn" or die "_$tfn: $!\n"; my $csv = Text::CSV->new ({ eol => $crlf }); is_deeply ($csv->getline ($fhx), [qw( a b c )]); close $fhx; unlink "_$tfn"; $slurp_check->(); { local $/ = "\n"; $slurp_check->(); } } SKIP: { # http://rt.cpan.org/Ticket/Display.html?id=74220 $] < 5.008002 and skip "UTF8 unreliable in perl $]", 7; $rt = "74220"; # Text::CSV can be made to produce bad strings my $csv = Text::CSV->new ({ binary => 1 }); my $ax = chr (0xfa); my $bx = "foo"; # We set the UTF-8 flag on a string with no funny characters utf8::upgrade ($bx); is ($bx, "foo", "no funny characters in the string"); ok (utf8::valid ($ax), "first string correct in Perl"); ok (utf8::valid ($bx), "second string correct in Perl"); ok ($csv->combine ($ax, $bx), "combine ()"); ok (my $foo = $csv->string (), "string ()"); ok (utf8::valid ($foo), "is combined string correct inside Perl?"); is ($foo, qq{\xfa,foo}, "expected result"); } SKIP: { # http://rt.cpan.org/Ticket/Display.html?id=80680 (eval { require Encode; $Encode::VERSION } || "0.00") =~ m{^([0-9.]+)}; $1 < 2.47 and skip "Encode is too old for these tests", 20000; $] < 5.008008 and skip "UTF8+Encode unreliable in perl $]", 20000; $rt = "80680"; # Text::CSV produces garbage on some data my $csv = Text::CSV->new ({ binary => 1 }); my $txt = "\x{415}\x{43a}\x{438}\x{43d}\x{431}\x{443}\x{440}\x{433}\x{2116}"; BIG_LOOP: foreach my $n (1 .. 5000) { foreach my $e (0 .. 3) { my $data = ("a" x $e) . ($txt x $n); my $enc = Encode::encode ("UTF-8", $data); my $exp = qq{1,"$enc"}; my $out = ""; open my $fh, ">:encoding(utf-8)", \$out or die "IO: $!\n"; $csv->print ($fh, [ 1, $data ]); close $fh; my $l = length ($out); if ($out eq $exp) { ok (1, "Buffer boundary check $n/$e ($l)"); next; } is ($out, $exp, "Data $n/$e ($l)"); last BIG_LOOP; } } } { # http://rt.cpan.org/Ticket/Display.html?id=81295 $rt = 81295; # escaped sep_char discarded when only item in unquoted field my $csv = Text::CSV->new ({ escape_char => "\\", auto_diag => 1 }); ok ($csv->parse ($input{$rt}[0]), "parse without allow_unquoted_escape"); is_deeply ([ $csv->fields ], [ 1, ",", 3 ], "escaped sep in quoted field"); $csv->allow_unquoted_escape (1); ok ($csv->parse ($input{$rt}[1]), "parse with allow_unquoted_escape"); is_deeply ([ $csv->fields ], [ 1, ",", 3 ], "escaped sep in unquoted field"); } { # http://rt.cpan.org/Ticket/Display.html?id=113279 $rt = 113279; # Failed parse + bind_columns causes memory corruption my $csv = Text::CSV->new (); is ($csv->parse ($input{$rt}[0]), 0, "parse invalid content"); is (0 + $csv->error_diag, 2034, "Error is kept"); my $fld; ok ($csv->bind_columns (\$fld), "bound column"); is ($csv->parse ($input{$rt}[0]), 0, "parse invalid content to bc"); is (0 + $csv->error_diag, 2034, "Error is kept"); } { # http://rt.cpan.org/Ticket/Display.html?id=115953 $rt = 115953; # Space stripped from middle of field value with allow_whitespace and allow_loose_quotes SKIP: { $] < 5.006002 and skip "unreliable in perl $]", 2; my $csv = Text::CSV->new ({ allow_loose_quotes => 1, escape_char => undef, allow_whitespace => 1, }); ok ($csv->parse ($input{$rt}[0]), "parse valid content"); is_deeply ([ $csv->fields ], [ q{foo "bar" baz} ], "Data"); } } { # http://rt.cpan.org/Ticket/Display.html?id=120655 $rt = 120655; # bind_columns with strange behavior / length() from old value SKIP: { $] < 5.008002 and skip "UTF8 unreliable in perl $]", 5; my $csv = Text::CSV->new ({ binary => 1 }); my %row; ok ($csv->bind_columns (\$row{c1}), "Bind columns"); my $oe = $ebcdic ? "\x8e\x62" : "\xc5\x93"; ok ($csv->parse ("pr${oe}blem"), "Parse utf-8 content"); is (length $row{c1}, 7, "Length"); ok ($csv->parse (""), "Parse empty line"); is (length $row{c1}, 0, "Length"); } } { # http://rt.cpan.org/Ticket/Display.html?id=123320 $rt = 123320; # ext::CSV_XS bug w/Mac format files SKIP: { $] < 5.008001 and skip "unreliable in perl $]", 4; open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh join "\r" => q{col1,col2,col3,}, q{"One","","Three"}, q{"Four","Five and a half","Six"}, q{}; close $fh; ok (my $csv = Text::CSV->new ({ auto_diag => 1, eol => "\r", }), "new"); my @msg; local $SIG{__WARN__} = sub { push @msg, @_; }; open $fh, "<", $tfn or die "$!\n"; my @hdr = eval { $csv->header ($fh); }; is (scalar @hdr, 0, "Empty field in header"); is (($csv->error_diag)[0], 1012, "error 1012"); close $fh; open $fh, ">", $tfn or die "$tfn: $!\n"; print $fh join "\r" => q{col1,col2,col3}, q{"One","Two","Three"}, ""; close $fh; open $fh, "<", $tfn or die "$!\n"; @hdr = eval { $csv->header ($fh); }; is_deeply (\@hdr, [qw( col1 col2 col3 )], "Header is ok"); close $fh; } } __END__ «24386» - \t doesn't work in _XS, works in _PP VIN StockNumber Year Make Model MD Engine EngineSize Transmission DriveTrain Trim BodyStyle CityFuel HWYFuel Mileage Color InteriorColor InternetPrice RetailPrice Notes ShortReview Certified NewUsed Image_URLs Equipment 1HGCM66573A030460 1621HA 2003 HONDA ACCORD EX V-6 ACCORD DOHC 16-Valve VTEC 3.0L 5-Speed Automatic EX V-6 4DR 21 30 70940 Gray Gray 15983 15983 AutoWeek calls the 2003 model the best Accord yet * Fun to hustle down a twisty road according to Road & Track * Sedan perfection according to Car and Driver * Named on the 2003 Car and Driver Ten Best List * Named a Consumer Guide Best Buy for 2003 * 0 0 http://vin.windowstickers.biz/incoming/w_1HGCM66573A030460_1.JPG, http://vin.windowstickers.biz/incoming/w_1HGCM66573A030460_2.JPG, http://vin.windowstickers.biz/incoming/w_1HGCM66573A030460_3.JPG, http://vin.windowstickers.biz/incoming/w_1HGCM66573A030460_4.JPG, http://vin.windowstickers.biz/incoming/w_1HGCM66573A030460_5.JPG, http://vin.windowstickers.biz/incoming/w_1HGCM66573A030460_6.JPG, http://vin.windowstickers.biz/incoming/w_1HGCM66573A030460_7.JPG, http://vin.windowstickers.biz/incoming/w_1HGCM66573A030460_8.JPG 120-Watt AM/FM Stereo System,3-Point Seat Belts,4-Wheel Double Wishbone Suspension,6-Disc In-Dash Compact Disc Changer,6-Speaker Audio System,8-Way Power Adjustable Driver's Seat,Air Conditioning w/Air-Filtration System,Anti-Lock Braking System,Automatic-Up/Down Driver's Window,Center Console Armrest w/Storage,Child Safety Rear Door Locks,Cruise Control,Driver & Front Passenger Dual-Stage Airbags,Electronic Remote Trunk Release,Emergency Trunk Release,Fold-Down Rear Seat Center Armrest,Fold-Down Rear Seatback w/Lock,Front Seat Side-Impact Airbags,Immobilizer Theft Deterrent System,LATCH Lower Anchor & Tethers For Children,Power Driver's Seat Height Adjustment,Power Exterior Mirrors,Power Moonroof w/Tilt Feature,Power Windows & Door Locks,Power-Assisted 4-Wheel Disc Brakes,Rear Window Defroster w/Timer,Remote Keyless Entry System w/Window Control,Security System,Tilt & Telescopic Steering Column,Traction Control System,Variable Intermittent Windshield Wipers,Variable-Assist Power Rack & Pinion Steering 1FTRW12W66KA65476 4110J 2006 FORD F-150 XLT CREW 5.5SB 4X2 F-150 SOHC Triton V8 4.6L 4-Speed Automatic 4X2 XLT CREW 5.5SB 15 19 20334 Black Gray 22923 22923 Named a Consumer Guide 2005 & 2006 Best Buy * Named Best Pickup by Car and Driver * The Detroit Free Press calls F-150 the best pickup truck ever * The Detroit News calls F-150 the best America has to offer * 0 0 http://vin.windowstickers.biz/incoming/w_1FTRW12W66KA65476_1.JPG, http://vin.windowstickers.biz/incoming/w_1FTRW12W66KA65476_2.JPG, http://vin.windowstickers.biz/incoming/w_1FTRW12W66KA65476_3.JPG, http://vin.windowstickers.biz/incoming/w_1FTRW12W66KA65476_4.JPG, http://vin.windowstickers.biz/incoming/w_1FTRW12W66KA65476_5.JPG, http://vin.windowstickers.biz/incoming/w_1FTRW12W66KA65476_6.JPG, http://vin.windowstickers.biz/incoming/w_1FTRW12W66KA65476_7.JPG, http://vin.windowstickers.biz/incoming/w_1FTRW12W66KA65476_8.JPG, http://vin.windowstickers.biz/incoming/w_1FTRW12W66KA65476_9.JPG 4-Pin Trailer Tow Connector,Air Conditioning,AM/FM Stereo w/Single Compact Disc Player,Auxiliary Power Outlets,Cargo Box Light & Tie-Downs,Child Safety Seat Lower Anchors & Tether Anchors,Crash Severity Sensor,Cruise Control,Dual-Stage Driver & Front-Right Passenger Airbags,Electronic Brake Force Distribution,Exterior Temperature & Compass Display,Fail-Safe Engine Cooling System,Front Dome Light w/Integrated Map Lights,Front Power Points,Front Seat Personal Safety System,Front-Passenger Sensing System,Manual Day/Night Interior Rearview Mirror,Oil Pressure & Coolant Temperature Gauges,Power 4-Wheel Disc Anti-Lock Brakes,Power Door Locks,Power Exterior Mirrors,Power Front Windows w/One-Touch Driver Side,Power Rack & Pinion Steering,Remote Keyless Entry System,Removable Tailgate w/Key Lock,Securilock Passive Anti-Theft System,Spare Tire w/Wheel Lock,Speed-Dependent Interval Windshield Wipers,Tailgate Assist System,Tilt Steering Wheel,Visors w/Covered Vanity Mirrors 5GZCZ23D03S826657 2111A 2003 SATURN VUE BASE FWD VUE DOHC 4-cylinder 2.2L 5-Speed Manual FWD BASE 5DR 23 28 74877 Silver Gray 11598 11598 Edmunds 2003 Buyer's Guide calls Vue a well-thought-out and capable mini sport utility vehicle, with large doors for ease of entry and exit, extensive cabin space and excellent crash test scores * 0 0 http://vin.windowstickers.biz/incoming/w_5GZCZ23D03S826657_1.JPG, http://vin.windowstickers.biz/incoming/w_5GZCZ23D03S826657_2.JPG, http://vin.windowstickers.biz/incoming/w_5GZCZ23D03S826657_3.JPG, http://vin.windowstickers.biz/incoming/w_5GZCZ23D03S826657_4.JPG, http://vin.windowstickers.biz/incoming/w_5GZCZ23D03S826657_5.JPG, http://vin.windowstickers.biz/incoming/w_5GZCZ23D03S826657_6.JPG, http://vin.windowstickers.biz/incoming/w_5GZCZ23D03S826657_7.JPG, http://vin.windowstickers.biz/incoming/w_5GZCZ23D03S826657_8.JPG 70/30 Split Folding Rear Seatback,AM/FM Stereo System,Center Console w/Storage,Center High-Mounted Rear Stop Light,CFC-Free Air Conditioning,Cloth Upholstery,Daytime Running Lights,Dent-Resistant Polymer Body Panels,Distributorless Ignition System,Driver & Front Passenger Frontal Airbags,Electric Power Rack-And-Pinion Steering,Fold-Flat Front Passenger Seat,Front & Rear Crumple Zones,Front & Rear Cup Holders,Front Bucket Seats,Front-Wheel Drive,Independent Front & Rear Suspension,Interval Rear Window Wiper/Washer,Interval Windshield Wipers,LATCH Child Safety Seat Anchor System,Platinum-Tipped Spark Plugs,Power Front Disc/Rear Drum Brakes,Rear Privacy Glass,Rear Window Defogger,Remote Rear Liftgate Release,Roof Rack,Sequential Fuel Injection,Side-Impact Door Beams,Tachometer,Theft-Deterrent System,Tilt Adjustable Steering Wheel,Visor Vanity Mirrors 1FMZU67K15UB18754 4067T 2005 FORD EXPLORER SPORT TRAC XLT 4X2 EXPLORER SPORT TRAC Flex Fuel SOHC V6 4.0L 5-Speed Automatic 4X2 XLT 4DR 16 21 12758 Maroon Gray 20995 20995 Consumer Guide 2005 reports Sport Trac offers more passenger space than other crew-cab pick-ups and is a good choice as a multipurpose vehicle * Consumer Guide 2005 credits Sport Trac with good in-cabin storage * 0 0 http://vin.windowstickers.biz/incoming/w_1FMZU67K15UB18754_1.JPG, http://vin.windowstickers.biz/incoming/w_1FMZU67K15UB18754_2.JPG, http://vin.windowstickers.biz/incoming/w_1FMZU67K15UB18754_3.JPG, http://vin.windowstickers.biz/incoming/w_1FMZU67K15UB18754_4.JPG, http://vin.windowstickers.biz/incoming/w_1FMZU67K15UB18754_5.JPG, http://vin.windowstickers.biz/incoming/w_1FMZU67K15UB18754_6.JPG, http://vin.windowstickers.biz/incoming/w_1FMZU67K15UB18754_7.JPG 3-Point Front & Rear Seatbelts,4-Speaker Audio System,Air Conditioning,AM/FM Stereo w/Compact Disc Player,Belt-Minder Safety Belt Reminder System,Child Safety Rear Door Locks,Cloth Upholstery,Cruise Control,Driver & Front Passenger Airbags,Driver Door Keyless Entry Keypad,Headlights-On Alert Chime,Height-Adjustable Front Seatbelts,LATCH Child Seat Lower Anchors & Tether Anchors,Locking Tailgate,Low-Back Front Bucket Seats,Lower Bodyside Moldings,Manual Day/Night Interior Rearview Mirror,Power 4-Wheel Disc Anti-Lock Brakes,Power Door Locks,Power Exterior Mirrors,Power Rack & Pinion Steering,Power Rear Window w/Anti-Pinch,Power Windows w/Driver One-Touch Down,Remote Keyless Entry System,Roof Rails,Securilock Passive Anti-Theft System,Side-Intrusion Door Beams,Sirius Satellite Radio/MP3 Capability,Solar-Tinted Glass Windows,Speed-Sensitive Intermittent Windshield Wipers,Tachometer,Tilt Steering Wheel 1J4GK48K96W108753 4068T 2006 JEEP LIBERTY SPORT 4X2 LIBERTY SOHC 12-valve V6 3.7L 4-Speed Automatic 4X2 SPORT 5DR 17 22 12419 Silver Gray 16999 16999 Named on the Automobile Magazine 50 Great New Cars List * Motor Trend reports Liberty fulfills the original go-anywhere mission of SUVs without fail or compromise * A Consumer Guide 2005 & 2006 Recommended Buy * 0 0 http://vin.windowstickers.biz/incoming/w_1J4GK48K96W108753_1.JPG, http://vin.windowstickers.biz/incoming/w_1J4GK48K96W108753_2.JPG, http://vin.windowstickers.biz/incoming/w_1J4GK48K96W108753_3.JPG, http://vin.windowstickers.biz/incoming/w_1J4GK48K96W108753_4.JPG, http://vin.windowstickers.biz/incoming/w_1J4GK48K96W108753_5.JPG, http://vin.windowstickers.biz/incoming/w_1J4GK48K96W108753_6.JPG, http://vin.windowstickers.biz/incoming/w_1J4GK48K96W108753_7.JPG, http://vin.windowstickers.biz/incoming/w_1J4GK48K96W108753_8.JPG, http://vin.windowstickers.biz/incoming/w_1J4GK48K96W108753_9.JPG 12-Volt Cargo Area Power Outlet,65/35 Split-Folding Rear Bench Seat,6-Speaker Audio System,Advanced Multi-Stage Frontal Airbags,Air Conditioning,All-Wheel Traction Control System,AM/FM Stereo w/Compact Disc Player,Center Console 12-Volt Power Outlet,Child Safety Rear Door Locks,Cloth Sun Visors w/Pull-Out Sunshade,Cloth Upholstery,Coolant Temperature Gauge,Electric Rear Window Defroster,Electronic Stability Program,Enhanced Accident Response System,Halogen Headlights w/Delay-Off Feature,LATCH Child Safety Seat Anchor System,Manual Day/Night Interior Rearview Mirror,Power 4-Wheel Disc Anti-Lock Brake System,Power Door Locks,Power Exterior Mirrors,Power Rack & Pinion Steering,Power Windows w/Front One-Touch Down,Rear Window Wiper/Washer,Remote Keyless Entry System,Roof Side Rails,Sentry Key Engine Immobilizer,Spare Tire Carrier,Tachometer,Tilt Steering Column,Tinted Windshield Glass,Variable Speed Intermittent Windshield Wipers «21530» - getline () does not return documented value at end of filehandle 1,1,2,3,4,5 2,1,2,3,4,5 3,1,2,3,4,5 4,1,2,3,4,5 5,1,2,3,4,5 «18703» - Fails to use quote_char of '~' ~Style Name~ ~5dr Crew Cab 130" WB 2WD LS~ ",~"~,~""~,~"""~,,~~, «15076» - escape_char before characters that do not need to be escaped. "Example";"It\'s an apostrophee" «34474» - wish: integrate row-as-hashref feature from Parse::CSV code,name,price,description 1,Dress,240.00,"Evening gown" 2,Drinks,82.78,"Drinks" 3,Sex,-9999.99,"Priceless" «38960» - print () on invalid filehandle warns and returns success «40507» - Parsing fails on escaped null byte "Audit active: ""TRUE "0","Desired:","Audit active: ""TRUE "0" "Audit active: ""TRUE "\0","Desired:","Audit active: ""TRUE "\0" «42642» - failure on unusual quote/sep values þDOGþþCATþþWOMBATþþBANDERSNATCHþ þ0þþ1þþ2þþ3þ «43927» - Is bind_columns broken or am I using it wrong? 1,2 «44402» - Unexpected results parsing tab-separated spaces «x1000» - Detlev reported inconsistent behavior between XS and PP B:033_02_ -drop, +drop animal legs @p 02-033.bmp @p 02-033.bmp  \x{A} 1 :c/b01:!1 ! 13 !6.!6 :b/b01:0 B:033_02_ R#012a 2 B:034_02c diagonal, trac -bound up @p 02-034c.bmp @p 02-034c.bmp  Found through e_sect2.pdf as U+F824 (,) and U+2E88 (⺈,) but won't display \x{A} 1 :c/b01:!1 ! 11 !10 :b/b01:0 2E88 B:034_02c R#018b 2 B:035_02_ +drop, -drop fission 丷  Aufgrund folgender Fälle definiere ich einen neuen Baustein, der simp. mit "horns&" identisch ist.\x{A}隊队 (jap.: pinnacle, horns&sow)\x{A}曾曾兌兑\x{A}über "golden calf":\x{A}é€é€ 1 :c/b01:!1 ! 11 !10 :b/b01:0 4E37 B:035_02_ 2 B:035_03_ fission, one horns @p 03-035.bmp @p 03-035.bmp  obsolete Heising explanation for form without the horizontal line: Variante von "horns", die erscheint, wenn darunter keine horizontale Linie steht\x{A}\x{A}Found through e_sect2.pdf as U+F7EA (??,) but won't display \x{A} 1 :c/b01:!1 ! 11 !10 :b/b01:0 B:035_03_ 3 --------------090302050909040309030109-- «58356» - Incorrect CSV generated if "quote_space => 0" «61525» - eol not working for values other than "\n"? «74216» - setting 'eol' affects global input record separator 1,2 3,4 5,6 7,8 «74330» - Text::CSV can be made to produce bad strings «80680» - Text::CSV produces garbage on some data «81295» - escaped sep_char discarded when only item in unquoted field 1,"\,",3 1,\,,3 «x1001» - Lines starting with "0" (Ruslan Dautkhanov) "0","A" "0","A" "A","0" "A","0" «113279» - Failed parse + bind_columns causes memory corruption foo "bar" «115953» - Space stripped from middle of field value with allow_whitespace and allow_loose_quotes "foo "bar" baz" «120655» - bind_columns with strange behavior / length() from old value «123320» - ext::CSV_XS bug w/Mac format files Text-CSV-2.06/t/40_misc.t0000644000175100017510000000332314760113543015055 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More tests => 24; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; require_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } $| = 1; my @binField = ("abc\0def\n\rghi", "ab\"ce,\031\"'", "\266"); my $csv = Text::CSV->new ({ binary => 1 }); ok ($csv->combine (@binField), "combine ()"); my $string; is_binary ($string = $csv->string, qq("abc"0def\n\rghi","ab""ce,\031""'",\266), "string ()"); ok ($csv->parse ($string), "parse ()"); is ($csv->fields, scalar @binField, "field count"); my @field = $csv->fields (); for (0 .. $#binField) { is ($field[$_], $binField[$_], "Field $_"); } ok (1, "eol \\r\\n"); $csv->eol ("\r\n"); ok ($csv->combine (@binField), "combine ()"); is_binary ($csv->string, qq("abc"0def\n\rghi","ab""ce,\031""'",\266\r\n), "string ()"); ok (1, "eol \\n"); $csv->eol ("\n"); ok ($csv->combine (@binField), "combine ()"); is_binary ($csv->string, qq("abc"0def\n\rghi","ab""ce,\031""'",\266\n), "string ()"); ok (1, "eol ,xxxxxxx\\n"); $csv->eol (",xxxxxxx\n"); ok ($csv->combine (@binField), "combine ()"); is_binary ($csv->string, qq("abc"0def\n\rghi","ab""ce,\031""'",\266,xxxxxxx\n), "string ()"); $csv->eol ("\n"); ok (1, "quote_char undef"); $csv->quote_char (undef); ok ($csv->combine ("abc","def","ghi"), "combine"); is ($csv->string, "abc,def,ghi\n", "string ()"); # Ken's test ok (1, "always_quote"); my $csv2 = Text::CSV->new ({ always_quote => 1 }); ok ($csv2, "new ()"); ok ($csv2->combine ("abc","def","ghi"), "combine ()"); is ($csv2->string, '"abc","def","ghi"', "string ()"); Text-CSV-2.06/t/46_eol_si.t0000644000175100017510000001565514760113543015415 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Config; use Test::More; BEGIN { unless (exists $Config{useperlio} && defined $Config{useperlio} && $] >= 5.008 && # perlio was experimental in 5.6.2, but not reliable $Config{useperlio} eq "define") { plan skip_all => "No reliable perlIO available"; } else { plan tests => 562; } } BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; require_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } $| = 1; # Embedded newline tests my $file = ""; my $def_rs = $/; foreach my $rs ("\n", "\r\n", "\r") { for $\ (undef, $rs) { my $csv = Text::CSV->new ({ binary => 1 }); $csv->eol ($/ = $rs) unless defined $\; my $fh; foreach my $pass (0, 1) { if ($pass == 0) { $file = ""; open $fh, ">", \$file or die "IO: $!\n"; } else { open $fh, "<", \$file or die "IO: $!\n"; } foreach my $eol ("", "\r", "\n", "\r\n", "\n\r") { my $s_eol = join " - ", map { defined $_ ? $_ : "" } $\, $rs, $eol; $s_eol =~ s/\r/\\r/g; $s_eol =~ s/\n/\\n/g; my @p; my @f = ("", 1, $eol, " $eol", "$eol ", " $eol ", "'$eol'", "\"$eol\"", " \" $eol \"\n ", "EOL"); if ($pass == 0) { ok ($csv->combine (@f), "combine |$s_eol|"); ok (my $str = $csv->string, "string |$s_eol|"); my $state = $csv->parse ($str); ok ($state, "parse |$s_eol|"); if ($state) { ok (@p = $csv->fields, "fields |$s_eol|"); } else{ is ($csv->error_input, $str, "error |$s_eol|"); } print $fh $str; } else { ok (my $row = $csv->getline ($fh), "getline |$s_eol|"); is (ref $row, "ARRAY", "row |$s_eol|"); @p = @$row; } local $, = "|"; is_binary ("@p", "@f", "result |$s_eol|"); } close $fh; } } } $/ = $def_rs; { my $csv = Text::CSV->new ({ escape_char => undef }); ok ($csv->parse (qq{"x"\r\n}), "Trailing \\r\\n with no escape char"); is ($csv->eol ("\r"), "\r", "eol set to \\r"); ok ($csv->parse (qq{"x"\r}), "Trailing \\r with no escape char"); ok ($csv->allow_whitespace (1), "Allow whitespace"); ok ($csv->parse (qq{"x" \r}), "Trailing \\r with no escape char"); } SKIP: { $] < 5.008 and skip "\$\\ tests don't work in perl 5.6.x and older", 2; { local $\ = "#\r\n"; my $csv = Text::CSV->new (); $file = ""; open my $fh, ">", \$file or die "IO: $!\n"; $csv->print ($fh, [ "a", 1 ]); close $fh; open $fh, "<", \$file or die "IO: $!\n"; local $/; is (<$fh>, "a,1#\r\n", "Strange \$\\"); close $fh; } { local $\ = "#\r\n"; my $csv = Text::CSV->new ({ eol => $\ }); $file = ""; open my $fh, ">", \$file or die "IO: $!\n"; $csv->print ($fh, [ "a", 1 ]); close $fh; open $fh, "<", \$file or die "IO: $!\n"; local $/; is (<$fh>, "a,1#\r\n", "Strange \$\\ + eol"); close $fh; } } $/ = $def_rs; ok (1, "Auto-detecting \\r"); { my @row = qw( a b c ); local $" = ","; for (["\n", "\\n"], ["\r\n", "\\r\\n"], ["\r", "\\r"]) { my ($eol, $s_eol) = @$_; $file = ""; open my $fh, ">", \$file or die "IO: $!\n"; print $fh qq{@row$eol@row$eol@row$eol\x91}; close $fh; open $fh, "<", \$file or die "IO: $!\n"; my $c = Text::CSV->new ({ binary => 1, auto_diag => 1 }); is ($c->eol (), "", "default EOL"); is_deeply ($c->getline ($fh), [ @row ], "EOL 1 $s_eol"); is ($c->eol (), $eol eq "\r" ? "\r" : "", "EOL"); is_deeply ($c->getline ($fh), [ @row ], "EOL 2 $s_eol"); is_deeply ($c->getline ($fh), [ @row ], "EOL 3 $s_eol"); close $fh; } } ok (1, "Specific \\r test from tfrayner"); { $/ = "\r"; $file = ""; open my $fh, ">", \$file or die "IO: $!\n"; print $fh qq{a,b,c$/}, qq{"d","e","f"$/}; close $fh; open $fh, "<", \$file or die "IO: $!\n"; my $c = Text::CSV->new ({ eol => $/ }); my $row; local $" = " "; ok ($row = $c->getline ($fh), "getline 1"); is (scalar @$row, 3, "# fields"); is ("@$row", "a b c", "fields 1"); ok ($row = $c->getline ($fh), "getline 2"); is (scalar @$row, 3, "# fields"); is ("@$row", "d e f", "fields 2"); close $fh; } $/ = $def_rs; ok (1, "EOL undef"); { $/ = "\r"; ok (my $csv = Text::CSV->new ({ eol => undef }), "new csv with eol => undef"); $file = ""; open my $fh, ">", \$file or die "IO: $!\n"; ok ($csv->print ($fh, [1, 2, 3]), "print"); ok ($csv->print ($fh, [4, 5, 6]), "print"); close $fh; open $fh, "<", \$file or die "IO: $!\n"; ok (my $row = $csv->getline ($fh), "getline 1"); is (scalar @$row, 5, "# fields"); is_deeply ($row, [ 1, 2, 34, 5, 6], "fields 1"); close $fh; } $/ = $def_rs; foreach my $eol ("!", "!!", "!\n", "!\n!") { (my $s_eol = $eol) =~ s/\n/\\n/g; ok (1, "EOL $s_eol"); ok (my $csv = Text::CSV->new ({ eol => $eol }), "new csv with eol => $s_eol"); $file = ""; open my $fh, ">", \$file or die "IO: $!\n"; ok ($csv->print ($fh, [1, 2, 3]), "print"); ok ($csv->print ($fh, [4, 5, 6]), "print"); close $fh; foreach my $rs (undef, "", "\n", $eol, "!", "!\n", "\n!", "!\n!", "\n!\n") { local $/ = $rs; (my $s_rs = defined $rs ? $rs : "-- undef --") =~ s/\n/\\n/g; ok (1, "with RS $s_rs"); open $fh, "<", \$file or die "IO: $!\n"; ok (my $row = $csv->getline ($fh), "getline 1"); is (scalar @$row, 3, "# fields"); is_deeply ($row, [ 1, 2, 3], "fields 1"); ok ( $row = $csv->getline ($fh), "getline 2"); is (scalar @$row, 3, "# fields"); is_deeply ($row, [ 4, 5, 6], "fields 2"); close $fh; } } $/ = $def_rs; { ok (my $csv = Text::CSV->new, "new for say"); my $foo; open my $fh, ">", \$foo or die "IO: $!\n"; ok ($csv->say ($fh, [ 1, 2 ]), "say"); close $fh; is ($foo, "1,2$/", "content with eol \$/"); $foo = ""; $csv->eol (undef); open $fh, ">", \$foo or die "IO: $!\n"; ok ($csv->say ($fh, [ 1, 2 ]), "say"); close $fh; $foo = ""; $csv->eol (""); open $fh, ">", \$foo or die "IO: $!\n"; ok ($csv->say ($fh, [ 1, 2 ]), "say"); close $fh; is ($foo, "1,2$/", "content with eol \$/"); $foo = ""; $csv->eol ("#"); open $fh, ">", \$foo or die "IO: $!\n"; ok ($csv->say ($fh, [ 1, 2 ]), "say"); close $fh; is ($foo, "1,2#", "content with eol #"); $foo = ""; $csv->eol ("0"); open $fh, ">", \$foo or die "IO: $!\n"; ok ($csv->say ($fh, [ 1, 2 ]), "say"); close $fh; is ($foo, "1,20", "content with eol 0"); } { ok (my $csv = Text::CSV->new, "new for say"); my $foo; my $dta = "x"; ok ($csv->bind_columns (\$dta), "bind columns"); local $\ = undef; local $/ = "\n"; open my $fh, ">", \$foo or die "IO: $!\n"; ok ($csv->print ($fh, undef), "print"); close $fh; is ($foo, "x", "print, no newline"); $foo = ""; open $fh, ">", \$foo or die "IO: $!\n"; ok ($csv->say ($fh, undef), "say"); close $fh; is ($foo, "x\n", "say, with newline"); } 1; Text-CSV-2.06/t/12_acc.t0000644000175100017510000002770614760113543014662 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; # use warnings core since 5.6 use Test::More tests => 245; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; } my $Backend = Text::CSV->backend; my $csv; ok ($csv = Text::CSV->new, "new ()"); is ($csv->quote_char, '"', "quote_char"); is ($csv->quote, '"', "quote"); is ($csv->escape_char, '"', "escape_char"); is ($csv->sep_char, ",", "sep_char"); is ($csv->sep, ",", "sep"); is ($csv->eol, "", "eol"); is ($csv->always_quote, 0, "always_quote"); is ($csv->binary, 0, "binary"); is ($csv->keep_meta_info, 0, "keep_meta_info"); is ($csv->allow_loose_quotes, 0, "allow_loose_quotes"); is ($csv->allow_loose_escapes, 0, "allow_loose_escapes"); is ($csv->allow_unquoted_escape, 0, "allow_unquoted_escape"); is ($csv->allow_whitespace, 0, "allow_whitespace"); is ($csv->blank_is_undef, 0, "blank_is_undef"); is ($csv->empty_is_undef, 0, "empty_is_undef"); is ($csv->auto_diag, 0, "auto_diag"); is ($csv->diag_verbose, 0, "diag_verbose"); is ($csv->verbatim, 0, "verbatim"); is ($csv->formula, "none", "formula"); is ($csv->strict, 0, "strict"); is ($csv->strict_eol, 0, "strict_eol"); is ($csv->skip_empty_rows, 0, "skip_empty_rows"); is ($csv->quote_space, 1, "quote_space"); is ($csv->quote_empty, 0, "quote_empty"); is ($csv->escape_null, 1, "escape_null"); is ($csv->quote_null, 1, "quote_null"); is ($csv->quote_binary, 1, "quote_binary"); is ($csv->record_number, 0, "record_number"); is ($csv->decode_utf8, 1, "decode_utf8"); is ($csv->undef_str, undef, "undef_str"); is ($csv->comment_str, undef, "comment_str"); is ($csv->binary (1), 1, "binary (1)"); my @fld = ( 'txt =, "Hi!"', "Yes", "", 2, undef, "1.09", "\r", undef ); ok ($csv->combine (@fld), "combine"); is ($csv->string, qq{"txt =, ""Hi!""",Yes,,2,,1.09,"\r",}, "string"); is ($csv->sep_char (";"), ";", "sep_char (;)"); is ($csv->sep ("**"), "**", "sep (**)"); is ($csv->sep (";"), ";", "sep (;)"); is ($csv->sep_char (), ";", "sep_char ()"); is ($csv->quote_char ("="), "=", "quote_char (=)"); is ($csv->quote_char (undef), undef, "quote_char (undef)"); is ($csv->{quote_char}, undef, "{quote_char} (undef)"); is ($csv->quote (undef), "", "quote (undef)"); is ($csv->quote (""), "", "quote (undef)"); is ($csv->quote ("**"), "**", "quote (**)"); is ($csv->quote ("="), "=", "quote (=)"); is ($csv->eol (undef), "", "eol (undef)"); is ($csv->eol (""), "", "eol ('')"); is ($csv->eol ("\r"), "\r", "eol (\\r)"); is ($csv->keep_meta_info (1), 1, "keep_meta_info (1)"); is ($csv->keep_meta_info (0), 0, "keep_meta_info (0)"); is ($csv->keep_meta_info (""), 0, "keep_meta_info ('')"); is ($csv->keep_meta_info (undef), 0, "keep_meta_info (undef)"); is ($csv->keep_meta_info ("false"), 0, "keep_meta_info (undef)"); is ($csv->keep_meta_info ("true"), 1, "keep_meta_info (undef)"); is ($csv->always_quote (undef), 0, "always_quote (undef)"); is ($csv->always_quote (1), 1, "always_quote (1)"); is ($csv->allow_loose_quotes (1), 1, "allow_loose_quotes (1)"); is ($csv->allow_loose_escapes (1), 1, "allow_loose_escapes (1)"); is ($csv->allow_unquoted_escape (1), 1, "allow_unquoted_escape (1)"); is ($csv->allow_whitespace (1), 1, "allow_whitespace (1)"); is ($csv->blank_is_undef (1), 1, "blank_is_undef (1)"); is ($csv->empty_is_undef (1), 1, "empty_is_undef (1)"); is ($csv->auto_diag (1), 1, "auto_diag (1)"); is ($csv->auto_diag (2), 2, "auto_diag (2)"); is ($csv->auto_diag (9), 9, "auto_diag (9)"); is ($csv->auto_diag ("true"), 1, "auto_diag (\"true\")"); is ($csv->auto_diag ("false"), 0, "auto_diag (\"false\")"); is ($csv->auto_diag (undef), 0, "auto_diag (undef)"); is ($csv->auto_diag (""), 0, "auto_diag (\"\")"); is ($csv->diag_verbose (1), 1, "diag_verbose (1)"); is ($csv->diag_verbose (2), 2, "diag_verbose (2)"); is ($csv->diag_verbose (9), 9, "diag_verbose (9)"); is ($csv->diag_verbose ("true"), 1, "diag_verbose (\"true\")"); is ($csv->diag_verbose ("false"), 0, "diag_verbose (\"false\")"); is ($csv->diag_verbose (undef), 0, "diag_verbose (undef)"); is ($csv->diag_verbose (""), 0, "diag_verbose (\"\")"); is ($csv->verbatim (1), 1, "verbatim (1)"); is ($csv->formula ("diag"), "diag", "formula (\"diag\")"); is ($csv->strict (1), 1, "strict (1)"); is ($csv->strict_eol (1), 1, "strict_eol (1)"); is ($csv->skip_empty_rows (1), 1, "skip_empty_rows (1)"); is ($csv->quote_space (1), 1, "quote_space (1)"); is ($csv->quote_empty (1), 1, "quote_empty (1)"); is ($csv->escape_null (1), 1, "escape_null (1)"); is ($csv->quote_null (1), 1, "quote_null (1)"); is ($csv->quote_binary (1), 1, "quote_binary (1)"); is ($csv->escape_char (undef), undef, "escape_char (undef)"); is ($csv->{escape_char}, undef, "{escape_char} (undef)"); is ($csv->escape_char ("\\"), "\\", "escape_char (\\)"); ok ($csv->combine (@fld), "combine"); is ($csv->string, qq{=txt \\=, "Hi!"=;=Yes=;==;=2=;;=1.09=;=\r=;\r}, "string"); is ($csv->undef_str ("-"), "-", "undef_str"); is ($csv->comment_str ("#"), "#", "comment_str"); is ($csv->allow_whitespace (0), 0, "allow_whitespace (0)"); is ($csv->quote_space (0), 0, "quote_space (0)"); is ($csv->quote_empty (0), 0, "quote_empty (0)"); is ($csv->escape_null (0), 0, "escape_null (0)"); is ($csv->quote_null (0), 0, "quote_null (0)"); is ($csv->quote_binary (0), 0, "quote_binary (0)"); is ($csv->decode_utf8 (0), 0, "decode_utf8 (0)"); is ($csv->sep ("--"), "--", "sep (\"--\")"); is ($csv->sep_char (), "\0", "sep_char"); is ($csv->quote ("++"), "++", "quote (\"++\")"); is ($csv->quote_char (), "\0", "quote_char"); is ($csv->undef_str (undef), undef, "undef_str"); is ($csv->comment_str (undef), undef, "comment_str"); # Test single-byte specials in UTF-8 mode is ($csv->sep ("|"), "|", "sep |"); is ($csv->sep_char (), "|", "sep_char"); chop (my $s = "|\x{20ac}"); is ($csv->sep ($s), "|", "sep |"); is ($csv->sep (), "|", "sep_char"); is ($csv->sep_char (), "|", "sep_char"); is ($csv->quote ("'"), "'", "quote '"); is ($csv->quote_char (), "'", "quote_char"); chop (my $q = "'\x{20ac}"); is ($csv->quote ($q), "'", "quote '"); is ($csv->quote (), "'", "quote_char"); is ($csv->quote_char (), "'", "quote_char"); # Funny settings, all three translate to \0 internally ok ($csv = Text::CSV->new ({ sep => "::::::::::", quote_char => undef, escape_char => undef, }), "new (undef ...)"); is ($csv->sep_char, "\0", "sep_char undef"); is ($csv->sep, "::::::::::", "sep long"); is ($csv->quote_char, undef, "quote_char undef"); is ($csv->quote, undef, "quote undef"); is ($csv->escape_char, undef, "escape_char undef"); ok ($csv->parse ("foo"), "parse (foo)"); $csv->sep_char (","); is ($csv->record_number, 1, "record_number"); ok ($csv->parse ("foo"), "parse (foo)"); is ($csv->record_number, 2, "record_number"); ok (!$csv->parse ("foo,foo\0bar"), "parse (foo)"); $csv->escape_char ("\\"); ok (!$csv->parse ("foo,foo\0bar"), "parse (foo)"); $csv->binary (1); ok ( $csv->parse ("foo,foo\0bar"), "parse (foo)"); # Attribute aliasses ok ($csv = Text::CSV->new ({ quote_always => 1, verbose_diag => 1})); is ($csv->always_quote, 1, "always_quote = quote_always"); is ($csv->diag_verbose, 1, "diag_verbose = verbose_diag"); ok ($csv = Text::CSV->new ({ escape_char => undef }), "undef escape aliases"); is ($csv->escape_char, undef, "escape_char is undef"); ok ($csv = Text::CSV->new ({ quote => undef }), "undef quote aliases"); is ($csv->quote_char, undef, "quote_char is undef"); is ($csv->quote, undef, "quote is undef"); # Some forbidden combinations foreach my $ws (" ", "\t") { ok ($csv = Text::CSV->new ({ escape_char => $ws }), "New blank escape"); eval { ok ($csv->allow_whitespace (1), "Allow ws") }; is (($csv->error_diag)[0], 1002, "Wrong combo"); ok ($csv = Text::CSV->new ({ quote_char => $ws }), "New blank quote"); eval { ok ($csv->allow_whitespace (1), "Allow ws") }; is (($csv->error_diag)[0], 1002, "Wrong combo"); ok ($csv = Text::CSV->new ({ allow_whitespace => 1 }), "New ws 1"); eval { ok ($csv->escape_char ($ws), "esc") }; is (($csv->error_diag)[0], 1002, "Wrong combo"); ok ($csv = Text::CSV->new ({ allow_whitespace => 1 }), "New ws 1"); eval { ok ($csv->quote_char ($ws), "esc") }; is (($csv->error_diag)[0], 1002, "Wrong combo"); } foreach my $esc (undef, "", " ", "\t", "!!!!!!") { foreach my $quo (undef, "", " ", "\t", "!!!!!!") { defined $esc && $esc =~ m/[ \t]/ or defined $quo && $quo =~ m/[ \t]/ or next; my $wc = join " " => map { !defined $_ ? "" : $_ eq "" ? "" : $_ eq " " ? "" : $_ eq "\t" ? "" : $_ } "esc:", $esc, "quo:", $quo; eval { $csv = Text::CSV->new ({ escape => $esc, quote => $quo, allow_whitespace => 1, }) }; like ((Text::CSV::error_diag)[1], qr{^INI - allow_whitespace}, "Wrong combo - error message: $wc"); is ((Text::CSV::error_diag)[0], 1002, "Wrong combo - numeric error: $wc"); } } # Test 1003 in constructor foreach my $x ("\r", "\n", "\r\n", "x\n", "\rx") { foreach my $attr (qw( sep_char quote_char escape_char )) { #ok (1, "attr: $attr => ", $x =~ s/\n/\\n/gr =~ s/\r/\\r/gr); eval { $csv = Text::CSV->new ({ $attr => $x }) }; is ((Text::CSV::error_diag)[0], 1003, "eol in $attr"); } } # Test 1003 in methods foreach my $attr (qw( sep_char quote_char escape_char )) { ok ($csv = Text::CSV->new, "New"); eval { ok ($csv->$attr ("\n"), "$attr => \\n") }; is (($csv->error_diag)[0], 1003, "not allowed"); } # Too long attr (max 16) $csv = Text::CSV->new ({ quote => "'" }); my $xl = "X" x 32; eval { $csv->eol ($xl); }; is (($csv->error_diag)[0], 1005, "eol too long"); is ($csv->eol (), "", "eol unchanged"); eval { $csv->sep ($xl); }; is (($csv->error_diag)[0], 1006, "sep too long"); is ($csv->sep (), ",", "sep unchanged"); eval { $csv->quote ($xl); }; is (($csv->error_diag)[0], 1007, "quo too long"); is ($csv->quote (), "'", "quo unchanged"); eval { $csv = Text::CSV->new ({ eol => $xl }); }; is ($csv, undef, "new with EOL too long"); is ((Text::CSV::error_diag)[0], 1005, "error set"); eval { $csv = Text::CSV->new ({ sep => $xl }); }; is ($csv, undef, "new with SEP too long"); is ((Text::CSV::error_diag)[0], 1006, "error set"); eval { $csv = Text::CSV->new ({ quote => $xl }); }; is ($csv, undef, "new with QUO too long"); is ((Text::CSV::error_diag)[0], 1007, "error set"); # And test erroneous calls is (Text::CSV::new (0), undef, "new () as function"); is (Text::CSV::error_diag (), "usage: my \$csv = $Backend->new ([{ option => value, ... }]);", "Generic usage () message"); is (Text::CSV->new ({ oel => "" }), undef, "typo in attr"); is (Text::CSV::error_diag (), "INI - Unknown attribute 'oel'", "Unsupported attr"); is (Text::CSV->new ({ _STATUS => "" }), undef, "private attr"); is (Text::CSV::error_diag (), "INI - Unknown attribute '_STATUS'", "Unsupported private attr"); foreach my $arg (undef, 0, "", " ", 1, [], [ 0 ], *STDOUT) { is (Text::CSV->new ($arg), undef, "Illegal type for first arg"); is ((Text::CSV::error_diag)[0], 1000, "Should be a hashref - numeric error"); } my $attr = [ sort qw( eol sep_char sep quote_char quote escape_char binary decode_utf8 auto_diag diag_verbose blank_is_undef empty_is_undef allow_whitespace allow_loose_quotes allow_loose_escapes allow_unquoted_escape always_quote quote_space quote_empty quote_binary escape_null keep_meta_info verbatim strict strict_eol skip_empty_rows formula undef_str comment_str types callbacks ENCODING )]; is_deeply ([ Text::CSV::known_attributes () ], $attr, "Known attributes (function)"); is_deeply ([ Text::CSV->known_attributes () ], $attr, "Known attributes (class method)"); is_deeply ([ Text::CSV->new->known_attributes () ], $attr, "Known attributes (method)"); 1; Text-CSV-2.06/t/71_strict.t0000644000175100017510000001741614760113543015446 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More tests => 75; #use Test::More "no_plan"; my %err; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; require_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; open my $fh, "<", "lib/Text/CSV_PP.pm" or die "Cannot read error messages from PP\n"; while (<$fh>) { m/^ ([0-9]{4}) => "([^"]+)",/ and $err{$1} = $2; } close $fh; } my $tfn = "_80test.csv"; END { -f $tfn and unlink $tfn; } $| = 1; my $csv = Text::CSV->new (); { my $csv = Text::CSV->new ({ strict => 1 }); ok ($csv->parse ("1,2,3"), "Set strict to 3 columns"); ok ($csv->parse ("a,b,c"), "3 columns should be correct"); is ($csv->parse ("3,4"), 0, "Not enough columns"); is (0 + $csv->error_diag, 2014, "Error set correctly"); } { my $csv = Text::CSV->new ({ strict => 1 }); ok ($csv->parse ("1,2,3"), "Set strict to 3 columns"); is ($csv->parse ("3,4,5,6"), 0, "Too many columns"); is (0 + $csv->error_diag, 2014, "Error set correctly"); } { my $csv = Text::CSV->new ({ strict => 1 }); open my $fh, ">", $tfn or die "$tfn: $!\n"; ok ($csv->say ($fh, [ 1, 2, 3 ]), "Write line 1"); ok ($csv->say ($fh, [ 1, 2, 3 ]), "Write line 2"); close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; ok ((my $r = $csv->getline ($fh)), "Get line 1 under strict"); ok (( $r = $csv->getline ($fh)), "Get line 2 under strict"); is ($csv->getline ($fh), undef, "EOF under strict"); is (0 + $csv->error_diag, 2012, "Error is 2012 instead of 2014"); ok ($csv->eof, "EOF is set"); close $fh; } { my $csv = Text::CSV->new ({ strict => 1 }); open my $fh, ">", $tfn or die "$tfn: $!\n"; ok ($csv->say ($fh, [ 1, 2, 3 ]), "Write line 1"); ok ($csv->print ($fh, [ 1, 2, 3 ]), "Write line 2 no newline"); close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; ok ((my $r = $csv->getline ($fh)), "Get line 1 under strict"); ok (( $r = $csv->getline ($fh)), "Get line 2 under strict no newline"); is ($csv->getline ($fh), undef, "EOF under strict"); is (0 + $csv->error_diag, 2012, "Error is 2012 instead of 2014"); ok ($csv->eof, "EOF is set"); close $fh; } { my $csv = Text::CSV->new (); open my $fh, ">", $tfn or die "$tfn: $!\n"; ok ($csv->say ($fh, [ 1 .. 3 ]), "Write line 1 (headers)"); ok ($csv->say ($fh, [ 1 .. 4 ]), "Write line 2 (data)"); close $fh; my $aoh = Text::CSV::csv (in => $tfn, headers => "auto"); is_deeply ($aoh, [{ 1 => 1, 2 => 2, 3 => 3 }], "Column dropped"); my @e; eval { local $SIG{__WARN__} = sub { push @e => @_ }; $aoh = Text::CSV::csv (in => $tfn, headers => "auto", strict => 1); }; is_deeply ($aoh, [], "Fail under strict"); is (scalar @e, 1, "Got error"); like ($e[0], qr{ 2014 }, "Error 2014"); open $fh, ">", $tfn or die "$tfn: $!\n"; ok ($csv->say ($fh, [ 1 .. 4 ]), "Write line 1 (headers)"); ok ($csv->say ($fh, [ 1 .. 3 ]), "Write line 2 (data)"); close $fh; $aoh = Text::CSV::csv (in => $tfn, headers => "auto"); is_deeply ($aoh, [{ 1 => 1, 2 => 2, 3 => 3, 4 => undef }], "Column added"); @e = (); eval { local $SIG{__WARN__} = sub { push @e => @_ }; $aoh = Text::CSV::csv (in => $tfn, headers => "auto", strict => 1); }; is_deeply ($aoh, [], "Fail under strict"); is (scalar @e, 1, "Got error"); like ($e[0], qr{ 2014 }, "Error 2014"); } foreach my $strict (0, 1) { my $csv = Text::CSV->new ({ binary => 1, comment_str => "#", eol => "\n", escape_char => '"', quote_char => '"', sep_char => "|", strict => $strict, }); my $status = $csv->parse ('a|b|"d"'); is (0 + $csv->error_diag, 0, "No fail under strict = $strict"); $status = $csv->parse ('a|b|c"d"e'); # Loose unescaped quote is (0 + $csv->error_diag, 2034, "Previous error still actual"); } open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh <<"EOC"; 1,foo 2,bar,fail 3,baz 4 5,eox EOC close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; my @rpt; $csv = Text::CSV->new ({ strict => 1, auto_diag => 1 }); $csv->callbacks (error => sub { my ($err, $msg, $pos, $recno, $fldno) = @_; if ($err == 2014) { push @rpt => [ $recno, $fldno, $pos ]; $csv->SetDiag (0); } }); is_deeply ([ $csv->getline_all ($fh), @rpt ], [[[ 1, "foo" ], [ 2, "bar", "fail" ], [ 3, "baz" ], [ 4 ], [ 5, "eox" ]], [ 2, 3, 12 ], [ 4, 1, 3 ]], "Can catch strict 2014 with \$csv"); close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; @rpt = (); $csv = Text::CSV->new ({ strict => 1, auto_diag => 1, callbacks => { error => sub { my ($err, $msg, $pos, $recno, $fldno) = @_; if ($err == 2014) { push @rpt => [ $recno, $fldno, $pos ]; Text::CSV->SetDiag (0); } }}}); is_deeply ([ $csv->getline_all ($fh), @rpt ], [[[ 1, "foo" ], [ 2, "bar", "fail" ], [ 3, "baz" ], [ 4 ], [ 5, "eox" ]], [ 2, 3, 12 ], [ 4, 1, 3 ]], "Can catch strict 2014 with class"); close $fh; # Under strcict, fail un not enough fields. # Under non-strict expect the value of the previous record foreach my $test ( [ "a,b,c\n" . "d,e,f\n". "g,h\n". "i,j,k\n", "a,b,c\n" . "d,e,f\n". "g,h,f\n". "i,j,k\n", 2, 5 ], [ "a,b,c\n" . "d,e,f\n". "g,h\n" , "a,b,c\n" . "d,e,f\n". "g,h,f\n" , 2, 5 ], [ "a,b,c\n" . "g,h\n". "i,j,k\n", "a,b,c\n" . "g,h,c\n". "i,j,k\n", 1, 5 ], [ "a,b\n" . "d,e,f\n". "g,h\n". "i,j,k\n", "a,b,*\n" . "d,e,f\n". "g,h,f\n". "i,j,k\n", 1, 5 ], ) { my ($dta, $dta0, $err_line, $pos) = @$test; open $fh, ">", $tfn or die "$tfn: $!\n"; print $fh $dta; close $fh; my $expect = [ map {[ split m/,/ => $_ ]} grep m/\S/ => split "\n" => $dta0 ]; foreach my $strict (0, 1) { open $fh, "<", $tfn or die "$tfn: $!\n"; my $csv = Text::CSV->new ({ strict => $strict }); my ($r1, $r2, $r3) = ("-", "+", "*"); $csv->bind_columns (\($r1, $r2, $r3)); my @out; eval { while ($csv->getline ($fh)) { push @out => [ $r1, $r2, $r3 ]; } }; close $fh; my @err = $csv->error_diag; if ($strict) { is ($err[0], 2014, "ENF"); splice @$expect, $err_line; } else { is ($err[0], 2012, "EOF"); } is_deeply (\@out, $expect, "Bound + strict = $strict"); } } { ok (my $csv = Text::CSV->new ({ strict => 1 }), "Issue#58 data first"); ok ($csv->column_names (qw( A B C )), "Expect 3 colums"); is_deeply ($csv->getline_hr (*DATA), { A => 1, B => 2, C => 42 }, "Stream OK"); ok ($csv->parse ("1,2,42"), "Parse"); is_deeply ([ $csv->fields ], [ 1, 2, 42 ], "Parse OK"); is ($csv->parse ("2,42"), 0, "Parse not enough"); my @err = $csv->error_diag; # error-code, str, pos, rec, fld is ($err[0], 2014, "Error 2014"); is ($err[4], 2, "Just got 2"); } { ok (my $csv = Text::CSV->new ({ strict => 1 }), "Issue#58 no data first"); ok ($csv->column_names (qw( A B C )), "Expect 3 colums"); is ($csv->parse ("2,42"), 0, "Parse not enough"); my @err = $csv->error_diag; # error-code, str, pos, rec, fld is ($err[0], 2014, "Error 2014"); is ($err[4], 2, "Just got 2"); } { ok (my $csv = Text::CSV->new ({ strict => 1 }), "Issue#62 no data first"); my $tf = "issue-62-$$.csv"; END { -e $tf and unlink $tf } open my $fh, ">", $tf; print $fh "A,B\n1,2\n"; close $fh; open $fh, "<", $tf; ok (my @col = @{$csv->getline ($fh)}, "Get header"); my $val = {}; ok ($csv->bind_columns (\@{$val}{@col}), "Bind columns"); ok ($csv->getline ($fh), "Values into bound hash entries"); my @err = $csv->error_diag; # error-code, str, pos, rec, fld is ($err[0], 0, "No error 2014"); is_deeply ($val, { A => 1, B => 2 }, "Content"); close $fh; unlink $tf; } __END__ 1,2,42 Text-CSV-2.06/t/16_import.t0000644000175100017510000000464614760113543015450 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More tests => 41; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", qw( :CONSTANTS PV IV NV ); plan skip_all => "Cannot load Text::CSV" if $@; } is ( PV, 0, "Type PV"); is ( IV, 1, "Type IV"); is ( NV, 2, "Type NV"); is ( PV (), 0, "Type PV f"); is ( IV (), 1, "Type IV f"); is ( NV (), 2, "Type NV f"); is (Text::CSV::PV, 0, "Type T:C:PV"); is (Text::CSV::IV, 1, "Type T:C:IV"); is (Text::CSV::NV, 2, "Type T:C:NV"); is (Text::CSV::PV (), 0, "Type T:C:PV f"); is (Text::CSV::IV (), 1, "Type T:C:IV f"); is (Text::CSV::NV (), 2, "Type T:C:NV f"); is ( CSV_TYPE_PV, 0, "Type CT_PV"); is ( CSV_TYPE_IV, 1, "Type CT_IV"); is ( CSV_TYPE_NV, 2, "Type CT_NV"); is ( CSV_TYPE_PV (), 0, "Type CT_PV f"); is ( CSV_TYPE_IV (), 1, "Type CT_IV f"); is ( CSV_TYPE_NV (), 2, "Type CT_NV f"); is (Text::CSV::CSV_TYPE_PV, 0, "Type T:C:CT_PV"); is (Text::CSV::CSV_TYPE_IV, 1, "Type T:C:CT_IV"); is (Text::CSV::CSV_TYPE_NV, 2, "Type T:C:CT_NV"); is (Text::CSV::CSV_TYPE_PV (), 0, "Type T:C:CT_PV f"); is (Text::CSV::CSV_TYPE_IV (), 1, "Type T:C:CT_IV f"); is (Text::CSV::CSV_TYPE_NV (), 2, "Type T:C:CT_NV f"); is ( CSV_FLAGS_IS_QUOTED, 1, "is_Q"); is ( CSV_FLAGS_IS_BINARY, 2, "is_B"); is ( CSV_FLAGS_ERROR_IN_FIELD, 4, "is_E"); is ( CSV_FLAGS_IS_MISSING, 16, "is_M"); is ( CSV_FLAGS_IS_QUOTED (), 1, "is_Q f"); is ( CSV_FLAGS_IS_BINARY (), 2, "is_B f"); is ( CSV_FLAGS_ERROR_IN_FIELD (), 4, "is_E f"); is ( CSV_FLAGS_IS_MISSING (), 16, "is_M f"); is (Text::CSV::CSV_FLAGS_IS_QUOTED, 1, "is_Q"); is (Text::CSV::CSV_FLAGS_IS_BINARY, 2, "is_B"); is (Text::CSV::CSV_FLAGS_ERROR_IN_FIELD, 4, "is_E"); is (Text::CSV::CSV_FLAGS_IS_MISSING, 16, "is_M"); is (Text::CSV::CSV_FLAGS_IS_QUOTED (), 1, "T:C:is_Q f"); is (Text::CSV::CSV_FLAGS_IS_BINARY (), 2, "T:C:is_B f"); is (Text::CSV::CSV_FLAGS_ERROR_IN_FIELD (), 4, "T:C:is_E f"); is (Text::CSV::CSV_FLAGS_IS_MISSING (), 16, "T:C:is_M f"); Text-CSV-2.06/t/fields_containing_0.t0000644000175100017510000000443714600712237017522 0ustar ishigakiishigaki#!/usr/bin/perl =head1 DESCRIPTION This is a test program that succeeds with Text::CSV_PP and fails with Text::CSV_XS. The Text::CSV_XS behaviour is the correct one. =head1 CREDITS AND LICENSE The sample data (now anonymised) and a test program were contributed by blue_sky on Freenode’s #perl channel as part of a problem report with Text::CSV_PP based on the Text::CSV documentation. License is open source and compatible with the license of Text::CSV. Converted into a test program by Shlomi Fish ( L ) , while disclaiming all explicit or implicit copyright ownership on the modifications. ==head1 MODIFICATION modified by makamaka for old perl. =cut #use warnings; $^W = 1; use strict; use Test::More tests => 4; my $FALSE = 0; # my $USE_XS = $ENV{'USE_TEXT_CSV_XS'}; my $USE_XS = $FALSE; use Text::CSV_PP; use Data::Dumper qw(Dumper); END { unlink '_fc0_test.csv'; } if ($USE_XS) { require Text::CSV_XS; } { my $csv_text = <<'EOF'; "DIVISION CODE", "DIVISION DESCRIPTION", "CUSTOMER CODE", "CUSTOMER NAME", "SHORT NAME", "ADDRESS LINE 1", "ADDRESS LINE 2", "ADDRESS LINE 3", "TOWN", "COUNTY", "POST CODE", "COUNTRY", "GRID REF", "TELEPHONE", "AGENT CODE", "YEAR TO DATE SALES" "1", "UK", "Lambda", "Gambda Noo", "Foo", "Quad", "Rectum", "", "Eingoon", "Land", "Simplex", "", "", "099 999", "", 0.00 EOF # open my $IF, "<", \$csv_text; my $IF; open $IF, ">_fc0_test.csv" or die "_fc0_test.csv: $!"; print $IF $csv_text; close $IF; open $IF, "<_fc0_test.csv" or die "_fc0_test.csv: $!"; my $csv = ($USE_XS ? "Text::CSV_XS" : "Text::CSV_PP")->new({ allow_whitespace => 1, allow_loose_escapes => 1, }) or die "Cannot use CSV: ".Text::CSV->error_diag(); $csv->column_names( $csv->getline($IF) ); { my $first_line = $csv->getline_hr($IF); # TEST is ($first_line->{'POST CODE'}, 'Simplex', "First line POST CODE" ); # TEST is ($first_line->{'COUNTRY'}, '', "First line COUNTRY", ); # TEST is ($first_line->{'GRID REF'}, '', "First line GRID REF", ); # TEST is ($first_line->{'TELEPHONE'}, '099 999', "First line TELEPHONE", ); } close($IF); } Text-CSV-2.06/t/80_diag.t0000644000175100017510000002743614760113543015045 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More tests => 316; #use Test::More "no_plan"; my %err; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; require_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; open my $fh, "<", "lib/Text/CSV_PP.pm" or die "Cannot read error messages from PP\n"; while (<$fh>) { m/^\s+([0-9]{4}) => "([^"]+)"/ and $err{$1} = $2; } close $fh; } my $tfn = "_80test.csv"; END { -f $tfn and unlink $tfn; } $| = 1; my $csv = Text::CSV->new (); is (Text::CSV::error_diag (), "", "Last failure for new () - OK"); is_deeply ([ $csv->error_diag ], [ 0, "", 0, 0, 0, 0 ], "OK in list context"); sub parse_err { my ($n_err, $p_err, $r_err, $f_err, $str) = @_; my $s_err = $err{$n_err}; my $STR = _readable ($str); is ($csv->parse ($str), 0, "$n_err - Err for parse ('$STR')"); is ($csv->error_diag () + 0, $n_err, "$n_err - Diag in numerical context"); is ($csv->error_diag (), $s_err, "$n_err - Diag in string context"); my ($c_diag, $s_diag, $p_diag, $r_diag, $f_diag) = $csv->error_diag (); is ($c_diag, $n_err, "$n_err - Num diag in list context"); is ($s_diag, $s_err, "$n_err - Str diag in list context"); is ($p_diag, $p_err, "$n_err - Pos diag in list context"); is ($r_diag, $r_err, "$n_err - Rec diag in list context"); is ($f_diag, $f_err, "$n_err - Fld diag in list context"); } # parse_err parse_err 2023, 19, 1, 2, qq{2023,",2008-04-05,"Foo, Bar",\n}; # " $csv = Text::CSV->new ({ escape_char => "+", eol => "\n" }); is ($csv->error_diag (), "", "No errors yet"); parse_err 2010, 3, 1, 1, qq{"x"\r}; parse_err 2011, 4, 2, 1, qq{"x"x}; parse_err 2021, 2, 3, 1, qq{"\n"}; parse_err 2022, 2, 4, 1, qq{"\r"}; parse_err 2025, 2, 5, 1, qq{"+ "}; parse_err 2026, 2, 6, 1, qq{"\0 "}; parse_err 2027, 1, 7, 1, '"'; parse_err 2031, 1, 8, 1, qq{\r }; parse_err 2032, 2, 9, 1, qq{ \r}; parse_err 2034, 4, 10, 2, qq{1, "bar",2}; parse_err 2037, 1, 11, 1, qq{\0 }; { my @warn; local $SIG{__WARN__} = sub { push @warn => @_ }; $csv->error_diag (); ok (@warn == 1, "Got error message"); like ($warn[0], qr{^# CSV_(?:PP|XS) ERROR: 2037 - EIF}, "error content"); } is ($csv->eof, "", "No EOF"); $csv->SetDiag (2012); is ($csv->eof, 1, "EOF caused by 2012"); is (Text::CSV->new ({ ecs_char => ":" }), undef, "Unsupported option"); { my @warn; local $SIG{__WARN__} = sub { push @warn => @_ }; Text::CSV::error_diag (); ok (@warn == 1, "Error_diag in void context ::"); like ($warn[0], qr{^# CSV_(?:PP|XS) ERROR: 1000 - INI}, "error content"); } { my @warn; local $SIG{__WARN__} = sub { push @warn => @_ }; Text::CSV->error_diag (); ok (@warn == 1, "Error_diag in void context ->"); like ($warn[0], qr{^# CSV_(?:PP|XS) ERROR: 1000 - INI}, "error content"); } { my @warn; local $SIG{__WARN__} = sub { push @warn => @_ }; is (Text::CSV->new ({ auto_diag => 0, ecs_char => ":" }), undef, "Unsupported option"); ok (@warn == 0, "Error_diag in from new ({ auto_diag => 0})"); } { my @warn; local $SIG{__WARN__} = sub { push @warn => @_ }; is (Text::CSV->new ({ auto_diag => 1, ecs_char => ":" }), undef, "Unsupported option"); ok (@warn == 1, "Error_diag in from new ({ auto_diag => 1})"); like ($warn[0], qr{^# CSV_(?:PP|XS) ERROR: 1000 - INI}, "error content"); } is (Text::CSV::error_diag (), "INI - Unknown attribute 'ecs_char'", "Last failure for new () - FAIL"); is (Text::CSV->error_diag (), "INI - Unknown attribute 'ecs_char'", "Last failure for new () - FAIL"); is (Text::CSV::error_diag (bless {}, "Foo"), "INI - Unknown attribute 'ecs_char'", "Last failure for new () - FAIL"); $csv->SetDiag (1000); is (0 + $csv->error_diag (), 1000, "Set error NUM"); is ( $csv->error_diag (), "INI - constructor failed","Set error STR"); $csv->SetDiag (0); is (0 + $csv->error_diag (), 0, "Reset error NUM"); is ( $csv->error_diag (), "", "Reset error STR"); ok (1, "Test auto_diag"); $csv = Text::CSV->new ({ auto_diag => 1 }); { my @warn; local $SIG{__WARN__} = sub { push @warn => @_ }; is ($csv->{_RECNO}, 0, "No records read yet"); is ($csv->parse ('"","'), 0, "1 - bad parse"); ok (@warn == 1, "1 - One error"); like ($warn[0], qr '^# CSV_(?:PP|XS) ERROR: 2027 -', "1 - error message"); is ($csv->{_RECNO}, 1, "One record read"); } { my @warn; local $SIG{__WARN__} = sub { push @warn => @_ }; is ($csv->diag_verbose (3), 3, "Set diag_verbose"); is ($csv->parse ('"","'), 0, "1 - bad parse"); ok (@warn == 1, "1 - One error"); @warn = split m/\n/ => $warn[0]; ok (@warn == 3, "1 - error plus two lines"); like ($warn[0], qr '^# CSV_(?:PP|XS) ERROR: 2027 -', "1 - error message"); like ($warn[1], qr '^"","', "1 - input line"); like ($warn[2], qr '^ \^', "1 - position indicator"); is ($csv->{_RECNO}, 2, "Another record read"); } { ok ($csv->{auto_diag} = 2, "auto_diag = 2 to die"); eval { $csv->parse ('"","') }; like ($@, qr '^# CSV_(?:PP|XS) ERROR: 2027 -', "2 - error message"); } { my @warn; local $SIG{__WARN__} = sub { push @warn => @_ }; # Invalid error_input calls is (Text::CSV::error_input (undef), undef, "Bad error_input call"); is (Text::CSV::error_input (""), undef, "Bad error_input call"); is (Text::CSV::error_input ([]), undef, "Bad error_input call"); is (Text::CSV->error_input, undef, "Bad error_input call"); ok (my $csv = Text::CSV->new (), "new for cache diag"); $csv->_cache_diag (); ok (@warn == 1, "Got warn"); is ($warn[0], "CACHE: invalid\n", "Uninitialized cache"); @warn = (); ok ($csv->parse ("1"), "parse"); # initialize cache $csv->_cache_set (987, 10); ok (@warn == 1, "Got warn"); is ($warn[0], "Unknown cache index 987 ignored\n", "Ignore bad cache calls"); is ($csv->parse ('"'), 0, "Bad parse"); is ($csv->error_input, '"', "Error input"); ok ($csv->_cache_set (34, 0), "Reset error input (dangerous!)"); is ($csv->error_input, '"', "Error input not reset"); } { my $csv = Text::CSV->new (); ok ($csv->parse (q{1,"abc"}), "Valid parse"); is ($csv->error_input (), undef, "Undefined error_input"); is ($csv->{_ERROR_INPUT}, undef, "Undefined error_input"); } foreach my $spec ( undef, # No spec at all "", # No spec at all "row=0", # row > 0 "col=0", # col > 0 "cell=0", # cell = r,c "cell=0,0", # TL col > 0 "cell=1,0", # TL row > 0 "cell=1,1;0,1", # BR col > 0 "cell=1,1;1,0", # BR row > 0 "row=*", # * only after n- "col=3-1", # to >= from "cell=4,1;1", # cell has no ; "cell=3,3-2,1", # bottom-right should be right to and below top-left "cell=3,3-2,*", # bottom-right should be right to and below top-left "cell=3,3-4,1", # bottom-right should be right to and below top-left "cell=3,3-*,1", # bottom-right should be right to and below top-left "cell=1,*", # * in single cell col "cell=*,1", # * in single cell row "cell=*,*", # * in single cell row and column "cell=1,*-8,9", # * in cell range top-left cell col "cell=*,1-8,9", # * in cell range top-left cell row "cell=*,*-8,9", # * in cell range top-left cell row and column "row=/", # illegal character "col=4;row=3", # cannot combine rows and columns ) { my $csv = Text::CSV->new (); my $r; eval { $r = $csv->fragment (undef, $spec); }; is ($r, undef, "Cannot do fragment with bad RFC7111 spec"); my ($c_diag, $s_diag, $p_diag) = $csv->error_diag (); is ($c_diag, 2013, "Illegal RFC7111 spec"); is ($p_diag, 0, "Position"); } my $diag_file = "_$$.out"; open EH, ">&STDERR" or die "STDERR: $!\n"; open STDERR, ">", $diag_file or die "STDERR: $!\n"; # Trigger extra output for longer quote and sep is ($csv->sep ("--"), "--", "set longer sep"); is ($csv->quote ("^^"), "^^", "set longer quote"); ok ($csv->_cache_diag, "Cache debugging output"); close STDERR; open STDERR, ">&EH" or die "STDERR: $!\n"; open EH, "<", $diag_file or die "STDERR: $!\n"; is (scalar , "CACHE:\n", "Title"); while () { m/^\s+(?:tmp|bptr|cache)\b/ and next; like ($_, qr{^ \w+\s+[0-9a-f]+:(?:".*"|\s*[0-9]+)$}, "Content"); } close EH; unlink $diag_file; { my $err = ""; local $SIG{__DIE__} = sub { $err = shift; }; ok (my $csv = Text::CSV->new, "new"); eval { $csv->print_hr (*STDERR, {}); }; is (0 + $csv->error_diag, 3009, "Missing column names"); ok ($csv->column_names ("foo"), "set columns"); eval { $csv->print_hr (*STDERR, []); }; is (0 + $csv->error_diag, 3010, "print_hr needs a hashref"); } { my $csv = Text::CSV->new ({ sep_char => "=" }); eval { $csv->quote ("::::::::::::::"); }; is (0 + $csv->error_diag, 0, "Can set quote to something long"); eval { $csv->quote ("="); }; is (0 + $csv->error_diag, 1001, "Cannot set quote to current sep"); } { my $csv = Text::CSV->new ({ quote_char => "=" }); eval { $csv->sep ("::::::::::::::"); }; is (0 + $csv->error_diag, 0, "Can set sep to something long"); eval { $csv->sep (undef); }; is (0 + $csv->error_diag, 1008, "Can set sep to undef"); eval { $csv->sep (""); }; is (0 + $csv->error_diag, 1008, "Can set sep to empty"); eval { $csv->sep ("="); }; is (0 + $csv->error_diag, 1001, "Cannot set sep to current sep"); } { my $csv = Text::CSV->new; eval { $csv->header (undef, "foo"); }; is (0 + $csv->error_diag, 1014, "Cannot read header from undefined source"); eval { $csv->header (*STDIN, "foo"); }; like ($@, qr/^usage:/, "Illegal header call"); } { my $csv = Text::CSV->new; foreach my $arg ([], sub {}, Text::CSV->new, {}) { eval { $csv->parse ($arg) }; my @diag = $csv->error_diag; is ($diag[0], 1500, "Invalid parameters (code)"); like ($diag[1], qr{^PRM - Invalid/unsupported argument}, "Invalid parameters (msg)"); } } SKIP: { $] < 5.008 and skip qq{$] does not support ScalarIO}, 24; foreach my $key ({}, sub {}, []) { my $csv = Text::CSV->new; my $x = eval { $csv->csv (in => \"a,b", key => $key) }; is ($x, undef, "Invalid key"); my @diag = $csv->error_diag; is ($diag[0], 1501, "Invalid key type"); } { my $csv = Text::CSV->new; my $x = eval { $csv->csv (in => \"a,b", value => "b") }; is ($x, undef, "Value without key"); my @diag = $csv->error_diag; is ($diag[0], 1502, "No key"); } foreach my $val ({}, sub {}, []) { my $csv = Text::CSV->new; my $x = eval { $csv->csv (in => \"a,b", key => "a", value => $val) }; is ($x, undef, "Invalid value"); my @diag = $csv->error_diag; is ($diag[0], 1503, "Invalid value type"); } foreach my $ser ("die", 4) { ok (my $csv = Text::CSV->new ({ skip_empty_rows => $ser }), "New CSV for SER $ser"); is (eval { $csv->csv (in => \"\n") }, undef, "Parse empty line for SER $ser"); like ($@, qr{^Empty row}, "Message"); my @diag = $csv->error_diag; is ($diag[0], 2015, "Empty row"); like ($diag[1], qr{^ERW - Empty row}, "Error description"); } } # Issue 19: auto_diag > 1 does not die if ->header () is used if ($] >= 5.008002) { open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh qq{foo,bar,baz\n}; print $fh qq{a,xxx,1\n}; print $fh qq{b,"xx"xx", 2"\n}; print $fh qq{c, foo , 3\n}; close $fh; foreach my $h (0, 1) { $@ = ""; my @row; my $ok = eval { open $fh, "<", $tfn or die "$tfn: $!\n"; my $csv = Text::CSV->new ({ auto_diag => 2 }); $h and push @row => [ $csv->header ($fh) ]; while (my $row = $csv->getline ($fh)) { push @row => $row } close $fh; 1; }; is_deeply (\@row, [[qw(foo bar baz)],[qw(a xxx 1)]], "2 valid rows"); like ($@, qr '^# CSV_(?:PP|XS) ERROR: 2023 -', "3rd row dies error 2023"); } } else { ok (1, "Test skipped in this version of perl") for 1..4; } 1; Text-CSV-2.06/t/79_callbacks.t0000644000175100017510000001246214760113543016061 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More tests => 111; #use Test::More "no_plan"; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; require_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } $| = 1; my $csv; my $tfn = "_79test.csv"; END { -f $tfn and unlink $tfn; } # These tests are for the constructor { my $warn; local $SIG{__WARN__} = sub { $warn = shift; }; ok ($csv = Text::CSV->new ({ callbacks => undef }), "new"); is ($warn, undef, "no warn for undef"); is ($csv->callbacks, $warn = undef, "no callbacks for undef"); ok ($csv = Text::CSV->new ({ callbacks => 0 }), "new"); like ($warn, qr{: ignored\n}, "warn for 0"); is ($csv->callbacks, $warn = undef, "no callbacks for 0"); ok ($csv = Text::CSV->new ({ callbacks => 1 }), "new"); like ($warn, qr{: ignored\n}, "warn for 1"); is ($csv->callbacks, $warn = undef, "no callbacks for 1"); ok ($csv = Text::CSV->new ({ callbacks => \1 }), "new"); like ($warn, qr{: ignored\n}, "warn for \\1"); is ($csv->callbacks, $warn = undef, "no callbacks for \\1"); ok ($csv = Text::CSV->new ({ callbacks => "" }), "new"); like ($warn, qr{: ignored\n}, "warn for ''"); is ($csv->callbacks, $warn = undef, "no callbacks for ''"); ok ($csv = Text::CSV->new ({ callbacks => [] }), "new"); like ($warn, qr{: ignored\n}, "warn for []"); is ($csv->callbacks, $warn = undef, "no callbacks for []"); ok ($csv = Text::CSV->new ({ callbacks => sub {} }), "new"); like ($warn, qr{: ignored\n}, "warn for sub {}"); is ($csv->callbacks, $warn = undef, "no callbacks for sub {}"); } ok ($csv = Text::CSV->new (), "new"); is ($csv->callbacks, undef, "no callbacks"); ok ($csv->bind_columns (\my ($c, $s)), "bind"); ok ($csv->getline (*DATA), "parse ok"); is ($c, 1, "key"); is ($s, "foo", "value"); $s = "untouched"; ok ($csv->getline (*DATA), "parse bad"); is ($c, 1, "key"); is ($s, "untouched", "untouched"); ok ($csv->getline (*DATA), "parse bad"); is ($c, "foo", "key"); is ($s, "untouched", "untouched"); ok ($csv->getline (*DATA), "parse good"); is ($c, 2, "key"); is ($s, "bar", "value"); eval { is ($csv->getline (*DATA), undef,"parse bad"); }; my @diag = $csv->error_diag; is ($diag[0], 3006, "too many values"); # These tests are for the method foreach my $args ([""], [1], [[]], [sub{}], [1,2], [1,2,3], [undef,"error"], ["error",undef], ["%23bad",sub {}], ["error",sub{0;},undef,1], ["error",[]], ["error","error"], ["",sub{0;}], [sub{0;},0], [[],""]) { eval { $csv->callbacks (@$args); }; my @diag = $csv->error_diag; is ($diag[0], 1004, "invalid callbacks"); is ($csv->callbacks, undef, "not set"); } # These tests are for invalid arguments *inside* the hash foreach my $arg (undef, 0, 1, \1, "", [], $csv) { eval { $csv->callbacks ({ error => $arg }); }; my @diag = $csv->error_diag; is ($diag[0], 1004, "invalid callbacks"); is ($csv->callbacks, undef, "not set"); } ok ($csv->callbacks (bogus => sub { 0; }), "useless callback"); my $error = 3006; sub ignore { is ($_[0], $error, "Caught error $error"); $csv->SetDiag (0); # Ignore this error } # ignore my $idx = 1; ok ($csv->auto_diag (1), "set auto_diag"); my $callbacks = { error => \&ignore, after_parse => sub { my ($c, $av) = @_; # Just add a field push @$av, "NEW"; }, before_print => sub { my ($c, $av) = @_; # First field set to line number $av->[0] = $idx++; # Maximum 2 fields @{$av} > 2 and splice @{$av}, 2; # Minimum 2 fields @{$av} < 2 and push @{$av}, ""; }, }; is (ref $csv->callbacks ($callbacks), "HASH", "callbacks set"); ok ($csv->getline (*DATA), "parse ok"); is ($c, 1, "key"); is ($s, "foo", "value"); ok ($csv->getline (*DATA), "parse bad, skip 3006"); ok ($csv->getline (*DATA), "parse good"); is ($c, 2, "key"); is ($s, "bar", "value"); $csv->bind_columns (undef); ok (my $row = $csv->getline (*DATA), "get row"); is_deeply ($row, [ 1, 2, 3, "NEW" ], "fetch + value from hook"); $error = 2012; # EOF ok ($csv->getline (*DATA), "parse past eof"); ok ($csv->eol ("\n"), "eol for output"); open my $fh, ">", $tfn or die "$tfn: $!"; ok ($csv->print ($fh, [ 0, "foo" ]), "print OK"); ok ($csv->print ($fh, [ 0, "bar", 3 ]), "print too many"); ok ($csv->print ($fh, [ 0 ]), "print too few"); close $fh; open $fh, "<", $tfn or die "$tfn: $!"; is (do { local $/; <$fh> }, "1,foo\n2,bar\n3,\n", "Modified output"); close $fh; # Test the non-IO interface ok ($csv->parse ("10,blah,33\n"), "parse"); is_deeply ([ $csv->fields ], [ 10, "blah", 33, "NEW" ], "fields"); ok ($csv->combine (11, "fri", 22, 18), "combine - no hook"); is ($csv->string, qq{11,fri,22,18\n}, "string"); is ($csv->callbacks (undef), undef, "clear callbacks"); is_deeply (Text::CSV::csv (in => $tfn, callbacks => $callbacks), [[1,"foo","NEW"],[2,"bar","NEW"],[3,"","NEW"]], "using getline_all"); open $fh, ">", $tfn or die "$tfn: $!\n"; print $fh <<"EOC"; 1,foo 2,bar 3,baz 4,zoo EOC close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; $csv->callbacks (after_parse => sub { $_[1][0] eq 3 and return \"skip" }); is_deeply ($csv->getline_all ($fh), [[1,"foo"],[2,"bar"],[4,"zoo"]], "skip"); close $fh; __END__ 1,foo 1 foo 2,bar 3,baz,2 1,foo 3,baz,2 2,bar 1,2,3 Text-CSV-2.06/t/68_header.t0000644000175100017510000000330314760113543015362 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More; BEGIN { if ($] < 5.008001) { plan skip_all => "This test unit requires perl-5.8.1 or higher"; } else { plan tests => 32; } $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", "csv"; require "./t/util.pl"; } my $tfn = "_68test.csv"; END { unlink $tfn, "_$tfn"; } my @dta = ( [qw( foo bar zap )], [qw( mars venus pluto )], [qw( 1 2 3 )], ); my @dth = ( { foo => "mars", bar => "venus", zap => "pluto" }, { foo => 1, bar => 2, zap => 3 }, ); { open my $fh, ">", $tfn or die "$tfn: $!\n"; local $" = ","; print $fh "@$_\n" for @dta; close $fh; } is_deeply (csv (in => $tfn), \@dta, "csv ()"); is_deeply (csv (in => $tfn, bom => 1), \@dth, "csv (bom)"); is_deeply (csv (in => $tfn, headers => "auto"), \@dth, "csv (headers)"); is_deeply (csv (in => $tfn, bom => 1, headers => "auto"), \@dth, "csv (bom, headers)"); foreach my $arg ("", "bom", "auto", "bom, auto") { open my $fh, "<", $tfn or die "$tfn: $!\n"; my %attr; $arg =~ m/bom/ and $attr{bom} = 1; $arg =~ m/auto/ and $attr{headers} = "auto"; ok (my $csv = Text::CSV->new (), "New ($arg)"); is ($csv->record_number, 0, "start"); if ($arg) { is_deeply ([ $csv->header ($fh, \%attr) ], $dta[0], "Header") if $arg; is ($csv->record_number, 1, "first data-record"); is_deeply ($csv->getline_hr ($fh), $dth[$_], "getline $_") for 0..$#dth; } else { is_deeply ($csv->getline ($fh), $dta[$_], "getline $_") for 0..$#dta; } is ($csv->record_number, 3, "done"); close $fh; } Text-CSV-2.06/t/90_csv.t0000644000175100017510000003437214760113543014732 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Config; #use Test::More "no_plan"; use Test::More tests => 127; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", ("csv"); plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } my $tfn = "_90test.csv"; END { -f $tfn and unlink $tfn } my $data = "foo,bar,baz\n". "1,2,3\n". "2,a b,\n"; open FH, ">", $tfn or die "$tfn: $!"; print FH $data; close FH; my @hdr = qw( foo bar baz ); my $aoa = [ \@hdr, [ 1, 2, 3 ], [ 2, "a b", "" ], ]; my $aoh = [ { foo => 1, bar => 2, baz => 3 }, { foo => 2, bar => "a b", baz => "" }, ]; SKIP: for my $io ([ $tfn, "file" ], [ \*FH, "globref" ], [ *FH, "glob" ], [ \$data, "ScalarIO"] ) { $] < 5.008 && ref $io->[0] eq "SCALAR" and skip "No ScalarIO support for $]", 1; open FH, "<", $tfn or die "$tfn: $!\n"; is_deeply (csv ({ in => $io->[0] }), $aoa, "AOA $io->[1]"); close FH; } SKIP: for my $io ([ $tfn, "file" ], [ \*FH, "globref" ], [ *FH, "glob" ], [ \$data, "ScalarIO"] ) { $] < 5.008 && ref $io->[0] eq "SCALAR" and skip "No ScalarIO support for $]", 1; open FH, "<", $tfn or die "$tfn: $!\n"; is_deeply (csv (in => $io->[0], headers => "auto"), $aoh, "AOH $io->[1]"); close FH; } is_deeply (csv (in => $tfn, headers => { bar => "tender" }), [ { foo => 1, tender => 2, baz => 3 }, { foo => 2, tender => "a b", baz => "" }, ], "AOH with header map"); my @aoa = @{$aoa}[1,2]; is_deeply (csv (file => $tfn, headers => "skip"), \@aoa, "AOA skip"); is_deeply (csv (file => $tfn, fragment => "row=2-3"), \@aoa, "AOA fragment"); if ($] >= 5.008001) { my @hdr; ok (my $ref = csv (in => $tfn, bom => 1), "csv (-- not keeping header)"); is_deeply (\@hdr, [], "Should still be empty"); foreach my $alias (qw( keep_headers keep_column_names kh )) { @hdr = (); ok (my $ref = csv (in => $tfn, bom => 1, $alias => \@hdr), "csv ($alias => ...)"); is_deeply (\@hdr, [qw( foo bar baz )], "Headers kept for $alias"); } foreach my $alias (qw( keep_headers keep_column_names kh )) { @hdr = (); ok (my $ref = csv (in => $tfn, $alias => \@hdr), "csv ($alias => ... -- implied headers)"); is_deeply (\@hdr, [qw( foo bar baz )], "Headers kept for $alias"); } foreach my $alias (qw( internal true yes 1 )) { my $buf = ""; ok (my $ref = csv (in => $tfn, kh => $alias), "csv (kh => $alias)"); ok (csv (in => $ref, out => \$buf, kh => $alias, quote_space => 0, eol => "\n"), "get it back"); is ($buf, $data, "Headers kept for $alias"); } } else { ok (1, q{This perl cannot do scalar IO}) for 1..26; } if ($] >= 5.008001) { is_deeply (csv (in => $tfn, encoding => "utf-8", headers => ["a", "b", "c"], fragment => "row=2", sep_char => ","), [{ a => 1, b => 2, c => 3 }], "AOH headers fragment"); is_deeply (csv (in => $tfn, enc => "utf-8", headers => ["a", "b", "c"], fragment => "row=2", sep_char => ","), [{ a => 1, b => 2, c => 3 }], "AOH headers fragment"); } else { ok (1, q{This perl does not support open with "<:encoding(...)"}); ok (1, q{This perl does not support open with "<:encoding(...)"}); } ok (csv (in => $aoa, out => $tfn), "AOA out file"); is_deeply (csv (in => $tfn), $aoa, "AOA parse out"); ok (csv (in => $aoh, out => $tfn, headers => "auto"), "AOH out file"); is_deeply (csv (in => $tfn, headers => "auto"), $aoh, "AOH parse out"); if ($Config{usecperl} && $Config{usecperl} eq "define") { ok (1, "cperl has a different view on stable sorting of hash keys"); ok (1, "not doing this (silly) test"); } else { ok (csv (in => $aoh, out => $tfn, headers => "skip"), "AOH out file no header"); is_deeply (csv (in => $tfn, headers => [keys %{$aoh->[0]}]), $aoh, "AOH parse out no header"); } my $idx = 0; sub getrowa { return $aoa->[$idx++]; } sub getrowh { return $aoh->[$idx++]; } ok (csv (in => \&getrowa, file => $tfn), "out via file from CODE/AR"); is_deeply (csv (in => $tfn), $aoa, "data from CODE/AR"); $idx = 0; ok (csv (in => \&getrowh, out => $tfn, headers => \@hdr), "out from CODE/HR"); is_deeply (csv (in => $tfn, headers => "auto"), $aoh, "data from CODE/HR"); $idx = 0; ok (csv (in => \&getrowh, out => $tfn), "out from CODE/HR (auto headers)"); is_deeply (csv (in => $tfn, headers => "auto"), $aoh, "data from CODE/HR"); unlink $tfn; # Basic "key" checks SKIP: { $] < 5.008 and skip "No ScalarIO support for $]", 4; # Simple key is_deeply (csv (in => \"key,value\n1,2\n", key => "key"), { 1 => { key => 1, value => 2 }}, "key"); is_deeply (csv (in => \"1,2\n", key => "key", headers => [qw( key value )]), { 1 => { key => 1, value => 2 }}, "key"); # Combined key is_deeply (csv (in => \"a,b,value\n1,1,2\n", key => [ ":" => "a", "b" ]), { "1:1" => { a => 1, b => 1, value => 2 }}, "key list"); is_deeply (csv (in => \"2,3,2\n", key => [ ":" => "a", "b" ], headers => [qw( a b value )]), { "2:3" => { a => 2, b => 3, value => 2 }}, "key list"); } # Basic "value" checks SKIP: { $] < 5.008001 and skip "No ScalarIO support for 'value's in $]", 5; # Simple key simple value is_deeply (csv (in => \"key,value\n1,2\n", key => "key", value => "value"), { 1 => 2 }, "key:value"); is_deeply (csv (in => \"1,2\n", key => "key", headers => [qw( key value )], value => "value"), { 1 => 2 }, "key:value"); # Simple key combined value is_deeply (csv (in => \"key,v1,v2\n1,2,3\n", key => "key", value => [ "v1", "v2" ]), { 1 => { v1 => 2, v2 => 3 }}, "key:value"); # Combined key simple value is_deeply (csv (in => \"a,b,value\n1,1,2\n", key => [ ":" => "a", "b" ], value => "value"), { "1:1" => 2 }, "[key]:value"); # Combined key combined value is_deeply (csv (in => \"a,b,v1,v2\n1,1,2,2\n", key => [ ":" => "a", "b" ], value => [ "v1", "v2" ]), { "1:1" => { v1 => 2, v2 => 2 }}, "[key]:[value]"); } # Some "out" checks my $crnl; open my $fh, ">", $tfn or die "$tfn: $!\n"; csv (in => [{ a => 1 }], out => $fh); csv (in => [{ a => 1 }], out => $fh, headers => undef); csv (in => [{ a => 1 }], out => $fh, headers => "auto"); csv (in => [{ a => 1 }], out => $fh, headers => ["a"]); csv (in => [{ b => 1 }], out => $fh, headers => { b => "a" }); close $fh; { open $fh, "<", $tfn or die "$tfn: $!\n"; my $dta = do {local $/; <$fh>}; my @layers = eval { PerlIO::get_layers ($fh); }; close $fh; if (grep m/crlf/ => @layers) { $dta =~ s/\n/\r\n/g; $crnl++; } is ($dta, "a\r\n1\r\n" x 5, "AoH to out"); } # check internal defaults { my $ad = 1; sub check { my ($csv, $ar) = @_; is ($csv->auto_diag, $ad, "default auto_diag ($ad)"); is ($csv->binary, 1, "default binary"); is ($csv->eol, "\r\n", "default eol"); } # check # Note that 5.6.x writes to a *file* named SCALAR(0x50414A10) open my $fh, ">", \my $out or die "IO: $!\n"; csv (in => [[1,2]], out => $fh, on_in => \&check); # Check that I can overrule auto_diag $ad = 0; csv (in => [[1,2]], out => $fh, on_in => \&check, auto_diag => 0, ($] >= 5.008004 ? (encoding => "utf-8") : ())); } $] < 5.008 and unlink glob "SCALAR(*)"; # errors { my $err = ""; local $SIG{__DIE__} = sub { $err = shift; }; my $r = eval { csv (in => undef); }; is ($r, undef, "csv needs in or file"); like ($err, qr{^usage:}, "error"); $err = ""; $r = eval { csv (in => $tfn, key => [ ":" ], auto_diag => 0); }; $err =~ s{\s+at\s+\S+\s+line\s+\d+\.\r?\n?\Z}{}; is ($r, undef, "Fail call with key with not enough fields"); like ($err, qr{PRM.*unsupported type}, $err); $err = ""; $r = eval { csv (in => $tfn, key => { "fx" => 1 }, auto_diag => 0); }; $err =~ s{\s+at\s+\S+\s+line\s+\d+\.\r?\n?\Z}{}; is ($r, undef, "Fail call with unsupported key type"); like ($err, qr{PRM.*unsupported type}, $err); $err = ""; $r = eval { csv (in => $tfn, key => sub { "foo" }, auto_diag => 0); }; $err =~ s{\s+at\s+\S+\s+line\s+\d+\.\r?\n?\Z}{}; is ($r, undef, "Fail call with bad unsupported type"); like ($err, qr{PRM.*unsupported type}, $err); $err = ""; $r = eval { csv (in => $tfn, key => "xyz", auto_diag => 0); }; $err =~ s{\s+at\s+\S+\s+line\s+\d+\.\r?\n?\Z}{}; is ($r, undef, "Fail call with nonexisting key"); like ($err, qr{PRM.*xyz}, $err); $err = ""; $r = eval { csv (in => $tfn, key => [ "x" ], auto_diag => 0); }; $err =~ s{\s+at\s+\S+\s+line\s+\d+\.\r?\n?\Z}{}; is ($r, undef, "Fail call with no key in keylist"); like ($err, qr{PRM.*unsupported type}, $err); $err = ""; $r = eval { csv (in => $tfn, key => [ ":", "a", "xyz" ], auto_diag => 0); }; $err =~ s{\s+at\s+\S+\s+line\s+\d+\.\r?\n?\Z}{}; is ($r, undef, "Fail call with nonexisting key in keylist"); like ($err, qr{PRM.*xyz}, $err); $err = ""; local $SIG{__DIE__} = sub { $err = shift; }; local $SIG{__WARN__} = sub { $err = shift; }; foreach my $hr (42, "foo", \my %hr, sub { 42; }, *STDOUT) { $r = eval { csv (in => $tfn, kh => $hr, auto_diag => 0); }; $err =~ s{\s+at\s+\S+\s+line\s+\d+\.\r?\n?\Z}{}; is ($r, undef, "Fail call with bad keep_header type"); like ($err, qr{PRM.*unsupported type}, $err); $err = ""; } # $r = eval { csv (in => +{}, auto_diag => 0); }; # is ($r, undef, "Cannot read from hashref"); # like ($err, qr{No such file}i, "No such file or directory"); # undef $err; $r = eval { csv (in => undef, auto_diag => 0); }; $err =~ s{\s+at\s+\S+\s+line\s+\d+\.\r?\n?\Z}{}; is ($r, undef, "Cannot read from undef"); like ($err, qr{^usage}, "Remind them of correct syntax"); $err = ""; $r = eval { csv (in => "", auto_diag => 0); }; $err =~ s{\s+at\s+\S+\s+line\s+\d+\.\r?\n?\Z}{}; is ($r, undef, "Cannot read from empty"); like ($err, qr{^usage}, "Remind them of correct syntax"); $err = ""; my $fn = "./dev/foo/bar/\x99\x99/\x88\x88/". (join "\x99" => map { chr (128 + int rand 128) } 0..100).".csv"; $r = eval { csv (in => $fn, auto_diag => 0); }; $err =~ s{\s+at\s+\S+\s+line\s+\d+\.\r?\n?\Z}{}; is ($r, undef, "Cannot read from impossible file"); like ($err, qr{/foo/bar}, "No such file or directory"); $err = ""; $r = eval { csv (in => [[1,2]], out => $fn, auto_diag => 0); }; $err =~ s{\s+at\s+\S+\s+line\s+\d+\.\r?\n?\Z}{}; is ($r, undef, "Cannot write to impossible file"); like ($err, qr{/foo/bar}, "No such file or directory"); $err = ""; $r = eval { csv (); }; is ($r, undef, "Needs arguments"); like ($err, qr{^usage}i, "Don't know what to do"); $err = ""; my $x = sub { 42; }; $r = eval { csv (in => $tfn, out => \$x, auto_diag => 0); }; $err =~ s{\s+at\s+\S+\s+line\s+\d+\.\r?\n?\Z}{}; is ($r, undef, "Cannot write to subref"); like ($err, qr{Not a GLOB}i, "Not a GLOB"); $err = ""; SKIP: { $] < 5.008 and skip "$] does not support bom here", 2; $x = [[ 1, 2 ]]; # Add hashes to arrays $r = eval { csv (in => $tfn, out => $x, bom => 1); }; $err =~ s{\s+at\s+\S+\s+line\s+\d+\.\r?\n?\Z}{}; is ($r, undef, "Cannot add hashes to arrays"); like ($err, qr{type mismatch}, "HASH != ARRAY"); $err = ""; } $x = [{ a => 1, b => 2 }]; # Add arrays to hashes $r = eval { csv (in => $tfn, out => $x); }; $err =~ s{\s+at\s+\S+\s+line\s+\d+\.\r?\n?\Z}{}; is ($r, undef, "Cannot add arrays to hashes"); like ($err, qr{type mismatch}i, "ARRAY != HASH"); $err = ""; } eval { exists $Config{useperlio} && defined $Config{useperlio} && $] >= 5.008 && $Config{useperlio} eq "define" or skip "No scalar ref in this perl", 5; my $out = ""; open my $fh, ">", \$out or die "IO: $!\n"; ok (csv (in => [[ 1, 2, 3 ]], out => $fh), "out to fh to scalar ref"); is ($out, "1,2,3\r\n", "Scalar out"); $out = ""; ok (csv (in => [[ 1, 2, 3 ]], out => \$out), "out to scalar ref"); is ($out, "1,2,3\r\n", "Scalar out"); is_deeply (csv (in => \qq{1,"2 3"}, quo => undef, esc => undef), [["1", q{"2 3"}]], "quo => undef"); }; { my $csv = Text::CSV->new ({ binary => 1, auto_diag => 1 }); my $expect = [["a"],[1],["a"],[1],["a"],[1],["a"],[1],["a"],[1]]; is_deeply ($csv->csv (in => $tfn), $expect, "csv from object"); is_deeply (csv (in => $tfn, csv => $csv), $expect, "csv from attribute"); } { local *STDOUT; my $ofn = "_STDOUT.csv"; open STDOUT, ">", $ofn or die "$ofn: $!\n"; { my @w; local $SIG{__WARN__} = sub { push @w => @_ }; csv (in => $tfn, quote_always => 1, fragment => "row=1-2", on_in => sub { splice @{$_[1]}, 1; }, eol => "\n"); if ($crnl) { is (scalar @w, 0, "CRNL layer found"); } else { like ($w[0], qr/2016 - EOL/, "EOL mismatch"); } } close STDOUT; my $dta = do { local (@ARGV, $/) = $ofn; <> }; is ($dta, qq{"a"\n"1"\n}, "Chained csv call inherited attributes"); unlink $ofn; open STDOUT, ">", $ofn; csv (in => [[1,2]], out => *STDOUT, eol => "\n"); close STDOUT; $dta = do { local (@ARGV, $/) = $ofn; <> }; is ($dta, qq{1,2\n}, "out to *STDOUT"); unlink $ofn; open STDOUT, ">", $ofn; csv (in => [[1,2]], out => \*STDOUT, eol => "\n"); close STDOUT; $dta = do { local (@ARGV, $/) = $ofn; <> }; is ($dta, qq{1,2\n}, "out to \\*STDOUT"); unlink $ofn; open STDOUT, ">", $ofn; csv (in => []); close STDOUT; is (-s $ofn, 0, "No data results in an empty file"); unlink $ofn; SKIP: { $] <= 5.008 and skip qq{$] does not support ScalarIO}, 6; my $aoa = [[ 1, 2 ]]; is (csv (in => \"3,4", out => $aoa), $aoa, "return AOA"); is_deeply ($aoa, [[ 1, 2 ], [ 3, 4 ]], "Add to AOA"); my $aoh = [{ a => 1, b => 2 }]; is (csv (in => \"a,b\n3,4", out => $aoh, bom => 1), $aoh, "return AOH"); is_deeply ($aoa, [[ 1, 2 ], [ 3, 4 ]], "Add to AOH"); my $ref = { 1 => { a => 1, b => 2 }}; is (csv (in => \"a,b\n3,4", out => $ref, key => "a"), $ref, "return REF"); is_deeply ($ref, { 1 => { a => 1, b => 2}, 3 => { a => 3, b => 4}, }, "Add to keyed hash"); } SKIP: { $] <= 5.008003 and skip qq{$] does not support ">:crlf"}, 1; open STDOUT, ">", $ofn; binmode STDOUT, ":crlf"; csv (in => [[1,2]], out => \*STDOUT); close STDOUT; open my $oh, "<", $ofn or die "$ofn: $!\n"; binmode $oh; $dta = do { local $/; <$oh> }; is ($dta, qq{1,2\r\n}, "out to \\*STDOUT"); unlink $ofn; } } Text-CSV-2.06/t/20_file.t0000644000175100017510000001023014760113543015032 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; # use warnings; use Test::More tests => 109; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } $| = 1; $/ = "\n"; $\ = undef; my $tfn = "_20test.csv"; END { -f $tfn and unlink $tfn; } my $csv = Text::CSV->new (); my $UTF8 = ($ENV{LANG} || "C").($ENV{LC_ALL} || "C") =~ m/utf-?8/i ? 1 : 0; open FH, ">", $tfn or die "$tfn: $!"; ok (!$csv->print (*FH, ["abc", "def\007", "ghi"]), "print bad character"); close FH; for ( [ 1, 1, 1, '""' ], [ 2, 1, 1, '', '' ], [ 3, 1, 0, '', 'I said, "Hi!"', '' ], [ 4, 1, 0, '"', 'abc' ], [ 5, 1, 0, 'abc', '"' ], [ 6, 1, 1, 'abc', 'def', 'ghi' ], [ 7, 1, 1, "abc\tdef", 'ghi' ], [ 8, 1, 0, '"abc' ], [ 9, 1, 0, 'ab"c' ], [ 10, 1, 0, '"ab"c"' ], [ 11, 0, 0, qq("abc\nc") ], [ 12, 1, 1, q(","), ',' ], [ 13, 1, 0, qq("","I said,\t""Hi!""",""), '', qq(I said,\t"Hi!"), '' ], ) { my ($tst, $validp, $validg, @arg, $row) = @$_; open FH, ">", $tfn or die "$tfn: $!"; is ($csv->print (*FH, \@arg), $validp||"", "$tst - print ()"); close FH; open FH, ">", $tfn or die "$tfn: $!"; print FH join ",", @arg; close FH; open FH, "<", $tfn or die "$tfn: $!"; $row = $csv->getline (*FH); unless ($validg) { is ($row, undef, "$tst - false getline ()"); next; } ok ($row, "$tst - good getline ()"); $tst == 12 and @arg = (",", "", ""); foreach my $a (0 .. $#arg) { (my $exp = $arg[$a]) =~ s/^"(.*)"$/$1/; is ($row->[$a], $exp, "$tst - field $a"); } } unlink $tfn; # This test because of a problem with DBD::CSV ok (1, "Tests for DBD::CSV"); open FH, ">", $tfn or die "$tfn: $!"; $csv->binary (1); $csv->eol ("\r\n"); ok ($csv->print (*FH, [ "id", "name" ]), "Bad character"); ok ($csv->print (*FH, [ 1, "Alligator Descartes" ]), "Name 1"); ok ($csv->print (*FH, [ "3", "Jochen Wiedmann" ]), "Name 2"); ok ($csv->print (*FH, [ 2, "Tim Bunce" ]), "Name 3"); ok ($csv->print (*FH, [ " 4", "Andreas König" ]), "Name 4"); ok ($csv->print (*FH, [ 5 ]), "Name 5"); close FH; my $expected = <<"CONTENTS"; id,name\015 1,"Alligator Descartes"\015 3,"Jochen Wiedmann"\015 2,"Tim Bunce"\015 " 4","Andreas König"\015 5\015 CONTENTS open FH, "<", $tfn or die "$tfn: $!"; my $content = do { local $/; }; close FH; is ($content, $expected, "Content"); open FH, ">", $tfn or die "$tfn: $!"; print FH $content; close FH; open FH, "<", $tfn or die "$tfn: $!"; my $fields; print "# Retrieving data\n"; for (0 .. 5) { ok ($fields = $csv->getline (*FH), "Fetch field $_"); is ($csv->eof, "", "EOF"); print "# Row $_: $fields (@$fields)\n"; } is ($csv->getline (*FH), undef, "Fetch field 6"); is ($csv->eof, 1, "EOF"); # Edge cases for ([ 1, 1, 0, "\n" ], [ 2, 1, 0, "+\n" ], [ 3, 1, 0, "+" ], [ 4, 0, 2021, qq{"+"\n} ], [ 5, 0, 2025, qq{"+\n} ], [ 6, 0, 2011, qq{""+\n} ], [ 7, 0, 2027, qq{"+"} ], [ 8, 0, 2024, qq{"+} ], [ 9, 0, 2011, qq{""+} ], [ 10, 1, 0, "\r" ], [ 11, 0, 2031, "\r\b" ], [ 12, 0, 2032, "+\r\b" ], [ 13, 0, 2032, "+\r\b+" ], [ 14, 0, 2022, qq{"\r"} ], [ 15, 0, 2022, qq{"\r\b" } ], [ 16, 0, 2022, qq{"\r\b"\t} ], [ 17, 0, 2025, qq{"+\r\b"} ], [ 18, 0, 2025, qq{"+\r\b+"} ], [ 19, 0, 2022, qq{"\r"\b} ], [ 20, 0, 2022, qq{"\r\b"\b} ], [ 21, 0, 2025, qq{"+\r\b"\b} ], [ 22, 0, 2025, qq{"+\r\b+"\b} ], [ 23, 0, 2037, qq{\b} ], [ 24, 0, 2026, qq{"\b"} ], ) { my ($tst, $valid, $err, $str) = @$_; my $raw = $] < 5.008 ? "" : ":raw"; open FH, ">$raw", $tfn or die "$tfn: $!"; print FH $str; close FH; $csv = Text::CSV->new ({ escape_char => "+" }); open FH, "<$raw", $tfn or die "$tfn: $!"; my $row = $csv->getline (*FH); close FH; my @err = $csv->error_diag; my $sstr = _readable ($str); SKIP: { ok ($valid ? $row : !$row, "$tst - getline ESC +, '$sstr'"); is ($err[0], $err, "Error expected $err"); } } Text-CSV-2.06/t/71_pp.t0000644000175100017510000002162614600712237014551 0ustar ishigakiishigaki#!/usr/bin/perl # tests for bug report fixes or patches. use strict; $^W = 1; use Test::More tests => 104; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; } BEGIN { require_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; } #warn Text::CSV->backend; my $csv = Text::CSV->new( { sep_char => "\t", blank_is_undef => 1, allow_whitespace => 1 } ); ok $csv->parse(qq|John\t\t"my notes"|); is_deeply ([ $csv->fields ], [ "John", undef, "my notes" ], "Tab with allow_white_space"); # 2009-04-23 rt#45215 my $str = "this,is,some,csv,data\n"; $csv = Text::CSV->new; $csv->parse($str); is( $csv->string, $str ); #=pod # 2009-05-16 # getline() handles having escaped null my $opts = { 'escape_char' => '"', 'quote_char' => '"', 'binary' => 1, 'sep_char' => ',' }; my $eol = "\r\n"; my $blob = ( join "", map { chr $_ } 0 .. 255 ) x 1; #my $blob = ( join "", map { chr $_ } 0 .. 2 ) x 1; $csv = Text::CSV->new( $opts ); open( FH, '>__test.csv' ) or die $!; binmode FH; # writting ok( $csv->print( *FH, [ $blob ] ) ); close( FH ); # reading open( FH, "__test.csv" ) or die $!; binmode FH; $opts->{eol} = $eol; $csv = Text::CSV->new( $opts ); ok( my $colref = $csv->getline( *FH ) ); is( $colref->[0], $blob, "blob" ); close( FH ); #exit; unlink( '__test.csv' ); #=cut # 2009-07-30 # getline() handles a 0 staring multiline # writting open( FH, '>__test.csv' ) or die $!; binmode FH; ok( $csv->print( *FH, [ "00" ] ) ); ok( $csv->print( *FH, [ "\00" ] ) ); ok( $csv->print( *FH, [ "0\0" ] ) ); ok( $csv->print( *FH, [ "\0\0" ] ) ); ok( $csv->print( *FH, [ "0\n0" ] ) ); ok( $csv->print( *FH, [ "\0\n0" ] ) ); ok( $csv->print( *FH, [ "0\n\0" ] ) ); ok( $csv->print( *FH, [ "\0\n\0" ] ) ); ok( $csv->print( *FH, [ "\"0\n0" ] ) ); ok( $csv->print( *FH, [ "\"\0\n0" ] ) ); ok( $csv->print( *FH, [ "\"0\n\0" ] ) ); ok( $csv->print( *FH, [ "\"\0\n\0" ] ) ); ok( $csv->print( *FH, [ "\"0\n\"0" ] ) ); ok( $csv->print( *FH, [ "\"\0\n\"0" ] ) ); ok( $csv->print( *FH, [ "\"0\n\"\0" ] ) ); ok( $csv->print( *FH, [ "\"\0\n\"\0" ] ) ); ok( $csv->print( *FH, [ "0\n0", "0\n0" ] ) ); ok( $csv->print( *FH, [ "\0\n0", "\0\n0" ] ) ); ok( $csv->print( *FH, [ "0\n\0", "0\n\0" ] ) ); ok( $csv->print( *FH, [ "\0\n\0", "\0\n\0" ] ) ); $csv->always_quote(1); ok( $csv->print( *FH, [ "", undef, "0\n", "", "\0\n0" ] ) ); close( FH ); # reading open( FH, "__test.csv" ) or die $!; binmode FH; is( $csv->getline( *FH )->[0], "00", '*00' ); # Test::More warns 00 is( $csv->getline( *FH )->[0], "\00", '\00' ); is( $csv->getline( *FH )->[0], "0\0", '0\0' ); is( $csv->getline( *FH )->[0], "\0\0", '\0\0' ); is( $csv->getline( *FH )->[0], "0\n0", '*0\n0' ); # Test::More warns 00 is( $csv->getline( *FH )->[0], "\0\n0", '\0\n0' ); is( $csv->getline( *FH )->[0], "0\n\0", '0\n\0' ); is( $csv->getline( *FH )->[0], "\0\n\0", '\0\n\0' ); is( $csv->getline( *FH )->[0], "\"0\n0", '\"0\n0' ); is( $csv->getline( *FH )->[0], "\"\0\n0", '\"\0\n0' ); is( $csv->getline( *FH )->[0], "\"0\n\0", '\"0\n\0' ); is( $csv->getline( *FH )->[0], "\"\0\n\0", '\"\0\n\0' ); is( $csv->getline( *FH )->[0], "\"0\n\"0", '\"0\n\"0' ); is( $csv->getline( *FH )->[0], "\"\0\n\"0", '\"\0\n\"0' ); is( $csv->getline( *FH )->[0], "\"0\n\"\0", '\"0\n\"\0' ); is( $csv->getline( *FH )->[0], "\"\0\n\"\0", '\"\0\n\"\0' ); is( $csv->getline( *FH )->[1], "0\n0", '*0\n0' ); # Test::More warns 00 is( $csv->getline( *FH )->[1], "\0\n0", '\0\n0' ); is( $csv->getline( *FH )->[1], "0\n\0", '0\n\0' ); is( $csv->getline( *FH )->[1], "\0\n\0", '\0\n\0' ); $csv->blank_is_undef(1); my $col = $csv->getline( *FH ); is( $col->[0], "", '' ); is( $col->[1], undef, '' ); is( $col->[2], "0\n", '' ); is( $col->[3], "", '' ); is( $col->[4], "\0\n0", '' ); close( FH ); unlink( '__test.csv' ); # 2010-06-18 reported by https://rt.cpan.org/Public/Bug/Display.html?id=58356 $csv = Text::CSV->new ({ binary => 1, quote_space => 0 }); my @list = ( "a a", "b,b", "c ,c", ); ok( $csv->combine( @list ) ); is( $csv->string, q{a a,"b,b","c ,c"} ); # 2010-06-22 reported { $csv = Text::CSV->new ({ binary => 1, sep_char => ';', always_quote => 1 }); open( FH, '>__test.csv' ) or die $!; binmode FH; ok( $csv->print( *FH, [ 0, qq{t"t"\n} ] ) ); close( FH ); open( FH, "__test.csv" ) or die $!; binmode FH; my $col = $csv->getline( *FH ); is( $col->[0], "0" ); is( $col->[1], qq{t"t"\n} ); close( FH ); unlink( '__test.csv' ); } # 2010-10-13 reported by hiratara { $csv = Text::CSV->new ({ binary => 1, eol => $/, always_quote => 1 }); open( FH, '>__test.csv' ) or die $!; binmode FH; ok( $csv->print( *FH, [qw/A 01/] ) ); ok( $csv->print( *FH, [qw/B 02/] ) ); close( FH ); open( FH, "__test.csv" ) or die $!; binmode FH; my $col = $csv->getline( *FH ); is( $col->[0], 'A' ); is( $col->[1], '01' ); $col = $csv->getline( *FH ); is( $col->[0], 'B' ); is( $col->[1], '02' ); close( FH ); unlink( '__test.csv' ); } # 2010-10-13 reported(2) by hiratara { $csv = Text::CSV->new ({ binary => 1, eol => $/ }); open( FH, '>__test.csv' ) or die $!; binmode FH; ok( $csv->print( *FH, [qw/1 0"/] ) ); ok( $csv->print( *FH, [qw/2 0"/] ) ); close( FH ); open( FH, "__test.csv" ) or die $!; binmode FH; my $col = $csv->getline( *FH ); is( $col->[0], '1' ); is( $col->[1], '0"' ); $col = $csv->getline( *FH ); is( $col->[0], '2' ); is( $col->[1], '0"' ); close( FH ); unlink( '__test.csv' ); } { # previous three test merged $csv = Text::CSV->new ({ binary => 1, eol => $/ }); open( FH, '>__test.csv' ) or die $!; binmode FH; ok( $csv->print( *FH, [ 0, qq{t"t"\n} ] ) ); ok( $csv->print( *FH, [qw/A 01/] ) ); ok( $csv->print( *FH, [qw/1 0"/] ) ); ok( $csv->print( *FH, [undef,undef] ) ); ok( $csv->print( *FH, [qw/1 0"/] ) ); ok( $csv->print( *FH, [qw/A 01/] ) ); close( FH ); open( FH, "__test.csv" ) or die $!; binmode FH; my $col = $csv->getline( *FH ); is( $col->[0], "0" ); is( $col->[1], qq{t"t"\n} ); $col = $csv->getline( *FH ); is( $col->[0], 'A' ); is( $col->[1], '01' ); $col = $csv->getline( *FH ); is( $col->[0], '1' ); is( $col->[1], '0"' ); $col = $csv->getline( *FH ); is( $col->[0], '' ); is( $col->[1], '' ); $col = $csv->getline( *FH ); is( $col->[0], '1' ); is( $col->[1], '0"' ); $col = $csv->getline( *FH ); is( $col->[0], 'A' ); is( $col->[1], '01' ); close( FH ); unlink( '__test.csv' ); } SKIP: { # https://rt.cpan.org/Ticket/Display.html?id=83705 skip "pp only for now", 3 unless Text::CSV->is_pp; my $csv = Text::CSV->new( { binary => 1, allow_loose_escapes => 1, allow_loose_quotes => 1, sep_char => q{;}, escape_char => q{"}, quote_char => q{"} } ); $csv->parse(q{"6RE";"EINKAUF";"5";"";"2,5" HD"}); is_deeply([$csv->fields], ["6RE","EINKAUF","5","",'2,5" HD']); my $csv_dump = q{"6RE";"EINKAUF";"5";"";"2,5" HD" "LIDL";"-2"}; open( FH, '>__test.csv' ) or die $!; print FH $csv_dump; close FH; open FH, '<__test.csv'; is_deeply( $csv->getline(*FH), ["6RE","EINKAUF","5","",'2,5" HD'] ); is_deeply( $csv->getline(*FH), ['LIDL','-2'] ); close FH; unlink( '__test.csv' ); } { # imported from t/70_rt.t my $csv = Text::CSV->new ({ escape_char => "\\", auto_diag => 1 }); ok( $csv->parse(q{1,"\,",3}) ); is_deeply ([ $csv->fields ], [ 1, ",", 3 ], "escaped sep in quoted field"); ok( $csv->parse(q{1,"2\,4",3}) ); is_deeply ([ $csv->fields ], [ 1, "2,4", 3 ], "escaped sep in quoted field"); $csv->allow_unquoted_escape(1); ok( $csv->parse(q{1,\,,3}) ); is_deeply ([ $csv->fields ], [ 1, ",", 3 ], "escaped sep in quoted field"); ok( $csv->parse(q{1,2\,4,3}) ); is_deeply ([ $csv->fields ], [ 1, "2,4", 3 ], "escaped sep in quoted field"); } { # https://github.com/makamaka/Text-CSV/pull/3 { package FakeFileHandleForEOF; sub new { return bless { line => "foo,bar,baz\n" }, shift } sub getline { my $self = shift; return delete $self->{line}; } sub eof { my $self = shift; return not exists $self->{line}; } } my $csv = Text::CSV->new({binary => 1}); my $fh = FakeFileHandleForEOF->new; ok(!$fh->eof); eval { is_deeply( $csv->getline($fh), [qw[ foo bar baz ]]) }; is($@, '', "no exception thrown"); ok($fh->eof); } { # https://github.com/makamaka/Text-CSV/issues/14 # https://rt.cpan.org/Ticket/Display.html?id=109719 SKIP: { skip "requires Encode", 1 unless eval "require Encode"; my $csv = Text::CSV->new({empty_is_undef => 1, blank_is_undef => 1}); my $line = "foo,,bar,"; Encode::_utf8_on($line); $csv->parse($line); my @fields = $csv->fields; is_deeply \@fields => ['foo', undef, 'bar', undef]; } } Text-CSV-2.06/t/65_allow.t0000644000175100017510000003254714760113543015261 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; #use Test::More "no_plan"; use Test::More tests => 1119; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", (); plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } my $tfn = "_65test.csv"; END { -f $tfn and unlink $tfn; } my $csv; ok (1, "Allow unescaped quotes"); # Allow unescaped quotes inside an unquoted field { my @bad = ( # valid, line [ 1, 1, 0, qq{foo,bar,"baz",quux} ], [ 2, 0, 2034, qq{rj,bs,r"jb"s,rjbs} ], [ 3, 0, 2034, qq{some "spaced" quote data,2,3,4} ], [ 4, 1, 0, qq{and an,entirely,quoted,"field"} ], [ 5, 1, 0, qq{and then,"one with ""quoted"" quotes",okay,?} ], ); for (@bad) { my ($tst, $valid, $err, $bad) = @$_; $csv = Text::CSV->new (); ok ($csv, "$tst - new (alq => 0)"); is ($csv->parse ($bad), $valid, "$tst - parse () fail"); is (0 + $csv->error_diag, $err, "$tst - error $err"); $csv->allow_loose_quotes (1); ok ($csv->parse ($bad), "$tst - parse () pass"); ok (my @f = $csv->fields, "$tst - fields"); } #$csv = Text::CSV->new ({ quote_char => '"', escape_char => "=" }); #ok (!$csv->parse (qq{foo,d'uh"bar}), "should fail"); } ok (1, "Allow loose quotes inside quoted"); # Allow unescaped quotes inside a quoted field { my @bad = ( # valid, line [ 1, 1, 0, qq{foo,bar,"baz",quux} ], [ 2, 0, 2023, qq{rj,bs,"r"jb"s",rjbs} ], [ 3, 0, 2023, qq{"some "spaced" quote data",2,3,4} ], [ 4, 1, 0, qq{and an,entirely,quoted,"field"} ], [ 5, 1, 0, qq{and then,"one with ""quoted"" quotes",okay,?} ], ); for (@bad) { my ($tst, $valid, $err, $bad) = @$_; $csv = Text::CSV->new (); ok ($csv, "$tst - new (alq => 0)"); is ($csv->parse ($bad), $valid, "$tst - parse () fail"); is (0 + $csv->error_diag, $err, "$tst - error $err"); $csv->allow_loose_quotes (1); is ($csv->parse ($bad), $valid, "$tst - parse () fail with lq"); is (0 + $csv->error_diag, $err, "$tst - error $err"); $csv->escape_char (undef); ok ($csv->parse ($bad), "$tst - parse () pass"); ok (my @f = $csv->fields, "$tst - fields"); } } ok (1, "Allow loose escapes"); # Allow escapes to escape characters that should not be escaped { my @bad = ( # valid, line [ 1, 1, 0, qq{1,foo,bar,"baz",quux} ], [ 2, 1, 0, qq{2,escaped,"quote\\"s",in,"here"} ], [ 3, 1, 0, qq{3,escaped,quote\\"s,in,"here"} ], [ 4, 1, 0, qq{4,escap\\'d chars,allowed,in,unquoted,fields} ], [ 5, 0, 2025, qq{5,42,"and it\\'s dog",} ], [ 6, 1, 0, qq{\\,} ], [ 7, 1, 0, qq{\\} ], [ 8, 0, 2035, qq{foo\\} ], ); for (@bad) { my ($tst, $valid, $err, $bad) = @$_; $csv = Text::CSV->new ({ escape_char => "\\" }); ok ($csv, "$tst - new (ale => 0)"); is ($csv->parse ($bad), $valid, "$tst - parse () fail"); is (0 + $csv->error_diag, $err, "$tst - error $err"); $csv->allow_loose_escapes (1); if ($tst >= 8) { # Should always fail ok (!$csv->parse ($bad), "$tst - parse () fail"); is (0 + $csv->error_diag, $err, "$tst - error $err"); } else { ok ($csv->parse ($bad), "$tst - parse () pass"); ok (my @f = $csv->fields, "$tst - fields"); } } } ok (1, "Allow whitespace"); # Allow whitespace to surround sep char { my @bad = ( # valid, line [ 1, 1, 0, qq{1,foo,bar,baz,quux} ], [ 2, 1, 0, qq{1,foo,bar,"baz",quux} ], [ 3, 1, 0, qq{1, foo,bar,"baz",quux} ], [ 4, 1, 0, qq{ 1,foo,bar,"baz",quux} ], [ 5, 0, 2034, qq{1,foo,bar, "baz",quux} ], [ 6, 1, 0, qq{1,foo ,bar,"baz",quux} ], [ 7, 1, 0, qq{1,foo,bar,"baz",quux } ], [ 8, 1, 0, qq{1,foo,bar,"baz","quux"} ], [ 9, 0, 2023, qq{1,foo,bar,"baz" ,quux} ], [ 10, 0, 2023, qq{1,foo,bar,"baz","quux" } ], [ 11, 0, 2034, qq{ 1 , foo , bar , "baz" , quux } ], [ 12, 0, 2034, qq{ 1 , foo , bar , "baz" , quux } ], [ 13, 0, 2034, qq{ 1 , foo , bar , "baz"\t , quux } ], ); foreach my $eol ("", "\n", "\r", "\r\n") { my $s_eol = _readable ($eol); for (@bad) { my ($tst, $ok, $err, $bad) = @$_; $csv = Text::CSV->new ({ eol => $eol, binary => 1 }); ok ($csv, "$s_eol / $tst - new - '$bad')"); is ($csv->parse ($bad), $ok, "$s_eol / $tst - parse () fail"); is (0 + $csv->error_diag, $err, "$tst - error $err"); $csv->allow_whitespace (1); ok ($csv->parse ("$bad$eol"), "$s_eol / $tst - parse () pass"); ok (my @f = $csv->fields, "$s_eol / $tst - fields"); local $" = ","; is ("@f", $bad[0][-1], "$s_eol / $tst - content"); } } } ok (1, "Allow whitespace"); # Allow whitespace to surround sep char { my @bad = ( # test, ok, line [ 1, 1, 0, qq{1,foo,bar,baz,quux} ], [ 2, 1, 0, qq{1,foo,bar,"baz",quux} ], [ 3, 1, 0, qq{1, foo,bar,"baz",quux} ], [ 4, 1, 0, qq{ 1,foo,bar,"baz",quux} ], [ 5, 0, 2034, qq{1,foo,bar, "baz",quux} ], [ 6, 1, 0, qq{1,foo ,bar,"baz",quux} ], [ 7, 1, 0, qq{1,foo,bar,"baz",quux } ], [ 8, 1, 0, qq{1,foo,bar,"baz","quux"} ], [ 9, 0, 2023, qq{1,foo,bar,"baz" ,quux} ], [ 10, 0, 2023, qq{1,foo,bar,"baz","quux" } ], [ 11, 0, 2023, qq{1,foo,bar,"baz","quux" } ], [ 12, 0, 2034, qq{ 1 , foo , bar , "baz" , quux } ], [ 13, 0, 2034, qq{ 1 , foo , bar , "baz" , quux } ], [ 14, 0, 2034, qq{ 1 , foo , bar , "baz"\t , quux } ], ); foreach my $eol ("", "\n", "\r", "\r\n") { my $s_eol = _readable ($eol); for (@bad) { my ($tst, $ok, $err, $bad) = @$_; $csv = Text::CSV->new ({ eol => $eol, binary => 1, }); ok ($csv, "$s_eol / $tst - new - '$bad')"); is ($csv->parse ($bad), $ok, "$s_eol / $tst - parse () fail"); is (0 + $csv->error_diag, $err, "$tst - error $err"); $csv->allow_whitespace (1); ok ($csv->parse ("$bad$eol"), "$s_eol / $tst - parse () pass"); ok (my @f = $csv->fields, "$s_eol / $tst - fields"); local $" = ","; is ("@f", $bad[0][-1], "$s_eol / $tst - content"); } } } ok (1, "blank_is_undef"); foreach my $conf ( [ 0, 0, 0, 1, "", " ", '""', 2, "", "", "" ], [ 0, 0, 1, 1, undef, " ", '""', 2, undef, undef, undef ], [ 0, 1, 0, 1, "", " ", '""', 2, "", "", "" ], [ 0, 1, 1, 1, undef, " ", '""', 2, undef, undef, undef ], [ 1, 0, 0, 1, "", " ", '""', 2, "", "", "" ], [ 1, 0, 1, 1, "", " ", '""', 2, undef, "", undef ], [ 1, 1, 0, 1, "", " ", '""', 2, "", "", "" ], [ 1, 1, 1, 1, "", " ", '""', 2, undef, "", undef ], ) { my ($aq, $aw, $bu, @expect, $str) = @$conf; $csv = Text::CSV->new ({ always_quote => $aq, allow_whitespace => $aw, blank_is_undef => $bu }); ok ($csv, "new ({ aq $aq aw $aw bu $bu })"); ok ($csv->combine (1, "", " ", '""', 2, undef, "", undef), "combine ()"); ok ($str = $csv->string, "string ()"); foreach my $eol ("", "\n", "\r\n") { my $s_eol = _readable ($eol); ok ($csv->parse ($str.$eol), "parse (*$str$s_eol*)"); ok (my @f = $csv->fields, "fields ()"); is_deeply (\@f, \@expect, "result"); } } ok (1, "empty_is_undef"); foreach my $conf ( [ 0, 0, 0, 1, "", " ", '""', 2, "", "", "" ], [ 0, 0, 1, 1, undef, " ", '""', 2, undef, undef, undef ], [ 0, 1, 0, 1, "", " ", '""', 2, "", "", "" ], [ 0, 1, 1, 1, undef, " ", '""', 2, undef, undef, undef ], [ 1, 0, 0, 1, "", " ", '""', 2, "", "", "" ], [ 1, 0, 1, 1, undef, " ", '""', 2, undef, undef, undef ], [ 1, 1, 0, 1, "", " ", '""', 2, "", "", "" ], [ 1, 1, 1, 1, undef, " ", '""', 2, undef, undef, undef ], ) { my ($aq, $aw, $bu, @expect, $str) = @$conf; $csv = Text::CSV->new ({ always_quote => $aq, allow_whitespace => $aw, empty_is_undef => $bu }); ok ($csv, "new ({ aq $aq aw $aw bu $bu })"); ok ($csv->combine (1, "", " ", '""', 2, undef, "", undef), "combine ()"); ok ($str = $csv->string, "string ()"); foreach my $eol ("", "\n", "\r\n") { my $s_eol = _readable ($eol); ok ($csv->parse ($str.$eol), "parse (*$str$s_eol*)"); ok (my @f = $csv->fields, "fields ()"); is_deeply (\@f, \@expect, "result"); } } ok (1, "Trailing junk"); foreach my $bin (0, 1) { foreach my $eol (undef, "\r") { my $s_eol = _readable ($eol); my $csv = Text::CSV->new ({ binary => $bin, eol => $eol }); ok ($csv, "$s_eol - new ()"); my @bad = ( # test, line [ 1, qq{"\r\r\n"\r} ], [ 2, qq{"\r\r\n"\r\r} ], [ 3, qq{"\r\r\n"\r\r\n} ], [ 4, qq{"\r\r\n"\t \r} ], [ 5, qq{"\r\r\n"\t \r\r} ], [ 6, qq{"\r\r\n"\t \r\r\n} ], ); my @pass = ( 0, 0, 0, 1 ); my @fail = ( 2022, 2022, 2023, 0 ); foreach my $arg (@bad) { my ($tst, $bad) = @$arg; my $ok = ($bin << 1) | ($eol ? 1 : 0); is ($csv->parse ($bad), $pass[$ok], "$tst $ok - parse () default"); is (0 + $csv->error_diag, $fail[$ok], "$tst $ok - error $fail[$ok]"); $csv->allow_whitespace (1); is ($csv->parse ($bad), $pass[$ok], "$tst $ok - parse () allow"); is (0 + $csv->error_diag, $fail[$ok], "$tst $ok - error $fail[$ok]"); } } } { ok (1, "verbatim"); my $csv = Text::CSV->new ({ sep_char => "^", binary => 1, }); my @str = ( qq{M^^Abe^Timmerman#\r\n}, qq{M^^Abe\nTimmerman#\r\n}, ); my $gc; ok (1, "verbatim on parse ()"); foreach $gc (0, 1) { $csv->verbatim ($gc); ok ($csv->parse ($str[0]), "\\n $gc parse"); my @fld = $csv->fields; is (@fld, 4, "\\n $gc fields"); is ($fld[2], "Abe", "\\n $gc fld 2"); if ($gc) { # Note line ending is still there! is ($fld[3], "Timmerman#\r\n", "\\n $gc fld 3"); } else { # Note the stripped \r! is ($fld[3], "Timmerman#", "\\n $gc fld 3"); } ok ($csv->parse ($str[1]), "\\n $gc parse"); @fld = $csv->fields; is (@fld, 3, "\\n $gc fields"); if ($gc) { # All newlines verbatim is ($fld[2], "Abe\nTimmerman#\r\n", "\\n $gc fld 2"); } else { # Note, rest is next line is ($fld[2], "Abe", "\\n $gc fld 2"); } } $csv->eol ($/ = "#\r\n"); foreach $gc (0, 1) { $csv->verbatim ($gc); ok ($csv->parse ($str[0]), "#\\r\\n $gc parse"); my @fld = $csv->fields; is (@fld, 4, "#\\r\\n $gc fields"); is ($fld[2], "Abe", "#\\r\\n $gc fld 2"); is ($fld[3], $gc ? "Timmerman#\r\n" : "Timmerman", "#\\r\\n $gc fld 3"); ok ($csv->parse ($str[1]), "#\\r\\n $gc parse"); @fld = $csv->fields; is (@fld, 3, "#\\r\\n $gc fields"); is ($fld[2], $gc ? "Abe\nTimmerman#\r\n" : "Abe", "#\\r\\n $gc fld 2"); } my $fh; ok (1, "verbatim on getline (\$fh)"); open $fh, ">", $tfn or die "$tfn: $!\n"; print $fh @str, "M^Abe^*\r\n"; close $fh; foreach $gc (0, 1) { $csv->verbatim ($gc); open $fh, "<", $tfn or die "$tfn: $!\n"; my $row; ok ($row = $csv->getline ($fh), "#\\r\\n $gc getline"); is (@$row, 4, "#\\r\\n $gc fields"); is ($row->[2], "Abe", "#\\r\\n $gc fld 2"); is ($row->[3], "Timmerman", "#\\r\\n $gc fld 3"); ok ($row = $csv->getline ($fh), "#\\r\\n $gc parse"); is (@$row, 3, "#\\r\\n $gc fields"); is ($row->[2], $gc ? "Abe\nTimmerman" : "Abe", "#\\r\\n $gc fld 2"); } $gc = $csv->verbatim (); ok (my $row = $csv->getline ($fh), "#\\r\\n $gc parse EOF"); is (@$row, 3, "#\\r\\n $gc fields"); is ($row->[2], "*\r\n", "#\\r\\n $gc fld 2"); close $fh; $csv = Text::CSV->new ({ binary => 0, verbatim => 1, eol => "#\r\n", }); open $fh, ">", $tfn or die "$tfn: $!\n"; print $fh $str[1]; close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; is ($csv->getline ($fh), undef, "#\\r\\n $gc getline 2030"); is (0 + $csv->error_diag, 2030, "Got 2030"); close $fh; unlink $tfn; } { ok (1, "keep_meta_info on getline ()"); my $csv = Text::CSV->new ({ eol => "\n" }); open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh qq{1,"",,"Q",2\n}; close $fh; is ($csv->keep_meta_info (0), 0, "No meta info"); open $fh, "<", $tfn or die "$tfn: $!\n"; my $row = $csv->getline ($fh); ok ($row, "Get 1st line"); $csv->error_diag (); is ($csv->is_quoted (2), undef, "Is field 2 quoted?"); is ($csv->is_quoted (3), undef, "Is field 3 quoted?"); close $fh; open $fh, ">", $tfn or die "$tfn: $!\n"; print $fh qq{1,"",,"Q",2\n}; close $fh; is ($csv->keep_meta_info (1), 1, "Keep meta info"); open $fh, "<", $tfn or die "$tfn: $!\n"; $row = $csv->getline ($fh); ok ($row, "Get 2nd line"); $csv->error_diag (); is ($csv->is_quoted (2), 0, "Is field 2 quoted?"); is ($csv->is_quoted (3), 1, "Is field 3 quoted?"); close $fh; unlink $tfn; } { my $csv = Text::CSV->new ({}); my $s2023 = qq{2023,",2008-04-05," \tFoo, Bar",\n}; # " # ^ is ( $csv->parse ($s2023), 0, "Parse 2023"); is (($csv->error_diag)[0], 2023, "Fail code 2023"); is (($csv->error_diag)[2], 19, "Fail position"); is ( $csv->allow_whitespace (1), 1, "Allow whitespace"); is ( $csv->parse ($s2023), 0, "Parse 2023"); is (($csv->error_diag)[0], 2023, "Fail code 2023"); is (($csv->error_diag)[2], 22, "Space is eaten now"); } { my $csv = Text::CSV->new ({ allow_unquoted_escape => 1, escape_char => "=" }); my $str = q{1,3,=}; is ( $csv->parse ($str), 0, "Parse trailing ESC"); is (($csv->error_diag)[0], 2035, "Fail code 2035"); $str .= "0"; is ( $csv->parse ($str), 1, "Parse trailing ESC"); is_deeply ([ $csv->fields ], [ 1,3,"\0" ], "Parse passed"); } Text-CSV-2.06/t/77_getall.t0000644000175100017510000000437414760113543015413 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More tests => 81; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; require_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } $| = 1; my $tfn = "_77test.csv"; END { -f $tfn and unlink $tfn; } my @testlist = ( [ 1, "a", "\x01", "A" ], [ 2, "b", "\x02", "B" ], [ 3, "c", "\x03", "C" ], [ 4, "d", "\x04", "D" ], ); my @list; sub do_tests { my $sub = shift; $sub->(\@list); $sub->(\@list, 0); $sub->([@list[2,3]], 2); $sub->([], 0, 0); $sub->(\@list, 0, 10); $sub->([@list[0,1]], 0, 2); $sub->([@list[1,2]], 1, 2); $sub->([@list[1,2]], 1e0, 2); $sub->([@list[1,2]], "1", 2); $sub->([@list[1..3]], -3); $sub->([@list[1,2]], -3, 2); $sub->([@list[1..3]], -3, 3); $sub->([$list[0]], 0, 1); $sub->([$list[0]], 0, 1e0); $sub->([$list[0]], 0, "1"); } # do_tests foreach my $eol ("\n", "\r") { @list = @testlist; { ok (my $csv = Text::CSV->new ({ binary => 1, eol => $eol }), "csv out EOL "._readable ($eol)); open my $fh, ">", $tfn or die "$tfn: $!"; ok ($csv->print ($fh, $_), "write $_->[0]") for @list; close $fh; } { ok (my $csv = Text::CSV->new ({ binary => 1 }), "csv in"); do_tests (sub { my ($expect, @args) = @_; open my $fh, "<", $tfn or die "$tfn: $!"; my $s_args = join ", " => @args; is_deeply ($csv->getline_all ($fh, @args), $expect, "getline_all ($s_args)"); close $fh; }); } { ok (my $csv = Text::CSV->new ({ binary => 1 }), "csv in"); ok ($csv->column_names (my @cn = qw( foo bar bin baz )), "Set column names"); @list = map { my %h; @h{@cn} = @$_; \%h } @list; do_tests (sub { my ($expect, @args) = @_; open my $fh, "<", $tfn or die "$tfn: $!"; my $s_args = join ", " => @args; is_deeply ($csv->getline_hr_all ($fh, @args), $expect, "getline_hr_all ($s_args)"); close $fh; }); } { ok (my $csv = Text::CSV->new ({ binary => 1 }), "csv in"); open my $fh, "<", $tfn or die "$tfn: $!"; eval { my $row = $csv->getline_hr_all ($fh); }; is ($csv->error_diag () + 0, 3002, "Use _hr before colnames ()"); } } Text-CSV-2.06/t/csv_method.t0000644000175100017510000000155014600712237015750 0ustar ishigakiishigakiuse strict; use warnings; use File::Spec; use Test::More tests => 5; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; require_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; } { my $file = prepare('1,2,3'); my $csv = Text::CSV->new (); ok my $aoa = eval { $csv->csv (in => $file) }; is_deeply($aoa, [[1,2,3]]) or note explain $aoa; unlink $file; } { my $file = prepare('col1;col2;col3','1;2;3'); my $csv = Text::CSV->new ({ sep_char => ";" }); ok my $aoh = eval { $csv->csv (in => $file, bom => 1) }; is_deeply($aoh, [{col1 => 1, col2 => 2, col3 => 3}]) or note explain $aoh; unlink $file; } sub prepare { my @lines = @_; my $file = File::Spec->catfile(File::Spec->tmpdir, "file.csv"); open my $fh, '>', $file; print $fh "$_\n" for @lines; close $fh; $file; } Text-CSV-2.06/t/47_comment.t0000644000175100017510000000704214760113543015575 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; } use Text::CSV qw(csv); BEGIN { if ($] < 5.008002) { plan skip_all => "These tests require Encode and Unicode support"; } else { require Encode; plan tests => 71; } require "./t/util.pl"; } $| = 1; my $tfn = "_47cmnt.csv"; END { -f $tfn and unlink $tfn; } foreach my $cstr ("#", "//", "Comment", "\xe2\x98\x83") { foreach my $rest ("", " 1,2", "a,b") { my $csv = Text::CSV->new ({ binary => 1 }); $csv->comment_str ($cstr); my $fh; open $fh, ">", $tfn or die "$tfn: $!\n"; print $fh qq{$cstr$rest\n}; print $fh qq{c,$cstr\n}; print $fh qq{ $cstr\n}; print $fh qq{e,$cstr,$rest\n}; print $fh qq{$cstr\n}; print $fh qq{g,i$cstr\n}; print $fh qq{j,"k\n${cstr}k"\n}; print $fh qq{$cstr\n}; close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; my $cuni = Encode::decode ("utf-8", $cstr); my @rest = split m/,/ => $rest, -1; @rest or push @rest => ""; is_deeply ($csv->getline ($fh), [ "c", $cuni ], "$cstr , $rest"); is_deeply ($csv->getline ($fh), [ " $cuni" ], "leading space"); is_deeply ($csv->getline ($fh), [ "e", $cuni, @rest ], "not start of line"); is_deeply ($csv->getline ($fh), [ "g", "i$cuni" ], "not start of field"); is_deeply ($csv->getline ($fh), [ "j", "k\n${cuni}k" ], "in quoted field after NL"); close $fh; unlink $tfn; } } my $data = <<"EOC"; id | name # 42 | foo # EOC is_deeply (csv ( in => \$data, sep_char => "|", headers => "auto", allow_whitespace => 1, comment_str => "#", strict => 0, ), [{ id => 42, name => "foo" }], "Last record is comment"); is_deeply (csv ( in => \$data, sep_char => "|", headers => "auto", allow_whitespace => 1, comment_str => "#", strict => 1, ), [{ id => 42, name => "foo" }], "Last record is comment, under strict"); $data .= "3\n"; is_deeply (csv ( in => \$data, sep_char => "|", headers => "auto", allow_whitespace => 1, comment_str => "#", strict => 0, ), [{ id => 42, name => "foo" }, { id => 3, name => undef }, ], "Valid record past comment"); is_deeply (csv ( in => \$data, sep_char => "|", headers => "auto", allow_whitespace => 1, comment_str => "#", strict => 1, auto_diag => 0, # Suppress error 2014 ), [{ id => 42, name => "foo" }], "Invalid record past comment, under strict"); is_deeply (csv ( in => \"# comment\n42 | foo\n53 | bar\n", sep_char => "|", allow_whitespace => 1, comment_str => "#", strict => 1, auto_diag => 1, ), [[ 42, "foo" ], [ 53, "bar" ]], "Comment on first line, under strict"); foreach my $io (1, 0) { my $csv = Text::CSV->new ({ strict => 1, comment_str => "#", sep_char => "|", auto_diag => 2, diag_verbose => 1, }); # Data line is required to set field count for strict if ($io) { is_deeply ($csv->getline (*DATA), [ "a", "b" ], "Comment on last line IO data"); is_deeply ($csv->getline (*DATA), undef, "Comment on last line IO comment"); } else { ok ($csv->parse ("a|b"), "Parse data line"); is_deeply ([ $csv->fields ], [ "a", "b" ], "Data in parse"); ok ($csv->parse ("# some comment"), "Parse comment"); is_deeply ([ $csv->fields ], [ ], "Comment in parse"); } } 1; __END__ a|b # some comment Text-CSV-2.06/t/92_stream.t0000644000175100017510000000643114760113543015427 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; #use Test::More "no_plan"; use Test::More tests => 21; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", ("csv"); plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } my $tfni = "_92test-i.csv"; END { -f $tfni and unlink $tfni } # CRNL my $tfnn = "_92test-n.csv"; END { -f $tfnn and unlink $tfnn } # CRNL + NL my $tfno = "_92test-o.csv"; END { -f $tfno and unlink $tfno } # out my $data = "foo,bar,baz,quux\r\n". "1,2,3,25\r\n". "2,a b,,14\r\n"; open my $fhi, ">", $tfni or die "$tfni: $!"; print $fhi $data; close $fhi; open my $fhn, ">", $tfnn or die "$tfnn: $!"; { my $d = $data; $d =~ s/5\r\n/5\n/; print $fhn $d; } close $fhn; ok (my $aoa = csv (in => $tfni), "Read default data");; { my ($I, $O, @W); ok (my $co = Text::CSV->new ({ eol => "\n", auto_diag => 1, callbacks => { before_print => sub { warn ++$O, "\n"; $_[1][3] =~ s/x$/y/ or $_[1][3] *= 4; }, }, }), "Create external CSV object"); open my $fho, ">", $tfno or die "$tfno: $!\n"; { local $SIG{__WARN__} = sub { push @W => @_ }; csv ( in => $tfni, out => undef, callbacks => { after_parse => sub { warn ++$I, "\n"; $co->print ($fho, $_[1]); }, }, ); } close $tfno; chomp @W; is ("@W", "1 1 2 2 3 3", "Old-fashioned streaming"); } # Basic straight-forward streaming, no filters/modifiers unlink $tfno if -e $tfno; csv (in => $tfni, out => $tfno, quote_space => 0); ok (-s $tfno, "FILE -> FILE"); is_deeply (csv (in => $tfno), $aoa, "Data is equal"); unlink $tfno if -e $tfno; open my $fho, ">", $tfno; csv (in => $tfni, out => $fho, quote_space => 0); close $fho; ok (-s $tfno, "FILE -> FH"); is_deeply (csv (in => $tfno), $aoa, "Data is equal"); unlink $tfno if -e $tfno; open $fhi, "<", $tfni; csv (in => $fhi, out => $tfno, quote_space => 0); close $fhi; ok (-s $tfno, "FH -> FILE"); is_deeply (csv (in => $tfno), $aoa, "Data is equal"); unlink $tfno if -e $tfno; open $fhi, "<", $tfni; open $fho, ">", $tfno; csv (in => $fhi, out => $fho, quote_space => 0); close $fho; close $fhi; ok (-s $tfno, "FH -> FH"); is_deeply (csv (in => $tfno), $aoa, "Data is equal"); unlink $tfno if -e $tfno; my @W; eval { local $SIG{__WARN__} = sub { push @W => @_ }; csv (in => $tfnn, out => $tfno, quote_space => 0); }; like ($W[0], qr{\b2016 - EOL\b}, "Inconsistent use of EOL"); ok (-s $tfno, "FH -> FILE (NL => CRNL)"); is_deeply (csv (in => $tfno), $aoa, "Data is equal"); is (do { local (@ARGV, $/) = ($tfno); <> }, $data, "Consistent CRNL"); unlink $tfno if -e $tfno; csv ( in => $tfni, out => $tfno, quote_space => 0, after_parse => sub { $_[1][1] .= "X" }, ); ok (-s $tfno, "With after_parse"); my @new = map { my @x = @$_; $x[1] .= "X"; \@x } @$aoa; is_deeply (csv (in => $tfno), \@new, "Data is equal"); # Prove streaming behavior my $io = ""; unlink $tfno if -e $tfno; csv ( in => $tfni, out => $tfno, on_in => sub { $io .= "I" }, callbacks => { before_print => sub { $io .= "O" }}, ); ok (-s $tfno, "FILE -> FILE"); is_deeply (csv (in => $tfno), $aoa, "Data is equal"); like ($io, qr{^(?:IO)+\z}, "IOIOIO..."); Text-CSV-2.06/t/15_flags.t0000644000175100017510000003041714760113543015224 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; # use warnings core since 5.6 use Test::More tests => 229; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; } sub crnlsp { my $csv = shift; ok (!$csv->parse (), "Missing arguments"); ok ( $csv->parse ("\n"), "NL"); if ($csv->eol eq "\r") { ok ( $csv->parse ("\r"), "CR"); ok ( $csv->parse ("\r\r"), "CR CR"); ok ( $csv->parse ("\r "), "CR + Space"); ok ( $csv->parse (" \r"), "Space + CR"); } else { ok (!$csv->parse ("\r"), "CR"); ok (!$csv->parse ("\r\r"), "CR CR"); if ($csv->binary) { ok ( $csv->parse ("\r "), "CR + Space"); ok ( $csv->parse (" \r"), "Space + CR"); } else { ok (!$csv->parse ("\r "), "CR + Space"); ok (!$csv->parse (" \r"), "Space + CR"); } } ok ( $csv->parse ("\r\n"), "CR NL"); ok ( $csv->parse ("\n "), "NL + Space"); ok ( $csv->parse ("\r\n "), "CR NL + Space"); if ($csv->binary) { ok ( $csv->parse (qq{"\n"}), "Quoted NL"); ok ( $csv->parse (qq{"\r"}), "Quoted CR"); ok ( $csv->parse (qq{"\r\n"}), "Quoted CR NL"); ok ( $csv->parse (qq{"\n "}), "Quoted NL + Space"); ok ( $csv->parse (qq{"\r "}), "Quoted CR + Space"); ok ( $csv->parse (qq{"\r\n "}), "Quoted CR NL + Space"); } else { ok (!$csv->parse (qq{"\n"}), "Quoted NL"); ok (!$csv->parse (qq{"\r"}), "Quoted CR"); ok (!$csv->parse (qq{"\r\n"}), "Quoted CR NL"); ok (!$csv->parse (qq{"\n "}), "Quoted NL + Space"); ok (!$csv->parse (qq{"\r "}), "Quoted CR + Space"); ok (!$csv->parse (qq{"\r\n "}), "Quoted CR NL + Space"); } ok (!$csv->parse (qq{"\r\r\n"\r}), "Quoted CR CR NL >CR"); ok (!$csv->parse (qq{"\r\r\n"\r\r}), "Quoted CR CR NL >CR CR"); ok (!$csv->parse (qq{"\r\r\n"\r\r\n}), "Quoted CR CR NL >CR CR NL"); ok (!$csv->parse (qq{"\r\r\n"\t \r}), "Quoted CR CR NL >TAB Space CR"); ok (!$csv->parse (qq{"\r\r\n"\t \r\r}), "Quoted CR CR NL >TAB Space CR CR"); ok (!$csv->parse (qq{"\r\r\n"\t \r\r\n}), "Quoted CR CR NL >TAB Space CR CR NL"); } # crnlsp { my $csv = Text::CSV->new (); my $cb6 = chr (0xb6); # A random binary character is ($csv->meta_info, undef, "meta_info () before parse ()"); ok (1, "parse () tests - No meta_info"); crnlsp ($csv); ok (!$csv->parse ('"abc'), "Missing closing \""); ok (!$csv->parse ('ab"c'), "\" outside of \"'s"); ok (!$csv->parse ('"ab"c"'), "Bad character sequence"); ok (!$csv->parse ("ab${cb6}c"), "Binary character"); ok (!$csv->parse (qq{"ab${cb6}c"}), "Binary character in quotes"); ok (!$csv->parse (qq("abc\nc")), "Bad character (NL)"); ok (!$csv->status (), "Wrong status ()"); ok ( $csv->parse ('","'), "comma - parse ()"); is ( scalar $csv->fields (), 1, "comma - fields () - count"); is ( scalar $csv->meta_info (), 0, "comma - meta_info () - count"); is (($csv->fields ())[0], ",", "comma - fields () - content"); is (($csv->meta_info ())[0], undef, "comma - meta_info () - content"); ok ( $csv->parse (qq("","I said,\t""Hi!""","")), "Hi! - parse ()"); is ( scalar $csv->fields (), 3, "Hi! - fields () - count"); is ( scalar $csv->meta_info (), 0, "Hi! - meta_info () - count"); } { my $csv = Text::CSV->new ({ keep_meta_info => 1 }); ok (1, "parse () tests - With flags"); is ( $csv->meta_info, undef, "meta_info before parse"); ok (!$csv->parse (), "Missing arguments"); is ( $csv->meta_info, undef, "meta_info after failing parse"); crnlsp ($csv); ok (!$csv->parse ('"abc'), "Missing closing \""); ok (!$csv->parse ('ab"c'), "\" outside of \"'s"); ok (!$csv->parse ('"ab"c"'), "Bad character sequence"); ok (!$csv->parse (qq("abc\nc")), "Bad character (NL)"); ok (!$csv->status (), "Wrong status ()"); ok ( $csv->parse ('","'), "comma - parse ()"); is ( scalar $csv->fields (), 1, "comma - fields () - count"); is ( scalar $csv->meta_info (), 1, "comma - meta_info () - count"); is (($csv->fields ())[0], ",", "comma - fields () - content"); is (($csv->meta_info ())[0], 1, "comma - meta_info () - content"); ok ( $csv->parse (qq("","I said,\t""Hi!""",)), "Hi! - parse ()"); is ( scalar $csv->fields (), 3, "Hi! - fields () - count"); is ( scalar $csv->meta_info (), 3, "Hi! - meta_info () - count"); is (($csv->fields ())[0], "", "Hi! - fields () - field 1"); is (($csv->meta_info ())[0], 1, "Hi! - meta_info () - field 1"); is (($csv->fields ())[1], qq(I said,\t"Hi!"), "Hi! - fields () - field 2"); is (($csv->meta_info ())[1], 1, "Hi! - meta_info () - field 2"); is (($csv->fields ())[2], "", "Hi! - fields () - field 3"); is (($csv->meta_info ())[2], 0, "Hi! - meta_info () - field 3"); } { my $csv = Text::CSV->new ({ keep_meta_info => 1, binary => 1, quote_space => 0, }); ok ($csv->parse (qq{1,,"", ," ",f,"g","h""h",h\xb6lp,"h\xb6lp"}), "Parse"); ok (my @f = $csv->fields, "fields"); is_deeply (\@f, [ 1, "", "", " ", " ", "f", "g", "h\"h", "h\xb6lp", "h\xb6lp" ], "fields content"); ok ($csv->combine (@f), "combine"); is ($csv->string, qq{1,,, , ,f,g,"h""h",h\xb6lp,h\xb6lp}, "string 1"); ok ($csv->parse (qq{1,,"", ," ",f,"g","h""h",h\xb6lp,"h\xb6lp"}), "Parse"); is ($csv->keep_meta_info (11), 11, "keep meta on out"); ok ($csv->combine (@f), "combine"); is ($csv->string, qq{1,,"", ," ",f,"g","h""h",h\xb6lp,"h\xb6lp"}, "string 11"); ok ($csv->parse (qq{1,,"1193-1",4,"",,6}), "parse under 11"); ok ($csv->combine ($csv->fields), "combine"); is ($csv->string, qq{1,,"1193-1",4,"",,6}, "return same"); } { my $csv = Text::CSV->new ({ keep_meta_info => 1, eol => "\r" }); ok (1, "parse () tests - With flags"); is ( $csv->meta_info, undef, "meta_info before parse"); ok (!$csv->parse (), "Missing arguments"); is ( $csv->meta_info, undef, "meta_info after failing parse"); crnlsp ($csv); ok (!$csv->parse ('"abc'), "Missing closing \""); ok (!$csv->parse ('ab"c'), "\" outside of \"'s"); ok (!$csv->parse ('"ab"c"'), "Bad character sequence"); ok (!$csv->parse (qq("abc\nc")), "Bad character (NL)"); ok (!$csv->status (), "Wrong status ()"); ok ( $csv->parse ('","'), "comma - parse ()"); is ( scalar $csv->fields (), 1, "comma - fields () - count"); is ( scalar $csv->meta_info (), 1, "comma - meta_info () - count"); is (($csv->fields ())[0], ",", "comma - fields () - content"); is (($csv->meta_info ())[0], 1, "comma - meta_info () - content"); ok ( $csv->parse (qq("","I said,\t""Hi!""",)), "Hi! - parse ()"); is ( scalar $csv->fields (), 3, "Hi! - fields () - count"); is ( scalar $csv->meta_info (), 3, "Hi! - meta_info () - count"); is (($csv->fields ())[0], "", "Hi! - fields () - field 1"); is (($csv->meta_info ())[0], 1, "Hi! - meta_info () - field 1"); is (($csv->fields ())[1], qq(I said,\t"Hi!"), "Hi! - fields () - field 2"); is (($csv->meta_info ())[1], 1, "Hi! - meta_info () - field 2"); is (($csv->fields ())[2], "", "Hi! - fields () - field 3"); is (($csv->meta_info ())[2], 0, "Hi! - meta_info () - field 3"); } { my $csv = Text::CSV->new ({ keep_meta_info => 1, binary => 1 }); is ($csv->is_quoted (0), undef, "is_quoted () before parse"); is ($csv->is_binary (0), undef, "is_binary () before parse"); is ($csv->is_missing (0), undef, "is_missing () before parse"); my $bintxt = chr ($] < 5.006 ? 0xbf : 0x20ac); ok ( $csv->parse (qq{,"1","a\rb",0,"a\nb",1,\x8e,"a\r\n","$bintxt","",}), "parse () - mixed quoted/binary"); is (scalar $csv->fields, 11, "fields () - count"); my @fflg; ok (@fflg = $csv->meta_info, "meta_info ()"); is (scalar @fflg, 11, "meta_info () - count"); is_deeply ([ @fflg ], [ 0, 1, 3, 0, 3, 0, 2, 3, 3, 1, 0 ], "meta_info ()"); is ($csv->is_quoted (0), 0, "fflag 0 - not quoted"); is ($csv->is_binary (0), 0, "fflag 0 - not binary"); is ($csv->is_missing (0), 0, "fflag 0 - not missig"); is ($csv->is_quoted (2), 1, "fflag 2 - quoted"); is ($csv->is_binary (2), 1, "fflag 2 - binary"); is ($csv->is_missing (2), 0, "fflag 2 - not missing"); is ($csv->is_quoted (6), 0, "fflag 5 - not quoted"); is ($csv->is_binary (6), 1, "fflag 5 - binary"); is ($csv->is_missing (6), 0, "fflag 5 - not missing"); is ($csv->is_quoted (-1), undef, "fflag -1 - undefined"); is ($csv->is_binary (-8), undef, "fflag -8 - undefined"); is ($csv->is_missing (-8), undef, "fflag -8 - undefined"); is ($csv->is_quoted (21), undef, "fflag 21 - undefined"); is ($csv->is_binary (98), undef, "fflag 98 - undefined"); is ($csv->is_missing (98), 1, "fflag 98 - missing"); } { my $csv = Text::CSV->new ({ escape_char => "+" }); ok ( $csv->parse ("+"), "ESC"); ok (!$csv->parse ("++"), "ESC ESC"); ok ( $csv->parse ("+ "), "ESC Space"); ok ( $csv->parse ("+0"), "ESC NUL"); ok ( $csv->parse ("+\n"), "ESC NL"); ok (!$csv->parse ("+\r"), "ESC CR"); ok ( $csv->parse ("+\r\n"), "ESC CR NL"); ok (!$csv->parse (qq{"+"}), "Quo ESC"); ok (!$csv->parse (qq{""+}), "Quo ESC >"); ok ( $csv->parse (qq{"++"}), "Quo ESC ESC"); ok (!$csv->parse (qq{"+ "}), "Quo ESC Space"); ok ( $csv->parse (qq{"+0"}), "Quo ESC NUL"); ok (!$csv->parse (qq{"+\n"}), "Quo ESC NL"); ok (!$csv->parse (qq{"+\r"}), "Quo ESC CR"); ok (!$csv->parse (qq{"+\r\n"}), "Quo ESC CR NL"); } { my $csv = Text::CSV->new ({ escape_char => "+", binary => 1 }); ok ( $csv->parse ("+"), "ESC"); ok (!$csv->parse ("++"), "ESC ESC"); ok ( $csv->parse ("+ "), "ESC Space"); ok ( $csv->parse ("+0"), "ESC NUL"); ok ( $csv->parse ("+\n"), "ESC NL"); ok (!$csv->parse ("+\r"), "ESC CR"); ok ( $csv->parse ("+\r\n"), "ESC CR NL"); ok (!$csv->parse (qq{"+"}), "Quo ESC"); ok ( $csv->parse (qq{"++"}), "Quo ESC ESC"); ok (!$csv->parse (qq{"+ "}), "Quo ESC Space"); ok ( $csv->parse (qq{"+0"}), "Quo ESC NUL"); ok (!$csv->parse (qq{"+\n"}), "Quo ESC NL"); ok (!$csv->parse (qq{"+\r"}), "Quo ESC CR"); ok (!$csv->parse (qq{"+\r\n"}), "Quo ESC CR NL"); } ok (1, "Testing always_quote"); { ok (my $csv = Text::CSV->new ({ always_quote => 0 }), "new (aq => 0)"); ok ($csv->combine (1..3), "Combine"); is ($csv->string, q{1,2,3}, "String"); is ($csv->always_quote, 0, "Attr 0"); ok ($csv->always_quote (1), "Attr 1"); ok ($csv->combine (1..3), "Combine"); is ($csv->string, q{"1","2","3"}, "String"); is ($csv->always_quote, 1, "Attr 1"); is ($csv->always_quote (0), 0, "Attr 0"); ok ($csv->combine (1..3), "Combine"); is ($csv->string, q{1,2,3}, "String"); is ($csv->always_quote, 0, "Attr 0"); } ok (1, "Testing quote_space"); { ok (my $csv = Text::CSV->new ({ quote_space => 1 }), "new (qs => 1)"); ok ($csv->combine (1, " ", 3), "Combine"); is ($csv->string, q{1," ",3}, "String"); is ($csv->quote_space, 1, "Attr 1"); is ($csv->quote_space (0), 0, "Attr 0"); ok ($csv->combine (1, " ", 3), "Combine"); is ($csv->string, q{1, ,3}, "String"); is ($csv->quote_space, 0, "Attr 0"); is ($csv->quote_space (1), 1, "Attr 1"); ok ($csv->combine (1, " ", 3), "Combine"); is ($csv->string, q{1," ",3}, "String"); is ($csv->quote_space, 1, "Attr 1"); } ok (1, "Testing quote_empty"); { ok (my $csv = Text::CSV->new (), "new (default)"); is ($csv->quote_empty, 0, "default = 0"); ok ($csv->combine (1, undef, "", " ", 2), "combine qe = 0"); is ($csv->string, qq{1,,," ",2}, "string"); is ($csv->quote_empty (1), 1, "enable quote_empty"); ok ($csv->combine (1, undef, "", " ", 2), "combine qe = 1"); is ($csv->string, qq{1,,""," ",2}, "string"); } # https://rt.cpan.org/Public/Bug/Display.html?id=109097 ok (1, "Testing quote_char as undef"); { my $csv = Text::CSV->new ({ quote_char => undef }); is ($csv->escape_char, '"', "Escape Char defaults to double quotes"); ok ($csv->combine ('space here', '"quoted"', '"quoted and spaces"'), "Combine"); is ($csv->string, q{space here,""quoted"",""quoted and spaces""}, "String"); } Text-CSV-2.06/t/22_scalario.t0000644000175100017510000001434114760113543015721 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; # use warnings; $| = 1; use Config; use Test::More; BEGIN { unless (exists $Config{useperlio} && defined $Config{useperlio} && $] >= 5.008 && # perlio was experimental in 5.6.2, but not reliable $Config{useperlio} eq "define") { plan skip_all => "No reliable perlIO available"; } else { plan tests => 136; } } BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } $/ = "\n"; $\ = undef; my $io; my $io_str = ""; my $csv = Text::CSV->new (); open $io, ">", \$io_str or die "IO: $!"; ok (!$csv->print ($io, ["abc", "def\007", "ghi"]), "print bad character"); close $io; for ( [ 1, 1, 1, '""' ], [ 2, 1, 1, '', '' ], [ 3, 1, 0, '', 'I said, "Hi!"', '' ], [ 4, 1, 0, '"', 'abc' ], [ 5, 1, 0, 'abc', '"' ], [ 6, 1, 1, 'abc', 'def', 'ghi' ], [ 7, 1, 1, "abc\tdef", 'ghi' ], [ 8, 1, 0, '"abc' ], [ 9, 1, 0, 'ab"c' ], [ 10, 1, 0, '"ab"c"' ], [ 11, 0, 0, qq("abc\nc") ], [ 12, 1, 1, q(","), ',' ], [ 13, 1, 0, qq("","I said,\t""Hi!""",""), '', qq(I said,\t"Hi!"), '' ], ) { my ($tst, $validp, $validg, @arg, $row) = @$_; open $io, ">", \$io_str or die "IO: $!"; is ($csv->print ($io, \@arg), $validp||"", "$tst - print ()"); close $io; open $io, ">", \$io_str or die "IO: $!"; print $io join ",", @arg; close $io; open $io, "<", \$io_str or die "IO: $!"; $row = $csv->getline ($io); unless ($validg) { is ($row, undef, "$tst - false getline ()"); next; } ok ($row, "$tst - good getline ()"); $tst == 12 and @arg = (",", "", ""); foreach my $a (0 .. $#arg) { (my $exp = $arg[$a]) =~ s/^"(.*)"$/$1/; is ($row->[$a], $exp, "$tst - field $a"); } } # This test because of a problem with DBD::CSV ok (1, "Tests for DBD::CSV"); open $io, ">", \$io_str or die "IO: $!"; $csv->binary (1); $csv->eol ("\r\n"); ok ($csv->print ($io, [ "id", "name" ]), "Bad character"); ok ($csv->print ($io, [ 1, "Alligator Descartes" ]), "Name 1"); ok ($csv->print ($io, [ "3", "Jochen Wiedmann" ]), "Name 2"); ok ($csv->print ($io, [ 2, "Tim Bunce" ]), "Name 3"); ok ($csv->print ($io, [ " 4", "Andreas König" ]), "Name 4"); ok ($csv->print ($io, [ 5 ]), "Name 5"); close $io; my $expected = <<"CONTENTS"; id,name\015 1,"Alligator Descartes"\015 3,"Jochen Wiedmann"\015 2,"Tim Bunce"\015 " 4","Andreas König"\015 5\015 CONTENTS open $io, "<", \$io_str or die "IO: $!"; my $content = do { local $/; <$io> }; close $io; is ($content, $expected, "Content"); open $io, ">", \$io_str or die "IO: $!"; print $io $content; close $io; open $io, "<", \$io_str or die "IO: $!"; my $fields; print "# Retrieving data\n"; for (0 .. 5) { ok ($fields = $csv->getline ($io), "Fetch field $_"); is ($csv->eof, "", "EOF"); print "# Row $_: $fields (@$fields)\n"; } is ($csv->getline ($io), undef, "Fetch field 6"); is ($csv->eof, 1, "EOF"); { ok (my $csv = Text::CSV->new ({ binary => 1, eol => "\n" }), "new csv"); my ($out1, $out2, @fld, $fh) = ("", "", qw( 1 aa 3.14 ahhrg )); open $fh, ">", \$out1 or die "IO: $!"; ok ($csv->print ($fh, \@fld), "Add line $_") for 1..3; close $fh; $csv->bind_columns (\(@fld)); open $fh, ">", \$out2 or die "IO: $!"; ok ($csv->print ($fh, \@fld), "Add line $_") for 1..3; close $fh; is ($out2, $out1, "ignoring bound columns"); $out2 = ""; open $fh, ">", \$out2 or die "IO: $!"; ok ($csv->print ($fh, undef), "Add line $_") for 1..3; close $fh; is ($out2, $out1, "using bound columns"); } # Edge cases for ([ 1, 1, 0, "\n" ], [ 2, 1, 0, "+\n" ], [ 3, 1, 0, "+" ], [ 4, 0, 2021, qq{"+"\n} ], [ 5, 0, 2025, qq{"+\n} ], [ 6, 0, 2011, qq{""+\n} ], [ 7, 0, 2027, qq{"+"} ], [ 8, 0, 2024, qq{"+} ], [ 9, 0, 2011, qq{""+} ], [ 10, 1, 0, "\r" ], [ 11, 0, 2031, "\r\b" ], [ 12, 0, 2032, "+\r\b" ], [ 13, 0, 2032, "+\r\b+" ], [ 14, 0, 2022, qq{"\r"} ], [ 15, 0, 2022, qq{"\r\b" } ], [ 16, 0, 2022, qq{"\r\b"\t} ], [ 17, 0, 2025, qq{"+\r\b"} ], [ 18, 0, 2025, qq{"+\r\b+"} ], [ 19, 0, 2022, qq{"\r"\b} ], [ 20, 0, 2022, qq{"\r\b"\b} ], [ 21, 0, 2025, qq{"+\r\b"\b} ], [ 22, 0, 2025, qq{"+\r\b+"\b} ], [ 23, 0, 2037, qq{\b} ], [ 24, 0, 2026, qq{"\b"} ], ) { my ($tst, $valid, $err, $str) = @$_; $csv = Text::CSV->new ({ escape_char => "+" }); $io_str = $str; open $io, "<", \$io_str or die "IO: $!"; binmode $io; my $row = $csv->getline ($io); close $io; my @err = $csv->error_diag; my $sstr = _readable ($str); ok ($valid ? $row : !$row, "$tst - getline ESC +, '$sstr'"); is ($err[0], $err, "Error expected $err"); } { ok (my $csv = Text::CSV->new, "new for sep="); open my $fh, "<", \qq{sep=;\n"a b";3\n} or die "IO: $!"; is_deeply ($csv->getline_all ($fh), [["a b", 3]], "valid sep="); is (($csv->error_diag)[0], 2012, "EOF"); } { ok (my $csv = Text::CSV->new, "new for sep="); open my $fh, "<", \qq{sep=;\n"a b",3\n} or die "IO: $!"; is_deeply (eval { $csv->getline_all ($fh); }, [], "invalid sep="); is (($csv->error_diag)[0], 2023, "error"); } { ok (my $csv = Text::CSV->new, "new for sep="); open my $fh, "<", \qq{sep=XX\n"a b"XX3\n} or die "IO: $!"; is_deeply (eval { $csv->getline_all ($fh); }, [["a b", 3]], "multibyte sep="); is (($csv->error_diag)[0], 2012, "error"); } { ok (my $csv = Text::CSV->new, "new for sep="); # To check that it is *only* supported on the first line open my $fh, "<", \qq{sep=;\n"a b";3\nsep=,\n"a b",3\n} or die "IO: $!"; is_deeply ($csv->getline_all ($fh), [["a b","3"],["sep=,"]], "sep= not on 1st line"); is (($csv->error_diag)[0], 2023, "error"); } { ok (my $csv = Text::CSV->new, "new for sep="); my $sep = "#" x 80; open my $fh, "<", \qq{sep=$sep\n"a b",3\n2,3\n} or die "IO: $!"; my $r = $csv->getline_all ($fh); is_deeply ($r, [["sep=$sep"],["a b","3"],[2,3]], "sep= too long"); is (($csv->error_diag)[0], 2012, "EOF"); } Text-CSV-2.06/t/51_utf8.t0000644000175100017510000002107414760113543015015 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use charnames ":full"; use Test::More; $| = 1; BEGIN { $] < 5.008002 and plan skip_all => "UTF8 tests useless in this ancient perl version"; } my @tests; my $ebcdic = ord ("A") == 0xC1; BEGIN { delete $ENV{PERLIO}; my $pu = $ENV{PERL_UNICODE}; $pu = defined $pu && ($pu eq "" || $pu =~ m/[oD]/ || ($pu =~ m/^[0-9]+$/ && $pu & 16)); my $euro_ch = "\x{20ac}"; utf8::encode (my $bytes = $euro_ch); utf8::downgrade (my $bytes_dn = $bytes); utf8::upgrade (my $bytes_up = $bytes); @tests = ( # $test $perlio $data, $encoding $expect_w # ---------------------------- ------------------- ----------- --------- ---------- [ "Unicode default", "", $euro_ch, "utf8", $pu ? "no warn" : "warn" ], [ "Unicode binmode", "[binmode]", $euro_ch, "utf8", "warn", ], [ "Unicode :utf8", ":utf8", $euro_ch, "utf8", "no warn", ], [ "Unicode :encoding(utf8)", ":encoding(utf8)", $euro_ch, "utf8", "no warn", ], [ "Unicode :encoding(UTF-8)", ":encoding(UTF-8)", $euro_ch, "utf8", "no warn", ], [ "bytes dn default", "", $bytes_dn, "[none]", "no warn", ], [ "bytes dn binmode", "[binmode]", $bytes_dn, "[none]", "no warn", ], [ "bytes dn :utf8", ":utf8", $bytes_dn, "utf8", "no warn", ], [ "bytes dn :encoding(utf8)", ":encoding(utf8)", $bytes_dn, "utf8", "no warn", ], [ "bytes dn :encoding(UTF-8)", ":encoding(UTF-8)", $bytes_dn, "utf8", "no warn", ], [ "bytes up default", "", $bytes_up, "[none]", "no warn", ], [ "bytes up binmode", "[binmode]", $bytes_up, "[none]", "no warn", ], [ "bytes up :utf8", ":utf8", $bytes_up, "utf8", "no warn", ], [ "bytes up :encoding(utf8)", ":encoding(utf8)", $bytes_up, "utf8", "no warn", ], [ "bytes up :encoding(UTF-8)", ":encoding(UTF-8)", $bytes_up, "utf8", "no warn", ], ); my $builder = Test::More->builder; binmode $builder->output, ":encoding(utf8)"; binmode $builder->failure_output, ":encoding(utf8)"; binmode $builder->todo_output, ":encoding(utf8)"; plan tests => 11 + 6 * @tests + 4 * 22 + 6 + 10 + 2; } BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", ("csv"); plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } sub hexify { join " ", map { sprintf "%02x", $_ } unpack "C*", @_ } sub warned { length ($_[0]) ? "warn" : "no warn" } my $csv = Text::CSV->new ({ binary => 1, auto_diag => 1 }); for (@tests) { my ($test, $perlio, $data, $enc, $expect_w) = @$_; my $expect = qq{"$data"}; $enc eq "utf8" and utf8::encode ($expect); my ($p_out, $p_fh) = (""); my ($c_out, $c_fh) = (""); if ($perlio eq "[binmode]") { open $p_fh, ">", \$p_out or die "IO: $!\n"; binmode $p_fh; open $c_fh, ">", \$c_out or die "IO: $!\n"; binmode $c_fh; } else { open $p_fh, ">$perlio", \$p_out or die "IO: $!\n"; open $c_fh, ">$perlio", \$c_out or die "IO: $!\n"; } my $p_warn = ""; { local $SIG{__WARN__} = sub { $p_warn .= join "", @_ }; ok ((print $p_fh qq{"$data"}), "$test perl print"); close $p_fh; } my $c_warn = ""; { local $SIG{__WARN__} = sub { $c_warn .= join "", @_ }; ok ($csv->print ($c_fh, [ $data ]), "$test csv print"); close $c_fh; } is (hexify ($c_out), hexify ($p_out), "$test against Perl"); is (hexify ($c_out), hexify ($expect), "$test against expected"); is (warned ($c_warn), warned ($p_warn), "$test against Perl warning"); is (warned ($c_warn), $expect_w, "$test against expected warning"); } # Test automatic upgrades for valid UTF-8 { my $blob = pack "C*", 0..255; $blob =~ tr/",//d; # perl-5.10.x has buggy SvCUR () on blob $] >= 5.010000 && $] <= 5.012001 and $blob =~ tr/\0//d; my $b1 = "\x{b6}"; # PILCROW SIGN in ISO-8859-1 my $b2 = $ebcdic # ARABIC COMMA in UTF-8 ? "\x{b8}\x{57}\x{53}" : "\x{d8}\x{8c}"; my @data = ( qq[1,aap,3], # No diac qq[1,a${b1}p,3], # Single-byte qq[1,a${b2}p,3], # Multi-byte qq[1,"$blob",3], # Binary shit ) x 2; my $data = join "\n" => @data; my @expect = ("aap", "a\266p", "a\x{060c}p", $blob) x 2; my $csv = Text::CSV->new ({ binary => 1, auto_diag => 1 }); foreach my $bc (undef, 3) { my @read; # Using getline () open my $fh, "<", \$data or die "IO: $!\n"; binmode $fh; $bc and $csv->bind_columns (\my ($f1, $f2, $f3)); is (scalar $csv->bind_columns, $bc, "Columns_bound?"); while (my $row = $csv->getline ($fh)) { push @read, $bc ? $f2 : $row->[1]; } close $fh; is_deeply (\@read, \@expect, "Set and reset UTF-8 ".($bc?"no bind":"bind_columns")); is_deeply ([ map { utf8::is_utf8 ($_) } @read ], [ "", "", 1, "", "", "", 1, "" ], "UTF8 flags"); # Using parse () @read = map { $csv->parse ($_); $bc ? $f2 : ($csv->fields)[1]; } @data; is_deeply (\@read, \@expect, "Set and reset UTF-8 ".($bc?"no bind":"bind_columns")); is_deeply ([ map { utf8::is_utf8 ($_) } @read ], [ "", "", 1, "", "", "", 1, "" ], "UTF8 flags"); } } my $sep = "\x{2665}";#"\N{INVISIBLE SEPARATOR}"; my $quo = "\x{2661}";#"\N{FULLWIDTH QUOTATION MARK}"; foreach my $new (0, 1, 2, 3) { my %attr = ( binary => 1, always_quote => 1, );; $new & 1 and $attr{sep} = $sep; $new & 2 and $attr{quote} = $quo; my $csv = Text::CSV->new (\%attr); my $s = $attr{sep} || ','; my $q = $attr{quote} || '"'; note ("Test SEP: '$s', QUO: '$q'") if $Test::More::VERSION > 0.81; is ($csv->sep, $s, "sep"); is ($csv->quote, $q, "quote"); foreach my $data ( [ 1, 2 ], [ "\N{EURO SIGN}", "\N{SNOWMAN}" ], # [ $sep, $quo ], ) { my $exp8 = join $s => map { qq{$q$_$q} } @$data; utf8::encode (my $expb = $exp8); my @exp = ($expb, $exp8); ok ($csv->combine (@$data), "combine"); my $x = $csv->string; is ($csv->string, $exp8, "string"); open my $fh, ">:encoding(utf8)", \(my $out = "") or die "IO: $!\n"; ok ($csv->print ($fh, $data), "print with UTF8 sep"); close $fh; is ($out, $expb, "output"); ok ($csv->parse ($expb), "parse"); is_deeply ([ $csv->fields ], $data, "fields"); open $fh, "<", \$expb or die "IO: $!\n"; binmode $fh; is_deeply ($csv->getline ($fh), $data, "data from getline ()"); close $fh; $expb =~ tr/"//d; ok ($csv->parse ($expb), "parse"); is_deeply ([ $csv->fields ], $data, "fields"); open $fh, "<", \$expb or die "IO: $!\n"; binmode $fh; is_deeply ($csv->getline ($fh), $data, "data from getline ()"); close $fh; } } { my $h = "\N{WHITE HEART SUIT}"; my $H = "\N{BLACK HEART SUIT}"; my $str = "${h}I$h$H${h}L\"${h}ve$h$H${h}Perl$h"; utf8::encode ($str); ok (my $aoa = csv (in => \$str, sep => $H, quote => $h), "Hearts"); is_deeply ($aoa, [[ "I", "L${h}ve", "Perl"]], "I $H Perl"); ok (my $csv = Text::CSV->new ({ binary => 1, sep => $H, quote => $h }), "new hearts"); ok ($csv->combine (@{$aoa->[0]}), "combine"); ok ($str = $csv->string, "string"); utf8::decode ($str); is ($str, "I${H}${h}L\"${h}ve${h}${H}Perl", "Correct quotation"); } # Tests pulled from tests in Raku { my $csv = Text::CSV->new ({ binary => 1, auto_diag => 1 }); my $h = pack "C*", 224, 34, 204, 182; ok ($csv->combine (1, $h, 3)); ok (my $s = $csv->string, "String"); my $b = $h; utf8::encode ($b); ok ($csv->combine (1, $b, 3)); ok ($s = $csv->string, "String"); } { my $h = qq{\x{10fffd}xE0"}; #" my $b = $h; ok ($csv->combine (1, $b, 3)); ok (my $s = $csv->string, "String"); $b = $h; utf8::encode ($b); ok ($csv->combine (1, $b, 3)); ok ($s = $csv->string, "String"); $b = $h; utf8::encode ($b); ok ($csv->combine (1, $b, 3)); ok ($s = $csv->string, "String"); } { my $file = "Eric,\N{LATIN CAPITAL LETTER E WITH ACUTE}RIC\n"; utf8::encode ($file); open my $fh, "<", \$file or die $!; my $csv = Text::CSV->new ({ binary => 1, auto_diag => 2 }); is_deeply ( [ $csv->header ($fh) ], [ "eric", "\N{LATIN SMALL LETTER E WITH ACUTE}ric" ], "Lowercase unicode header"); } { my $file = "Eric,\N{LATIN SMALL LETTER E WITH ACUTE}ric\n"; utf8::encode ($file); open my $fh, "<", \$file or die $!; my $csv = Text::CSV->new ({ binary => 1, auto_diag => 2 }); is_deeply ( [ $csv->header ($fh, { munge => "uc" }) ], [ "ERIC", "\N{LATIN CAPITAL LETTER E WITH ACUTE}RIC" ], "Uppercase unicode header"); } Text-CSV-2.06/t/60_samples.t0000644000175100017510000000147114760113543015572 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More tests => 8; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", (); plan skip_all => "Cannot load Text::CSV" if $@; } # Some assorted examples from the modules history # "Pavel Kotala" { my $csv = Text::CSV->new ({ quote_char => '"', escape_char => '\\', sep_char => ';', binary => 1, }); ok ($csv, "new (\", \\\\, ;, 1)"); my @list = ("c:\\winnt", "text"); ok ($csv->combine (@list), "combine ()"); my $line = $csv->string; ok ($line, "string ()"); ok ($csv->parse ($line), "parse ()"); my @olist = $csv->fields; is (scalar @list, scalar @olist, "field count"); is ($list[0], $olist[0], "field 1"); is ($list[1], $olist[1], "field 2"); } Text-CSV-2.06/t/55_combi.t0000644000175100017510000001136714760113543015230 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More tests => 25119; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; require_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } my $csv = Text::CSV->new ({ binary => 1 }); my @attrib = qw( quote_char escape_char sep_char ); my @special = ('"', "'", ",", ";", "\t", "\\", "~"); # Add undef, once we can return undef my @input = ( "", 1, "1", 1.4, "1.4", " - 1,4", "1+2=3", "' ain't it great '", '"foo"! said the `bär', q{the ~ in "0 \0 this l'ne is \r ; or "'"} ); my $ninput = scalar @input; my $string = join "=", "", @input, ""; my %fail; ok (1, "-- qc ec sc ac"); sub combi { my %attr = @_; my $combi = join " ", "--", map { sprintf "%6s", _readable $attr{$_} } @attrib, "always_quote"; ok (1, $combi); # use legal non-special characters is ($csv->allow_whitespace (0), 0, "Reset allow WS"); is ($csv->sep_char ("\x03"), "\x03", "Reset sep"); is ($csv->quote_char ("\x0b"), "\x0b", "Reset quo"); is ($csv->escape_char ("\x0c"), "\x0c", "Reset esc"); # Set the attributes and check failure my %state; foreach my $attr (sort keys %attr) { eval { $csv->$attr ($attr{$attr}); }; $@ or next; $state{0 + $csv->error_diag} ||= $@; } if ($attr{sep_char} eq $attr{quote_char} || $attr{sep_char} eq $attr{escape_char}) { ok (exists $state{1001}, "Illegal combo"); like ($state{1001}, qr{sep_char is equal to}, "Illegal combo"); } else { ok (!exists $state{1001}, "No char conflict"); } if (!exists $state{1001} and $attr{sep_char} =~ m/[\r\n]/ || $attr{quote_char} =~ m/[\r\n]/ || $attr{escape_char} =~ m/[\r\n]/ ) { ok (exists $state{1003}, "Special contains eol"); like ($state{1003}, qr{in main attr not}, "Illegal combo"); } if ($attr{allow_whitespace} and $attr{quote_char} =~ m/^[ \t]/ || $attr{escape_char} =~ m/^[ \t]/ ) { #diag (join " -> ** " => $combi, join ", " => sort %state); ok (exists $state{1002}, "Illegal combo under allow_whitespace"); like ($state{1002}, qr{allow_whitespace with}, "Illegal combo"); } %state and return; # Check success is ($csv->$_ (), $attr{$_}, "check $_") for sort keys %attr; my $ret = $csv->combine (@input); ok ($ret, "combine"); ok (my $str = $csv->string, "string"); SKIP: { ok (my $ok = $csv->parse ($str), "parse"); unless ($ok) { $fail{parse}{$combi} = $csv->error_input; skip "parse () failed", 3; } ok (my @ret = $csv->fields, "fields"); unless (@ret) { $fail{fields}{$combi} = $csv->error_input; skip "fields () failed", 2; } is (scalar @ret, $ninput, "$ninput fields"); unless (scalar @ret == $ninput) { $fail{'$#fields'}{$combi} = $str; skip "# fields failed", 1; } my $ret = join "=", "", @ret, ""; is ($ret, $string, "content"); } } # combi foreach my $aw (0, 1) { foreach my $aq (0, 1) { foreach my $qc (@special) { foreach my $ec (@special, "+") { foreach my $sc (@special, "\0") { combi ( sep_char => $sc, quote_char => $qc, escape_char => $ec, always_quote => $aq, allow_whitespace => $aw, ); } } } } } foreach my $fail (sort keys %fail) { print STDERR "Failed combi for $fail ():\n", "-- qc ec sc ac\n"; foreach my $combi (sort keys %{$fail{$fail}}) { printf STDERR "%-20s - %s\n", map { _readable $_ } $combi, $fail{$fail}{$combi}; } } { my $err = ""; local $SIG{__WARN__} = sub { $err = shift; }; is (Text::CSV->new ({ sep => ",", quote => ",", auto_diag => 1 }), undef, "New (illegal combo + auto_diag)"); like ($err, qr{\bERROR: 1001 - INI -}, "Error message"); $err = ""; ok (my $csv = Text::CSV->new ({ auto_diag => 1 }), "new auto_diag"); eval { $csv->sep ('"'); }; like ($err, qr{\bERROR: 1001 - INI -}, "Error message"); is ($csv->sep_char (), '"', "sep changed anyway"); } { ok (my $csv = Text::CSV->new ({ binary => 1 }), "New CSV default"); ok ($csv->combine ("=\x00="), "combine =\\x00="); is ($csv->string, qq{"="0="}, "string"); } { ok (my $csv = Text::CSV->new ({ binary => 1, escape_null => 0 }), "New CSV no escape_null"); ok ($csv->combine ("=\x00="), "combine =\\x00="); is ($csv->string, qq{"=\0="}, "string"); } { ok (my $csv = Text::CSV->new ({ binary => 1, escape_char => "" }), "New CSV no escape"); ok ($csv->combine ("=\x00="), "combine =\\x00="); is ($csv->string, qq{"=\0="}, "string"); } { ok (my $csv = Text::CSV->new ({ binary => 1, escape_char => "", escape_null => 0 }), "New CSV no escape no escape_null"); ok ($csv->combine ("=\x00="), "combine =\\x00="); is ($csv->string, qq{"=\0="}, "string"); } 1; Text-CSV-2.06/t/78_fragment.t0000644000175100017510000000757214760113543015752 0ustar ishigakiishigaki#!/pro/bin/perl use strict; $^W = 1; $| = 1; use Config; use Test::More; BEGIN { unless (exists $Config{useperlio} && defined $Config{useperlio} && $] >= 5.008 && # perlio was experimental in 5.6.2, but not reliable $Config{useperlio} eq "define") { plan skip_all => "No reliable perlIO available"; } else { plan tests => 38; } } BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; } use Text::CSV; my $csv = Text::CSV->new (); my @test = ( "row=1" => [[ 11,12,13,14,15,16,17,18,19 ]], "row=2-3" => [[ 21,22,23,24,25,26,27,28,29 ], [ 31,32,33,34,35,36,37,38,39 ]], "row=2;4;6" => [[ 21,22,23,24,25,26,27,28,29 ], [ 41,42,43,44,45,46,47,48,49 ], [ 61,62,63,64,65,66,67,68,69 ]], "row=1-2;4;6-*" => [[ 11,12,13,14,15,16,17,18,19 ], [ 21,22,23,24,25,26,27,28,29 ], [ 41,42,43,44,45,46,47,48,49 ], [ 61,62,63,64,65,66,67,68,69 ], [ 71,72,73,74,75,76,77,78,79 ], [ 81,82,83,84,85,86,87,88,89 ], [ 91,92,93,94,95,96,97,98,99 ]], "col=1" => [[11],[21],[31],[41],[51],[61],[71],[81],[91]], "col=2-3" => [[12,13],[22,23],[32,33],[42,43],[52,53], [62,63],[72,73],[82,83],[92,93]], "col=2;4;6" => [[12,14,16],[22,24,26],[32,34,36],[42,44,46],[52,54,56], [62,64,66],[72,74,76],[82,84,86],[92,94,96]], "col=1-2;4;6-*" => [[11,12,14,16,17,18,19], [21,22,24,26,27,28,29], [31,32,34,36,37,38,39], [41,42,44,46,47,48,49], [51,52,54,56,57,58,59], [61,62,64,66,67,68,69], [71,72,74,76,77,78,79], [81,82,84,86,87,88,89], [91,92,94,96,97,98,99]], #cell=R,C "cell=7,7" => [[ 77 ]], "cell=7,7-8,8" => [[ 77,78 ], [ 87,88 ]], "cell=7,7-*,8" => [[ 77,78 ], [ 87,88 ], [ 97,98 ]], "cell=7,7-8,*" => [[ 77,78,79 ], [ 87,88,89 ]], "cell=7,7-*,*" => [[ 77,78,79 ], [ 87,88,89 ], [ 97,98,99 ]], "cell=7,7;7,8;8,7;8,8" => [[ 77,78 ], [ 87,88 ]], "cell=8,8;8,7;7,8;7,7" => [[ 77,78 ], [ 87,88 ]], "cell=1,1-2,2;3,3-4,4" => [ [11,12], [21,22], [33,34], [43,44]], "cell=1,1-3,3;2,3-4,4" => [ [11,12,13], [21,22,23,24], [31,32,33,34], [43,44]], "cell=1,1-3,3;2,2-4,4;2,3;4,2" => [ [11,12,13], [21,22,23,24], [31,32,33,34], [42,43,44]], "cell=1,1-2,2;3,3-4,4;1,4;4,1" => [ [11,12, 14], [21,22], [33,34], [41, 43,44]], ); my $todo = ""; my $data = join "" => ; while (my ($spec, $expect) = splice @test, 0, 2) { open my $io, "<", \$data or die "IO: $!\n"; my $aoa = $csv->fragment ($io, $spec); is_deeply ($aoa, $expect, "${todo}Fragment $spec"); } { $csv->column_names ("c3", "c4"); open my $io, "<", \$data or die "IO: $!\n"; is_deeply ($csv->fragment ($io, "cell=3,2-4,3"), [ { c3 => 32, c4 => 33 }, { c3 => 42, c4 => 43 }], "Fragment to AoH"); } { $csv->column_names ("C1", "C2"); open my $io, "<", \$data or die "IO: $!\n"; is_deeply ($csv->fragment ($io, "row=3"), [ { C1 => 31, C2 => 32 }], "Fragment row with headers to AoH"); } { $csv->column_names ("C1"); open my $io, "<", \$data or die "IO: $!\n"; is_deeply ($csv->fragment ($io, "col=2"), [ map +{ C1 => $_.2 } => 1 .. 9 ], "Fragment col with headers to AoH"); } $csv->column_names (undef); foreach my $spec ("col=1;3=2", "col=1,3-2", "col=-3", "col=0", "col=2--5", "col=0-2", "col=2-0", "col=2;;3") { open my $io, "<", \$data or die "IO: $!\n"; my $ref = eval { $csv->fragment ($io, "col=2;3=2"); }; is ($ref, undef, "Bad fragment spec"); is (0 + $csv->error_diag, 2013, "Error in spec"); } #$csv->eol ("\n"); #foreach my $r (1..9){$csv->print(*STDOUT,[map{$r.$_}1..9])} __END__ 11,12,13,14,15,16,17,18,19 21,22,23,24,25,26,27,28,29 31,32,33,34,35,36,37,38,39 41,42,43,44,45,46,47,48,49 51,52,53,54,55,56,57,58,59 61,62,63,64,65,66,67,68,69 71,72,73,74,75,76,77,78,79 81,82,83,84,85,86,87,88,89 91,92,93,94,95,96,97,98,99 Text-CSV-2.06/t/util.pl0000644000175100017510000001310314760113543014741 0ustar ishigakiishigakiuse strict; my %special = ( 9 => "\\t", 10 => "\\n", 13 => "\\r" ); my $ebcdic = ord ("A") == 0xc1; my @ebcdic = (# Convert EBCDIC 2 ASCII 0x00, 0x01, 0x02, 0x03, 0x9c, 0x09, 0x86, 0x7f, 0x97, 0x8d, 0x8e, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x9d, 0x0a, 0x08, 0x87, 0x18, 0x19, 0x92, 0x8f, 0x1c, 0x1d, 0x1e, 0x1f, 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x17, 0x1b, 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x05, 0x06, 0x07, 0x90, 0x91, 0x16, 0x93, 0x94, 0x95, 0x96, 0x04, 0x98, 0x99, 0x9a, 0x9b, 0x14, 0x15, 0x9e, 0x1a, 0x20, 0xa0, 0xe2, 0xe4, 0xe0, 0xe1, 0xe3, 0xe5, 0xe7, 0xf1, 0xa2, 0x2e, 0x3c, 0x28, 0x2b, 0x7c, 0x26, 0xe9, 0xea, 0xeb, 0xe8, 0xed, 0xee, 0xef, 0xec, 0xdf, 0x21, 0x24, 0x2a, 0x29, 0x3b, 0x5e, 0x2d, 0x2f, 0xc2, 0xc4, 0xc0, 0xc1, 0xc3, 0xc5, 0xc7, 0xd1, 0xa6, 0x2c, 0x25, 0x5f, 0x3e, 0x3f, 0xf8, 0xc9, 0xca, 0xcb, 0xc8, 0xcd, 0xce, 0xcf, 0xcc, 0x60, 0x3a, 0x23, 0x40, 0x27, 0x3d, 0x22, 0xd8, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0xab, 0xbb, 0xf0, 0xfd, 0xfe, 0xb1, 0xb0, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, 0x70, 0x71, 0x72, 0xaa, 0xba, 0xe6, 0xb8, 0xc6, 0xa4, 0xb5, 0x7e, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7a, 0xa1, 0xbf, 0xd0, 0x5b, 0xde, 0xae, 0xac, 0xa3, 0xa5, 0xb7, 0xa9, 0xa7, 0xb6, 0xbc, 0xbd, 0xbe, 0xdd, 0xa8, 0xaf, 0x5d, 0xb4, 0xd7, 0x7b, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0xad, 0xf4, 0xf6, 0xf2, 0xf3, 0xf5, 0x7d, 0x4a, 0x4b, 0x4c, 0x4d, 0x4e, 0x4f, 0x50, 0x51, 0x52, 0xb9, 0xfb, 0xfc, 0xf9, 0xfa, 0xff, 0x5c, 0xf7, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5a, 0xb2, 0xd4, 0xd6, 0xd2, 0xd3, 0xd5, 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0xb3, 0xdb, 0xdc, 0xd9, 0xda, 0x9f ); sub _readable { defined $_[0] or return "--undef--"; join "", map { my $cp = ord $_; $ebcdic and $cp = $ebcdic[$cp]; $cp >= 0x20 && $cp <= 0x7e ? $_ : $special{$cp} || sprintf "\\x{%02x}", $cp } split m//, $_[0]; } # _readable sub is_binary { my ($str, $exp, $tst) = @_; if ($str eq $exp) { ok (1, $tst); } else { my ($hs, $he) = map { _readable $_ } $str, $exp; is ($hs, $he, $tst); } } # is_binary # The rest is a modified copy of CORE's t/charset_tools.pl my @utf8_skip = $ebcdic ? ( # This translates a utf-8-encoded byte into how many # bytes the full utf8 character occupies. # 0 1 2 3 4 5 6 7 8 9 A B C D E F 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 0 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 1 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 2 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 3 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 4 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 5 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 6 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 7 -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, # 8 -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, # 9 -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, # A -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, # B -1,-1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, # C 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, # D 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, # E 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 7,13, # F ) : (); # Used for BOM testing *byte_utf8a_to_utf8n = $ebcdic ? sub { # Convert a UTF-8 byte sequence into the platform's native UTF-8 # equivalent, currently only UTF-8 and UTF-EBCDIC. my $string = shift; utf8::is_utf8 ($string) and return $string; my $length = length $string; #diag ($string); #diag ($length); my $out = ""; for (my $i = 0; $i < $length; $i++) { my $byte = ord substr $string, $i, 1; my $byte_count = $utf8_skip[$byte]; #diag ($byte); #diag ($byte_count); $byte_count < 0 and die "Illegal start byte"; ($i + $byte_count) > $length and die "Attempt to read " . ($i + $byte_count - $length) . " beyond end-of-string"; # Just translate UTF-8 invariants directly. if ($byte_count == 1) { $out .= chr utf8::unicode_to_native ($byte); next; } # Otherwise calculate the code point ordinal represented by the # sequence beginning with this byte, using the algorithm adapted from # utf8.c. We absorb each byte in the sequence as we go along my $ord = $byte & (0x1F >> ($byte_count - 2)); my $bytes_remaining = $byte_count - 1; while ($bytes_remaining > 0) { $byte = ord substr $string, ++$i, 1; ($byte & 0xC0) == 0x80 or die sprintf "byte '%X' is not a valid continuation", $byte; $ord = $ord << 6 | ($byte & 0x3f); $bytes_remaining--; } #diag ($byte); #diag ($ord); my $expected_bytes = $ord < 0x00000080 ? 1 : $ord < 0x00000800 ? 2 : $ord < 0x00010000 ? 3 : $ord < 0x00200000 ? 4 : $ord < 0x04000000 ? 5 : $ord < 0x80000000 ? 6 : 7; #: (uv) < UTF8_QUAD_MAX ? 7 : 13 ) # Make sure is not an overlong sequence $byte_count == $expected_bytes or die sprintf "character U+%X should occupy %d bytes, not %d", $ord, $expected_bytes, $byte_count; # Now that we have found the code point the original UTF-8 meant, we # use the native chr function to get its native string equivalent. $out .= chr utf8::unicode_to_native ($ord); } utf8::encode ($out); # Turn off utf8 flag. #diag ($out); return $out; } : sub { return shift }; 1; Text-CSV-2.06/t/91_csv_cb.t0000644000175100017510000002240714760113543015373 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; #use Test::More "no_plan"; use Test::More tests => 82; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", ("csv"); plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } my $tfn = "_91test.csv"; END { -f $tfn and unlink $tfn } my $data = "foo,bar,baz\n". "1,2,3\n". "2,a b,\n"; open my $fh, ">", $tfn or die "$tfn: $!"; print $fh $data; close $fh; my $aoa = [ [qw( foo bar baz )], [ 1, 2, 3 ], [ 2, "a b", "" ], ]; my $aoh = [ { foo => 1, bar => 2, baz => 3 }, { foo => 2, bar => "a b", baz => "" }, ]; for (qw( after_in on_in before_out )) { is_deeply (csv (in => $tfn, $_ => sub {}), $aoa, "callback $_ on AOA with empty sub"); is_deeply (csv (in => $tfn, callbacks => { $_ => sub {} }), $aoa, "callback $_ on AOA with empty sub"); } is_deeply (csv (in => $tfn, after_in => sub {}, callbacks => { on_in => sub {} }), $aoa, "callback after_in and on_in on AOA"); for (qw( after_in on_in before_out )) { is_deeply (csv (in => $tfn, headers => "auto", $_ => sub {}), $aoh, "callback $_ on AOH with empty sub"); is_deeply (csv (in => $tfn, headers => "auto", callbacks => { $_ => sub {} }), $aoh, "callback $_ on AOH with empty sub"); } is_deeply (csv (in => $tfn, headers => "auto", after_in => sub {}, callbacks => { on_in => sub {} }), $aoh, "callback after_in and on_in on AOH"); is_deeply (csv (in => $tfn, after_in => sub { push @{$_[1]}, "A" }), [ [qw( foo bar baz A )], [ 1, 2, 3, "A" ], [ 2, "a b", "", "A" ], ], "AOA ith after_in callback"); is_deeply (csv (in => $tfn, headers => "auto", after_in => sub { $_[1]{baz} = "A" }), [ { foo => 1, bar => 2, baz => "A" }, { foo => 2, bar => "a b", baz => "A" }, ], "AOH with after_in callback"); is_deeply (csv (in => $tfn, filter => { 2 => sub { /a/ }}), [ [qw( foo bar baz )], [ 2, "a b", "" ], ], "AOA with filter on col 2"); is_deeply (csv (in => $tfn, filter => { 2 => sub { /a/ }, 1 => sub { length > 1 }}), [ [qw( foo bar baz )], ], "AOA with filter on col 1 and 2"); is_deeply (csv (in => $tfn, filter => { foo => sub { $_ > 1 }}), [ { foo => 2, bar => "a b", baz => "" }, ], "AOH with filter on column name"); SKIP: { $] < 5.008001 and skip "No HOH/xx support in $]", 3; is_deeply (csv (in => $tfn, headers => "lc"), [ { foo => 1, bar => 2, baz => 3 }, { foo => 2, bar => "a b", baz => "" }], "AOH with lc headers"); is_deeply (csv (in => $tfn, headers => "uc"), [ { FOO => 1, BAR => 2, BAZ => 3 }, { FOO => 2, BAR => "a b", BAZ => "" }], "AOH with lc headers"); is_deeply (csv (in => $tfn, headers => sub { lcfirst uc $_[0] }), [ { fOO => 1, bAR => 2, bAZ => 3 }, { fOO => 2, bAR => "a b", bAZ => "" }], "AOH with mangled headers"); } SKIP: { $] < 5.008001 and skip "No BOM support in $]", 1; is_deeply (csv (in => $tfn, munge => { bar => "boo" }), [{ baz => 3, boo => 2, foo => 1 }, { baz => "", boo => "a b", foo => 2 }], "Munge with hash"); } open $fh, ">>", $tfn or die "$tfn: $!"; print $fh <<"EOD"; 3,3,3 4,5,6 5,7,9 6,9,12 7,11,15 8,13,18 EOD close $fh; is_deeply (csv (in => $tfn, filter => { foo => sub { $_ > 2 && $_[1][2] - $_[1][1] < 4 }}), [ { foo => 3, bar => 3, baz => 3 }, { foo => 4, bar => 5, baz => 6 }, { foo => 5, bar => 7, baz => 9 }, { foo => 6, bar => 9, baz => 12 }, ], "AOH with filter on column name + on other numbered fields"); is_deeply (csv (in => $tfn, filter => { foo => sub { $_ > 2 && $_{baz} - $_{bar} < 4 }}), [ { foo => 3, bar => 3, baz => 3 }, { foo => 4, bar => 5, baz => 6 }, { foo => 5, bar => 7, baz => 9 }, { foo => 6, bar => 9, baz => 12 }, ], "AOH with filter on column name + on other named fields"); # Check content ref in on_in AOA { my $aoa = csv ( in => $tfn, filter => { 1 => sub { m/^[3-9]/ }}, on_in => sub { is ($_[1][1], 2 * $_[1][0] - 3, "AOA $_[1][0]: b = 2a - 3 \$_[1][]"); }); } # Check content ref in on_in AOH { my $aoa = csv ( in => $tfn, headers => "auto", filter => { foo => sub { m/^[3-9]/ }}, after_parse => sub { is ($_[1]{bar}, 2 * $_[1]{foo} - 3, "AOH $_[1]{foo}: b = 2a - 3 \$_[1]{}"); }); } # Check content ref in on_in AOH with aliases %_ SKIP: { $] < 5.008001 and skip "No AOH/alias support in $]", 7; # 6 in on_in, 1 is_deeply %_ = ( brt => 42 ); my $aoa = csv ( in => $tfn, headers => "auto", filter => { foo => sub { m/^[3-9]/ }}, on_in => sub { is ($_{bar}, 2 * $_{foo} - 3, "AOH $_{foo}: b = 2a - 3 \$_{}"); }); is_deeply (\%_, { brt => 42 }, "%_ restored"); } SKIP: { $] < 5.008001 and skip "Too complicated test for $]", 2; # Add to %_ in callback # And test bizarre (but allowed) attribute combinations # Most of them can be either left out or done more efficiently in # a different way my $xcsv = Text::CSV->new; is_deeply (csv (in => $tfn, seps => [ ",", ";" ], munge => "uc", quo => '"', esc => '"', csv => $xcsv, filter => { 1 => sub { $_ eq "4" }}, on_in => sub { $_{BRT} = 42; }), [{ FOO => 4, BAR => 5, BAZ => 6, BRT => 42 }], "AOH with addition to %_ in on_in"); is_deeply ($xcsv->csv ( file => $tfn, sep_set => [ ";", "," ], munge_column_names => "uc", quote_char => '"', quote => '"', escape_char => '"', escape => '"', filter => { 1 => sub { $_ eq "4" }}, after_in => sub { $_{BRT} = 42; }), [{ FOO => 4, BAR => 5, BAZ => 6, BRT => 42 }], "AOH with addition to %_ in on_in"); } SKIP: { $] < 5.008001 and skip "Too complicated test for $]", 2; ok (my $hr = csv (in => $tfn, key => "foo", on_in => sub { $_[1]{quz} = "B"; $_{ziq} = 2; }), "Get into hashref with key and on_in"); is_deeply ($hr->{8}, {qw( bar 13 baz 18 foo 8 quz B ziq 2 )}, "on_in with key works"); } open $fh, ">", $tfn or die "$tfn: $!"; print $fh <<"EOD"; 3,3,3 5,7,9 , "", ,, , ,"", ,," ", "" 8,13,18 EOD close $fh; SKIP: { $] < 5.008001 and skip "Too complicated test for $]", 4; is_deeply (csv (in => $tfn, filter => "not_blank"), [[3,3,3],[5,7,9],["",""],["",""],["",""," ",""], ["","",""],["",""," ",""],[8,13,18]], "filter => not_blank"); is_deeply (csv (in => $tfn, filter => "not_empty"), [[3,3,3],[5,7,9],["",""," ",""],["",""," ",""],[8,13,18]], "filter => not_empty"); is_deeply (csv (in => $tfn, filter => "filled"), [[3,3,3],[5,7,9],[8,13,18]], "filter => filled"); is_deeply (csv (in => $tfn, filter => sub { grep { defined && m/\S/ } @{$_[1]} }), [[3,3,3],[5,7,9],[8,13,18]], "filter => filled"); } { my @err; my $aoa = csv (in => $tfn, strict => 1, on_error => sub { @err = @_ }); is_deeply ($aoa, [[3,3,3]], "Bad CSV still returns ref"); is ($err[0], 2014, "ENF - Inconsistent number of fields"); is (0 + Text::CSV->error_diag, 2014, "Error is kept"); } # Count rows in different ways open $fh, ">", $tfn or die "$tfn: $!"; print $fh <<"EOD"; foo,bar,baz 1,,3 0,"d €",4 999,999, EOD close $fh; { my $n = 0; open my $fh, "<", $tfn; my $csv = Text::CSV->new ({ binary => 1 }); while (my $row = $csv->getline ($fh)) { $n++; } close $fh; is ($n, 4, "Count rows with getline"); } { my $n = 0; my $aoa = csv (in => $tfn, on_in => sub { $n++ }); is ($n, 4, "Count rows with on_in"); } { my $n = 0; my $aoa = csv (in => $tfn, filter => { 0 => sub { $n++; 0; }}); is ($n, 4, "Count rows with filter hash"); } SKIP: { $] < 5.008001 and skip "Too complicated test for $]", 1; my $n = 0; my $aoa = csv (in => $tfn, filter => sub { $n++; 0; }); is ($n, 4, "Count rows with filter sub"); } SKIP: { $] < 5.008001 and skip "Too complicated test for $]", 1; my $n = 0; csv (in => $tfn, on_in => sub { $n++; 0; }, out => \"skip"); is ($n, 4, "Count rows with on_in and skipped out"); } # sep_set, seps, sep on problematic header foreach my $sep (",", ";", "\t") { my $ph = "Problematic header"; open $fh, ">", $tfn or die "$tfn: $!"; print $fh qq{foo${sep}"bar: a, b"${sep}"c;d"${sep}"e"\n}; print $fh qq{1${sep}2${sep}3${sep}4\n}; close $fh; my $exp = [{ "foo" => 1, "bar: a, b" => 2, "c;d" => 3, "e" => 4, }]; ok (csv (in => $tfn, allow_loose_quotes => 1), "$ph, AoA"); if ($] < 5.010000) { ok (1, "Unsupported header feature for $] - sep: $sep") for 1..6; next; } my @err; is (eval { local $SIG{__WARN__} = sub { push @err => @_ }; csv (in => $tfn, bom => 1); }, undef, "$ph: cannot decide on sep"); like ($err[0], qr{ERROR: 1011\b}, "$ph: error 1011"); is_deeply (csv (in => $tfn, bom => 1, sep_set => [ $sep ]), $exp, "$ph: sep_set"); is_deeply (csv (in => $tfn, bom => 1, seps => [ $sep ]), $exp, "$ph: seps"); is_deeply (csv (in => $tfn, bom => 1, sep_char => $sep ), $exp, "$ph: sep_char"); is_deeply (csv (in => $tfn, bom => 1, sep => $sep ), $exp, "$ph: sep"); } Text-CSV-2.06/t/41_null.t0000644000175100017510000000404114760113543015073 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More tests => 128; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; } use Text::CSV; my @pat = ( "00", "\00", "0\0", "\0\0", "0\n0", "\0\n0", "0\n\0", "\0\n\0", "\"0\n0", "\"\0\n0", "\"0\n\0", "\"\0\n\0", "\"0\n\"0", "\"\0\n\"0", "\"0\n\"\0", "\"\0\n\"\0", "0\n0", "\0\n0", "0\n\0", "\0\n\0", ); my %exp = map { my $x = $_; $x =~ s/\0/\\0/g; $x =~ s/\n/\\n/g; ($_ => $x); } @pat; my $line = ["", undef, "0\n", "", "\0\0\n0"]; my $tfn = "_41test.csv"; END { -f $tfn and unlink $tfn; } my $csv = Text::CSV->new ({ eol => "\n", binary => 1, auto_diag => 1, blank_is_undef => 1, }); ok ($csv->combine (@$line), "combine [ ... ]"); is ($csv->string, qq{,,"0\n",,""0"0\n0"\n}, "string"); open my $fh, ">", $tfn or die "$tfn: $!\n"; binmode $fh; ok ($csv->print ($fh, [ $_ ]), "print $exp{$_}") for @pat; $csv->always_quote (1); ok ($csv->print ($fh, $line), "print [ ... ]"); close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; binmode $fh; foreach my $pat (@pat) { ok (my $row = $csv->getline ($fh), "getline $exp{$pat}"); is ($row->[0], $pat, "data $exp{$pat}"); } is_deeply ($csv->getline ($fh), $line, "read [ ... ]"); close $fh; unlink $tfn; $csv = Text::CSV->new ({ eol => "\n", binary => 1, auto_diag => 1, blank_is_undef => 1, quote_null => 0, }); ok ($csv->combine (@$line), "combine [ ... ]"); is ($csv->string, qq{,,"0\n",,"\0\0\n0"\n}, "string"); open $fh, ">", $tfn or die "$tfn: $!\n"; binmode $fh; for (@pat) { ok ($csv->print ($fh, [ $_ ]), "print $exp{$_}"); } $csv->always_quote (1); ok ($csv->print ($fh, $line), "print [ ... ]"); close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; binmode $fh; foreach my $pat (@pat) { ok (my $row = $csv->getline ($fh), "getline $exp{$pat}"); is ($row->[0], $pat, "data $exp{$pat}"); } is_deeply ($csv->getline ($fh), $line, "read [ ... ]"); close $fh; Text-CSV-2.06/t/76_magic.t0000644000175100017510000000616514760113543015222 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; #use Test::More "no_plan"; use Test::More tests => 44; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", (); plan skip_all => "Cannot load Text::CSV" if $@; } my $tfn = "_76test.csv"; END { -f $tfn and unlink $tfn; } my $csv = Text::CSV->new ({ binary => 1, eol => "\n" }); my $fh; my $foo; my $bar; my @foo = ("#", 1..3); tie $foo, "Foo"; ok ($csv->combine (@$foo), "combine () from magic"); untie $foo; is_deeply ([$csv->fields], \@foo, "column_names ()"); tie $bar, "Bar"; $bar = "#"; ok ($csv->combine ($bar, @{$foo}[1..3]),"combine () from magic"); untie $bar; is_deeply ([$csv->fields], \@foo, "column_names ()"); tie $foo, "Foo"; open $fh, ">", $tfn or die "$tfn: $!\n"; ok ($csv->print ($fh, $foo), "print with unused magic scalar"); close $fh; untie $foo; open $fh, "<", $tfn or die "$tfn: $!\n"; is_deeply ($csv->getline ($fh), \@foo, "Content read-back"); close $fh; tie $foo, "Foo"; ok ($csv->column_names ($foo), "column_names () from magic"); untie $foo; is_deeply ([$csv->column_names], \@foo, "column_names ()"); open $fh, "<", $tfn or die "$tfn: $!\n"; tie $bar, "Bar"; ok ($csv->bind_columns (\$bar, \my ($f0, $f1, $f2)), "bind"); ok ($csv->getline ($fh), "fetch with magic"); is_deeply ([$bar,$f0,$f1,$f2], \@foo, "columns fetched on magic"); # free any refs is ($csv->bind_columns (undef), undef, "bind column clear"); untie $bar; close $fh; $csv->eol (undef); ok ($csv->combine ("us", undef, 3), "Combine with undef"); is ($csv->string, "us,,3", "Default"); foreach my $us ("\\N", 1, ",,,", "", "\xe2\x80\xa2", "\x{2205}") { ok (defined ($csv->undef_str ($us)),"Set undef_str with method"); ok ($csv->combine ("us", undef, 3), "Combine with undef"); is ($csv->string, "us,$us,3", "String after method"); } tie my $us, "Bar"; $us = "NULL"; ok ($csv->undef_str ($us), "Set undef_str from tied scalar"); ok ($csv->combine ("us", undef, 3), "Combine with undef"); is ($csv->string, "us,NULL,3", "String after method"); $us = "\\N"; ok ($csv->undef_str ($us), "Set undef_str from tied scalar"); ok ($csv->combine ("us", undef, 3), "Combine with undef"); is ($csv->string, "us,\\N,3", "String after method"); $us = undef; is ($csv->undef_str ($us), undef, "Set undef_str from tied scalar"); ok ($csv->combine ("us", undef, 3), "Combine with undef"); is ($csv->string, "us,,3", "String after method"); untie $us; $csv = Text::CSV->new ({ undef_str => "\\N" }); ok ($csv->combine ("us", undef, 3), "Combine with undef"); is ($csv->string, "us,\\N,3", "String after undef_str from constructor"); { package Foo; use strict; use warnings; require Tie::Scalar; use vars qw( @ISA ); @ISA = qw(Tie::Scalar); sub FETCH { [ "#", 1 .. 3 ]; } # FETCH sub TIESCALAR { bless [], "Foo"; } # TIESCALAR 1; } { package Bar; use strict; use warnings; require Tie::Scalar; use vars qw( @ISA ); @ISA = qw(Tie::Scalar); sub FETCH { return ${$_[0]}; } # FETCH sub STORE { ${$_[0]} = $_[1]; } # STORE sub TIESCALAR { my $bar; bless \$bar, "Bar"; } # TIESCALAR 1; } Text-CSV-2.06/t/50_utf8.t0000644000175100017510000001104214760113543015006 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More; use charnames ":full"; BEGIN { if ($] < 5.008001) { plan skip_all => "UTF8 tests useless in this ancient perl version"; } else { plan tests => 93; } } BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; require_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } my $tfn = "_50test.csv"; END { -f $tfn and unlink $tfn; } # No binary => 1, as UTF8 is supposed to be allowed without it my $csv = Text::CSV->new ({ always_quote => 1, keep_meta_info => 1, }); # Special characters to check: # 0A = \n 2C = , 20 = 22 = " # 0D = \r 3B = ; foreach my $test ( # Space-like characters [ "\x{0000A0}", "U+0000A0 NO-BREAK SPACE" ], [ "\x{00200B}", "U+00200B ZERO WIDTH SPACE" ], # Some characters with possible problems in the code point [ "\x{000122}", "U+000122 LATIN CAPITAL LETTER G WITH CEDILLA" ], [ "\x{002C22}", "U+002C22 GLAGOLITIC CAPITAL LETTER SPIDERY HA" ], [ "\x{000A2C}", "U+000A2C GURMUKHI LETTER BA" ], [ "\x{000E2C}", "U+000E2C THAI CHARACTER LO CHULA" ], [ "\x{010A2C}", "U+010A2C KHAROSHTHI LETTER VA" ], # Characters with possible problems in the encoded representation # Should not be possible. ASCII is coded in 000..127, all other # characters in 128..255 ) { my ($u, $msg) = @$test; ($u = "$u\x{0123}") =~ s/.$//; # Make sure it's marked UTF8 my @in = ("", " ", $u, ""); my $exp = join ",", map { qq{"$_"} } @in; ok ($csv->combine (@in), "combine $msg"); my $str = $csv->string; is_binary ($str, $exp, "string $msg"); ok ($csv->parse ($str), "parse $msg"); my @out = $csv->fields; # Cannot use is_deeply (), because of the binary content is (scalar @in, scalar @out, "fields $msg"); is_binary ($in[$_], $out[$_], "field $_ $msg") for 0 .. $#in; } # Test if the UTF8 part is accepted, but the \n is not is ($csv->parse (qq{"\x{0123}\n\x{20ac}"}), 0, "\\n still needs binary"); is ($csv->binary, 0, "bin flag still unset"); is ($csv->error_diag + 0, 2021, "Error 2021"); open my $fh, ">:encoding(utf-8)", $tfn or die "$tfn: $!\n"; print $fh qq{"\N{LATIN CAPITAL LETTER O WITH STROKE}l/Vin",0\n}; close $fh; SKIP: { open my $fh, "<:encoding(utf-8)", $tfn or skip "Cannot open UTF-8 test file", 6; my $row; ok ($row = $csv->getline ($fh), "read/parse"); is ($csv->is_quoted (0), 1, "First field is quoted"); is ($csv->is_quoted (1), 0, "Second field is not quoted"); is ($csv->is_binary (0), 1, "First field is binary"); is ($csv->is_binary (1), 0, "Second field is not binary"); ok (utf8::valid ($row->[0]), "First field is valid utf8"); $csv->combine (@$row); ok (utf8::valid ($csv->string), "Combined string is valid utf8"); } # Test quote_binary $csv->always_quote (0); $csv->quote_space (0); $csv->quote_binary (0); ok ($csv->combine (" ", 1, "\x{20ac} "), "Combine"); is ($csv->string, qq{ ,1,\x{20ac} }, "String 0-0"); $csv->quote_binary (1); ok ($csv->combine (" ", 1, "\x{20ac} "), "Combine"); is ($csv->string, qq{ ,1,"\x{20ac} "}, "String 0-1"); $csv->quote_space (1); $csv->quote_binary (0); ok ($csv->combine (" ", 1, "\x{20ac} "), "Combine"); is ($csv->string, qq{" ",1,"\x{20ac} "}, "String 1-0"); ok ($csv->quote_binary (1), "quote binary on"); ok ($csv->combine (" ", 1, "\x{20ac} "), "Combine"); is ($csv->string, qq{" ",1,"\x{20ac} "}, "String 1-1"); ok ($csv->parse (qq{,1,"f\x{014d}o, 3""56",,bar,\r\n}), "example from XS"); is_deeply ([$csv->fields], [ "", 1, qq{f\x{014d}o, 3"56}, "", "bar", "" ], "content"); open $fh, ">:encoding(utf-8)", $tfn or die "$tfn: $!\n"; print $fh "euro\n\x{20ac}\neuro\n"; close $fh; open $fh, "<:encoding(utf-8)", $tfn or die "$tfn: $!\n"; SKIP: { my $out = ""; my $isutf8 = $] < 5.008001 ? sub { !$_[0]; } : # utf8::is_utf8 () not available in 5.8.0 sub { utf8::is_utf8 ($out); }; ok ($csv->auto_diag (1), "auto diag"); ok ($csv->binary (1), "set binary"); ok ($csv->bind_columns (\$out), "bind"); ok ($csv->getline ($fh), "parse"); is ($csv->is_binary (0), 0, "not binary"); is ($out, "euro", "euro"); ok (!$isutf8->(1), "not utf8"); ok ($csv->getline ($fh), "parse"); is ($csv->is_binary (0), 1, "is binary"); is ($out, "\x{20ac}", "euro"); ok ($isutf8->(0), "is utf8"); ok ($csv->getline ($fh), "parse"); is ($csv->is_binary (0), 0, "not binary"); is ($out, "euro", "euro"); ok (!$isutf8->(1), "not utf8"); close $fh; } Text-CSV-2.06/t/45_eol.t0000644000175100017510000006220114760113543014706 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More tests => 1182; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; require_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } $| = 1; # Embedded newline tests my $tfn = "_45eol.csv"; END { -f $tfn and unlink $tfn; } my $def_rs = $/; foreach my $rs ("\n", "\r\n", "\r") { for $\ (undef, $rs) { my $csv = Text::CSV->new ({ binary => 1 }); $csv->eol ($/ = $rs) unless defined $\; foreach my $pass (0, 1) { my $fh; if ($pass == 0) { open $fh, ">", $tfn or die "$tfn: $!\n"; } else { open $fh, "<", $tfn or die "$tfn: $!\n"; } foreach my $eol ("", "\r", "\n", "\r\n", "\n\r") { my $s_eol = join " - ", map { defined $_ ? $_ : "" } $\, $rs, $eol; $s_eol =~ s/\r/\\r/g; $s_eol =~ s/\n/\\n/g; my @p; my @f = ("", 1, $eol, " $eol", "$eol ", " $eol ", "'$eol'", "\"$eol\"", " \" $eol \"\n ", "EOL"); if ($pass == 0) { ok ($csv->combine (@f), "combine |$s_eol|"); ok (my $str = $csv->string, "string |$s_eol|"); my $state = $csv->parse ($str); ok ($state, "parse |$s_eol|"); if ($state) { ok (@p = $csv->fields, "fields |$s_eol|"); } else{ is ($csv->error_input, $str, "error |$s_eol|"); } print $fh $str; } else { ok (my $row = $csv->getline ($fh), "getline |$s_eol|"); is (ref $row, "ARRAY", "row |$s_eol|"); @p = @$row; } local $, = "|"; is_binary ("@p", "@f", "result |$s_eol|"); } close $fh; } unlink $tfn; } } $/ = $def_rs; { my $csv = Text::CSV->new ({ escape_char => undef }); ok ($csv->parse (qq{"x"\r\n}), "Trailing \\r\\n with no escape char"); is ($csv->eol ("\r"), "\r", "eol set to \\r"); ok ($csv->parse (qq{"x"\r}), "Trailing \\r with no escape char"); ok ($csv->allow_whitespace (1), "Allow whitespace"); ok ($csv->parse (qq{"x" \r}), "Trailing \\r with no escape char"); } SKIP: { $] < 5.008 and skip "\$\\ tests don't work in perl 5.6.x and older", 2; { local $\ = "#\r\n"; my $csv = Text::CSV->new (); open my $fh, ">", $tfn or die "$tfn: $!\n"; $csv->print ($fh, [ "a", 1 ]); close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; local $/; is (<$fh>, "a,1#\r\n", "Strange \$\\"); close $fh; unlink $tfn; } { local $\ = "#\r\n"; my $csv = Text::CSV->new ({ eol => $\ }); open my $fh, ">", $tfn or die "$tfn: $!\n"; $csv->print ($fh, [ "a", 1 ]); close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; local $/; is (<$fh>, "a,1#\r\n", "Strange \$\\ + eol"); close $fh; unlink $tfn; } } $/ = $def_rs; ok (1, "Auto-detecting \\r"); { my @row = qw( a b c ); local $" = ","; for (["\n", "\\n"], ["\r\n", "\\r\\n"], ["\r", "\\r"]) { my ($eol, $s_eol) = @$_; open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh qq{@row$eol@row$eol@row$eol\x91}; close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; my $c = Text::CSV->new ({ binary => 1, auto_diag => 1 }); is ($c->eol (), "", "default EOL"); is_deeply ($c->getline ($fh), [ @row ], "EOL 1 $s_eol"); is ($c->eol (), $eol eq "\r" ? "\r" : "", "EOL"); is_deeply ($c->getline ($fh), [ @row ], "EOL 2 $s_eol"); is_deeply ($c->getline ($fh), [ @row ], "EOL 3 $s_eol"); close $fh; unlink $tfn; } } ok (1, "Specific \\r test from tfrayner"); { $/ = "\r"; open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh qq{a,b,c$/}, qq{"d","e","f"$/}; close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; my $c = Text::CSV->new ({ eol => $/ }); my $row; local $" = " "; ok ($row = $c->getline ($fh), "getline 1"); is (scalar @$row, 3, "# fields"); is ("@$row", "a b c", "fields 1"); ok ($row = $c->getline ($fh), "getline 2"); is (scalar @$row, 3, "# fields"); is ("@$row", "d e f", "fields 2"); close $fh; unlink $tfn; } $/ = $def_rs; ok (1, "EOL undef"); foreach my $se (0, 1) { $/ = "\r"; ok (my $csv = Text::CSV->new ({ eol => undef, strict_eol => $se, }), "new csv with eol => undef"); open my $fh, ">", $tfn or die "$tfn: $!\n"; ok ($csv->print ($fh, [1, 2, 3]), "print"); ok ($csv->print ($fh, [4, 5, 6]), "print"); close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; ok (my $row = $csv->getline ($fh), "getline 1"); is (scalar @$row, 5, "# fields"); is_deeply ($row, [ 1, 2, 34, 5, 6], "fields 1"); close $fh; unlink $tfn; } $/ = $def_rs; foreach my $eol ("!", "!!", "!\n", "!\n!", "!!!!!!!!", "!!!!!!!!!!", "\n!!!!!\n!!!!!", "!!!!!\n!!!!!\n", "%^+_\n\0!X**", "\r\n", "\r") { (my $s_eol = $eol) =~ s/\n/\\n/g; $s_eol =~ s/\r/\\r/g; $s_eol =~ s/\0/\\0/g; ok (1, "EOL $s_eol"); ok (my $csv = Text::CSV->new ({ eol => $eol }), "new csv with eol => $s_eol"); open my $fh, ">", $tfn or die "$tfn: $!\n"; ok ($csv->print ($fh, [1, 2, 3]), "print"); ok ($csv->print ($fh, [4, 5, 6]), "print"); close $fh; foreach my $rs (undef, "", "\n", $eol, "!", "!\n", "\n!", "!\n!", "\n!\n") { local $/ = $rs; (my $s_rs = defined $rs ? $rs : "-- undef --") =~ s/\n/\\n/g; ok (1, "with RS $s_rs"); open $fh, "<", $tfn or die "$tfn: $!\n"; ok (my $row = $csv->getline ($fh), "getline 1"); is (scalar @$row, 3, "field count"); is_deeply ($row, [ 1, 2, 3], "fields 1"); ok ( $row = $csv->getline ($fh), "getline 2"); is (scalar @$row, 3, "field count"); is_deeply ($row, [ 4, 5, 6], "fields 2"); close $fh; } unlink $tfn; } $/ = $def_rs; foreach my $se (0, 1) { my @w; local $SIG{__WARN__} = sub { push @w => @_ }; open my $fh, "<", "files/macosx.csv" or die "files/macosx.csv: $!"; ok (1, "MacOSX exported file"); ok (my $csv = Text::CSV->new ({ auto_diag => 1, binary => 1, strict_eol => $se, }), "new csv"); ok (my $row = $csv->getline ($fh), "getline 1"); is (scalar @$row, 15, "field count"); is ($row->[7], "", "field 8"); ok ( $row = $csv->getline ($fh), "getline 2"); is (scalar @$row, 15, "field count"); is ($row->[6], "Category", "field 7"); ok ( $row = $csv->getline ($fh), "getline 3"); is (scalar @$row, 15, "field count"); is ($row->[5], "Notes", "field 6"); ok ( $row = $csv->getline ($fh), "getline 4"); is (scalar @$row, 15, "field count"); is ($row->[7], "Points", "field 8"); ok ( $row = $csv->getline ($fh), "getline 5"); is (scalar @$row, 15, "field count"); is ($row->[7], 11, "field 8"); ok ( $row = $csv->getline ($fh), "getline 6"); is (scalar @$row, 15, "field count"); is ($row->[8], 34, "field 9"); ok ( $row = $csv->getline ($fh), "getline 7"); is (scalar @$row, 15, "field count"); is ($row->[7], 12, "field 8"); ok ( $row = $csv->getline ($fh), "getline 8"); is (scalar @$row, 15, "field count"); is ($row->[8], 2, "field 9"); ok ( $row = $csv->getline ($fh), "getline 9"); is (scalar @$row, 15, "field count"); is ($row->[3], "devs", "field 4"); ok ( $row = $csv->getline ($fh), "getline 10"); is (scalar @$row, 15, "field count"); is ($row->[3], "", "field 4"); ok ( $row = $csv->getline ($fh), "getline 11"); is (scalar @$row, 15, "field count"); is ($row->[6], "Mean", "field 7"); ok ( $row = $csv->getline ($fh), "getline 12"); is (scalar @$row, 15, "field count"); is ($row->[6], "Median", "field 7"); ok ( $row = $csv->getline ($fh), "getline 13"); is (scalar @$row, 15, "field count"); is ($row->[6], "Mode", "field 7"); ok ( $row = $csv->getline ($fh), "getline 14"); is (scalar @$row, 15, "field count"); is ($row->[6], "Min", "field 7"); ok ( $row = $csv->getline ($fh), "getline 15"); is (scalar @$row, 15, "field count"); is ($row->[6], "Max", "field 7"); ok ( $row = $csv->getline ($fh), "getline 16"); is (scalar @$row, 15, "field count"); is ($row->[0], "", "field 1"); close $fh; if ($se) { like ($w[0], qr{2016 - EOL}, "Got EOL warning"); } else { is_deeply (\@w, [], "No warnings"); } } { ok (my $csv = Text::CSV->new ({ auto_diag => 1, binary => 1 }), "new csv"); ok ($csv->eol ("--"), "eol = --"); ok ($csv->parse (qq{1,"2--3",4}), "no eol"); is_deeply ([$csv->fields], [ "1", "2--3", 4 ], "parse"); ok ($csv->parse (qq{1,"2--3",4--}), "eol"); is_deeply ([$csv->fields], [ "1", "2--3", 4 ], "parse"); ok ($csv->parse (qq{1,"2--3",4,--}), ",eol"); is_deeply ([$csv->fields], [ "1", "2--3", 4, "" ], "parse"); open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh qq{1,"2--3",4--}; print $fh qq{1,"2--3",4,--}; print $fh qq{1,"2--3",4}; close $fh; open $fh, "<", $tfn or die "$tfn: $!\n"; is_deeply ($csv->getline ($fh), [ "1", "2--3", 4 ], "getline eol"); is_deeply ($csv->getline ($fh), [ "1", "2--3", 4, "" ], "getline ,eol"); is_deeply ($csv->getline ($fh), [ "1", "2--3", 4 ], "getline eof"); close $fh; } { ok (my $csv = Text::CSV->new (), "new csv"); ok ($csv->parse (qq{"a","b","c"\r\n}), "parse \\r\\n"); is_deeply ([$csv->fields], [qw( a b c )], "result"); ok ($csv->allow_loose_escapes (1), "allow loose escapes"); ok ($csv->parse (qq{"a","b","c"\r\n}), "parse \\r\\n"); is_deeply ([$csv->fields], [qw( a b c )], "result"); } foreach my $eol ("\n", "\r\n", "\r") { my $s_eol = $eol; $s_eol =~ s{\r}{\\r}; $s_eol =~ s{\n}{\\n}; foreach my $before ("1,2$eol", "") { open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh $before; # To test if skipping the very first line works print $fh $eol; # skipped print $fh qq{ $eol}; # -> [ " " ] print $fh qq{,$eol}; # -> [ "", "" ] print $fh $eol; # skipped print $fh qq{""$eol}; # -> [ "" ] print $fh qq{eol$eol}; # -> [ "eol" ] close $fh; my @expect = ([ " " ], [ "", "" ], [ "" ], [ "eol" ]); $before and unshift @expect => [ 1, 2 ]; open $fh, "<", $tfn or die "$tfn: $!\n"; my $csv = Text::CSV->new ({ skip_empty_rows => 1, eol => $eol, }); my @csv; while (my $row = $csv->getline ($fh)) { push @csv => $row; } close $fh; is_deeply (\@csv, \@expect, "Empty lines skipped $s_eol\tEOL set"); open $fh, "<", $tfn or die "$tfn: $!\n"; $csv = Text::CSV->new ({ skip_empty_rows => 1 }); @csv = (); while (my $row = $csv->getline ($fh)) { push @csv => $row; } close $fh; is_deeply (\@csv, \@expect, "Empty lines skipped $s_eol\tauto-detect"); } } my %ers = ( # For backward compat :( - on 2024-12-05 XS and PP acted identical # some are not OK or at least do not DWIM in hindsight # strict : skip : reset : quoted '0:0:0:' => [[ "Aardvark", "snort", ], [ "", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "", ], [ "Camel", "grunt", ], [ "", ], [ "", ], [ "Crow", "caw", ], [ "", ], [ "", ], [ 2012, 0, 15, 0, "" ]], # EOF '0:0:1:' => [[ "Aardvark", "snort", ], [ "", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], [ "", ], [ "Crow", "caw", ], [ "Deer", "bellow", ], [ "Dolphin", "click", ], [ 2012, 0, 14, 0, "" ]], # EOF '0:1:0:' => [[ "Aardvark", "snort", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], [ "Crow", "caw", ], [ "Deer", "bellow", ], [ 2012, 0, 11, 0, "" ]], # EOF '0:1:1:' => [[ "Aardvark", "snort", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], [ "Crow", "caw", ], [ "Deer", "bellow", ], [ "Dolphin", "click", ], [ 2012, 0, 12, 0, "" ]], # EOF '0:0:0:"' => [[ "Aardvark", "snort", ], [ "", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "", ], [ "Camel", "grunt", ], [ "", ], [ "", ], [ "Crow", "caw", ], [ "", ], [ "", ], [ 2012, 0, 15, 0, "" ]], # EOF '0:0:1:"' => [[ "Aardvark", "snort", ], [ "", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], #[ "Crow", "caw", ], WRONG [ "Deer", "bellow", ], [ "Dolphin", "click", ], [ 2012, 0, 12, 0, "" ]], # EOF '0:1:0:"' => [[ "Aardvark", "snort", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], [ "Crow", "caw", ], [ "Deer", "bellow", ], # WRONG [ 2012, 0, 11, 0, "" ]], # EOF '0:1:1:"' => [[ "Aardvark", "snort", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], #[ "Crow", "caw", ], WRONG [ "Deer", "bellow", ], [ "Dolphin", "click", ], [ 2012, 0, 11, 0, "" ]], # EOF # Strict EOL warn / strict : skip : reset : quoted '1:0:0:' => [[ "Aardvark", "snort", ], [ "", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], [ "", ], [ "Crow", "caw", ], [ "Deer", "bellow", ], [ "Dolphin", "click", ], [ 2012, 13, 14, 2, "2016 - EOL" ]], '1:0:1:' => [[ "Aardvark", "snort", ], [ "", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], [ "", ], [ "Crow", "caw", ], [ "Deer", "bellow", ], [ "Dolphin", "click", ], [ 2012, 0, 14, 0, "" ]], # EOF '1:1:0:' => [[ "Aardvark", "snort", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], [ "Crow", "caw", ], [ "Deer", "bellow", ], [ "Dolphin", "click", ], [ 2012, 13, 12, 2, "2016 - EOL" ]], '1:1:1:' => [[ "Aardvark", "snort", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], [ "Crow", "caw", ], [ "Deer", "bellow", ], [ "Dolphin", "click", ], [ 2012, 10, 12, 1, "2016 - EOL" ]], '1:0:0:"' => [[ "Aardvark", "snort", ], [ "", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], [ "", ], [ "Crow", "caw", ], [ "Deer", "bellow", ], [ "Dolphin", "click", ], [ 2012, 15, 14, 2, "2016 - EOL" ]], '1:0:1:"' => [[ "Aardvark", "snort", ], [ "", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], #[ "Crow", "caw", ], WRONG: might change [ "Deer", "bellow", ], [ "Dolphin", "click", ], [ 2012, 13, 12, 2, "2016 - EOL" ]], '1:1:0:"' => [[ "Aardvark", "snort", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], [ "Crow", "caw", ], [ "Deer", "bellow", ], [ "Dolphin", "click", ], [ 2012, 15, 12, 2, "2016 - EOL" ]], '1:1:1:"' => [[ "Aardvark", "snort", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], #[ "Crow", "caw", ], WRONG, might change [ "Deer", "bellow", ], [ "Dolphin", "click", ], [ 2012, 13, 11, 2, "2016 - EOL" ]], # Strict EOL croak / strict : skip : reset : quoted '2:0:0:' => [[ "Aardvark", "snort", ], [ "", ], [ "Alpaca", "spit", ], [ 2016, 13, 4, 2, "2016 - EOL" ]], '2:0:1:' => [[ "Aardvark", "snort", ], [ "", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], [ "", ], [ "Crow", "caw", ], [ "Deer", "bellow", ], [ "Dolphin", "click", ], [ 2012, 0, 14, 0, "" ]], # EOF '2:1:0:' => [[ "Aardvark", "snort", ], [ "Alpaca", "spit", ], [ 2016, 13, 3, 2, "2016 - EOL" ]], '2:1:1:' => [[ "Aardvark", "snort", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ "Cobra", "shh", ], [ 2016, 10, 9, 1, "2016 - EOL" ]], '2:0:0:"' => [[ "Aardvark", "snort", ], [ "", ], [ "Alpaca", "spit", ], [ 2016, 15, 4, 2, "2016 - EOL" ]], '2:0:1:"' => [[ "Aardvark", "snort", ], [ "", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], [ 2016, 13, 9, 2, "2016 - EOL" ]], '2:1:0:"' => [[ "Aardvark", "snort", ], [ "Alpaca", "spit", ], [ 2016, 15, 3, 2, "2016 - EOL" ]], '2:1:1:"' => [[ "Aardvark", "snort", ], [ "Alpaca", "spit", ], [ "Badger", "growl", ], [ "Bat", "screech", ], [ "Bear", "roar", ], [ "Bee", "buzz", ], [ "Camel", "grunt", ], #[ "Cobra", "shh", ], NOT stored, documented, might change [ 2016, 13, 8, 2, "2016 - EOL" ]], ); foreach my $q ('', '"') { open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh "Aardvark,${q}snort${q}\r\n"; print $fh "\r\n"; # Empty line print $fh "Alpaca,${q}spit${q}\r\n"; print $fh "Badger,${q}growl${q}\n"; # only newline print $fh "Bat,${q}screech${q}\r\n"; print $fh "Bear,${q}roar${q}\r"; # only carriage return - no newline print $fh "Bee,${q}buzz${q}\r\n"; print $fh "Camel,${q}grunt${q}\r\n"; print $fh "Cobra,${q}shh${q}\r\r"; # two CR's print $fh "Crow,${q}caw${q}\r\n"; print $fh "Deer,${q}bellow${q}\n"; # only newline print $fh "Dolphin,${q}click${q}\r\n"; close $fh; foreach my $se (0, 1, 2) { foreach my $ser (0, 1) { foreach my $reset (0, 1) { my $tag = join ":" => $se, $ser, $reset, $q; open $fh, "<", $tfn or die "$tfn: $!\n"; my $csv = Text::CSV->new ({ strict_eol => $se, skip_empty_rows => $ser, auto_diag => 1, diag_verbose => 1, # Do NOT set binary! }); my (@r, @w); eval { local $SIG{__WARN__} = sub { push @w => @_ }; while (my $row = $csv->getline ($fh)) { push @r => [ @$row ]; $reset and $csv->eol (undef); } close $fh; }; my @diag = $csv->error_diag; my $warn = join " | " => map { substr $_, 16, 10 } @w; my $got = [ @r, [ @diag[0, 2, 3, 4], $warn ]]; my $exp = $ers{$tag}; unless (is_deeply ($got, $exp, $tag)) { # use Data::Peek; #diag DDumper { got => $got, tag => $tag }; } } } } } # strict_eol should NOT warn/die/complain on deviating EOL inside quoted fields { open my $fh, ">", $tfn or die "$tfn: $!\n"; print $fh qq{Abrax,Booz,Wrox\r\n}; print $fh qq{Foo,"x\ry",Ornf\r\n}; print $fh qq{Cruy,"a\nb",Hye\r\n}; print $fh qq{Daj,"f\r\nb",Uf\r\n}; close $fh; foreach my $se (0, 1, 2) { my $tag = join ":" => "SE $se"; open $fh, "<", $tfn or die "$tfn: $!\n"; my $csv = Text::CSV->new ({ strict_eol => $se, auto_diag => 1, diag_verbose => 1, binary => 1, }); my (@r, @w); eval { local $SIG{__WARN__} = sub { push @w => @_ }; while (my $row = $csv->getline ($fh)) { push @r => [ @$row ]; } close $fh; }; my @diag = $csv->error_diag; my $warn = join " | " => map { substr $_, 16, 10 } @w; is (scalar @r, 4, "$tag: Got 4 rows"); is (scalar @w, 0, "$tag: Got no warnings"); } } 1; Text-CSV-2.06/t/21_lexicalio.t0000644000175100017510000001073414760113543016076 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; # use warnings; use Test::More; BEGIN { if ($] < 5.006) { plan skip_all => "No lexical file handles in in this ancient perl version"; } else { plan tests => 109; } } BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV"; plan skip_all => "Cannot load Text::CSV" if $@; require "./t/util.pl"; } $| = 1; $/ = "\n"; $\ = undef; my $io; my $tfn = "_21test.csv"; END { -f $tfn and unlink $tfn; } my $csv = Text::CSV->new (); my $UTF8 = ($ENV{LANG} || "C").($ENV{LC_ALL} || "C") =~ m/utf-?8/i ? 1 : 0; open $io, ">", $tfn or die "$tfn: $!"; ok (!$csv->print ($io, ["abc", "def\007", "ghi"]), "print bad character"); close $io; for ( [ 1, 1, 1, '""' ], [ 2, 1, 1, '', '' ], [ 3, 1, 0, '', 'I said, "Hi!"', '' ], [ 4, 1, 0, '"', 'abc' ], [ 5, 1, 0, 'abc', '"' ], [ 6, 1, 1, 'abc', 'def', 'ghi' ], [ 7, 1, 1, "abc\tdef", 'ghi' ], [ 8, 1, 0, '"abc' ], [ 9, 1, 0, 'ab"c' ], [ 10, 1, 0, '"ab"c"' ], [ 11, 0, 0, qq("abc\nc") ], [ 12, 1, 1, q(","), ',' ], [ 13, 1, 0, qq("","I said,\t""Hi!""",""), '', qq(I said,\t"Hi!"), '' ], ) { my ($tst, $validp, $validg, @arg, $row) = @$_; open $io, ">", $tfn or die "$tfn: $!"; is ($csv->print ($io, \@arg), $validp||"", "$tst - print ()"); close $io; open $io, ">", $tfn or die "$tfn: $!"; print $io join ",", @arg; close $io; open $io, "<", $tfn or die "$tfn: $!"; $row = $csv->getline ($io); unless ($validg) { is ($row, undef, "$tst - false getline ()"); next; } ok ($row, "$tst - good getline ()"); $tst == 12 and @arg = (",", "", ""); foreach my $a (0 .. $#arg) { (my $exp = $arg[$a]) =~ s/^"(.*)"$/$1/; is ($row->[$a], $exp, "$tst - field $a"); } } unlink $tfn; # This test because of a problem with DBD::CSV ok (1, "Tests for DBD::CSV"); open $io, ">", $tfn or die "$tfn: $!"; $csv->binary (1); $csv->eol ("\r\n"); ok ($csv->print ($io, [ "id", "name" ]), "Bad character"); ok ($csv->print ($io, [ 1, "Alligator Descartes" ]), "Name 1"); ok ($csv->print ($io, [ "3", "Jochen Wiedmann" ]), "Name 2"); ok ($csv->print ($io, [ 2, "Tim Bunce" ]), "Name 3"); ok ($csv->print ($io, [ " 4", "Andreas König" ]), "Name 4"); ok ($csv->print ($io, [ 5 ]), "Name 5"); close $io; my $expected = <<"CONTENTS"; id,name\015 1,"Alligator Descartes"\015 3,"Jochen Wiedmann"\015 2,"Tim Bunce"\015 " 4","Andreas König"\015 5\015 CONTENTS open $io, "<", $tfn or die "$tfn: $!"; my $content = do { local $/; <$io> }; close $io; is ($content, $expected, "Content"); open $io, ">", $tfn or die "$tfn: $!"; print $io $content; close $io; open $io, "<", $tfn or die "$tfn: $!"; my $fields; print "# Retrieving data\n"; for (0 .. 5) { ok ($fields = $csv->getline ($io), "Fetch field $_"); is ($csv->eof, "", "EOF"); print "# Row $_: $fields (@$fields)\n"; } is ($csv->getline ($io), undef, "Fetch field 6"); is ($csv->eof, 1, "EOF"); # Edge cases for ([ 1, 1, 0, "\n" ], [ 2, 1, 0, "+\n" ], [ 3, 1, 0, "+" ], [ 4, 0, 2021, qq{"+"\n} ], [ 5, 0, 2025, qq{"+\n} ], [ 6, 0, 2011, qq{""+\n} ], [ 7, 0, 2027, qq{"+"} ], [ 8, 0, 2024, qq{"+} ], [ 9, 0, 2011, qq{""+} ], [ 10, 1, 0, "\r" ], [ 11, 0, 2031, "\r\b" ], [ 12, 0, 2032, "+\r\b" ], [ 13, 0, 2032, "+\r\b+" ], [ 14, 0, 2022, qq{"\r"} ], [ 15, 0, 2022, qq{"\r\b" } ], [ 16, 0, 2022, qq{"\r\b"\t} ], [ 17, 0, 2025, qq{"+\r\b"} ], [ 18, 0, 2025, qq{"+\r\b+"} ], [ 19, 0, 2022, qq{"\r"\b} ], [ 20, 0, 2022, qq{"\r\b"\b} ], [ 21, 0, 2025, qq{"+\r\b"\b} ], [ 22, 0, 2025, qq{"+\r\b+"\b} ], [ 23, 0, 2037, qq{\b} ], [ 24, 0, 2026, qq{"\b"} ], ) { my ($tst, $valid, $err, $str) = @$_; my $raw = $] < 5.008 ? "" : ":raw"; open my $io, ">$raw", $tfn or die "$tfn: $!"; print $io $str; close $io; $csv = Text::CSV->new ({ escape_char => "+" }); open $io, "<$raw", $tfn or die "$tfn: $!"; my $row = $csv->getline ($io); close $io; my @err = $csv->error_diag; my $sstr = _readable ($str); SKIP: { $tst == 10 && $] >= 5.008 && $] < 5.008003 && $UTF8 and skip "Be reasonable, this perl version does not do Unicode reliable", 2; ok ($valid ? $row : !$row, "$tst - getline ESC +, '$sstr'"); is ($err[0], $err, "Error expected $err"); } } Text-CSV-2.06/t/30_types.t0000644000175100017510000000325514760113543015271 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More tests => 25; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", (); plan skip_all => "Cannot load Text::CSV" if $@; } $| = 1; my $csv = Text::CSV->new ({ types => [ Text::CSV::IV (), Text::CSV::PV (), Text::CSV::NV (), ], }); ok ($csv, "CSV_XS->new ()"); is (@{$csv->{types}}, 3, "->{types} as hash"); is ($csv->{types}[0], Text::CSV::IV (), "type IV"); is ($csv->{types}[1], Text::CSV::PV (), "type PV"); is ($csv->{types}[2], Text::CSV::NV (), "type NV"); is (ref ($csv->types), "ARRAY", "->types () as method"); is ($csv->types ()->[0], Text::CSV::IV (), "type IV"); is ($csv->types ()->[1], Text::CSV::PV (), "type PV"); is ($csv->types ()->[2], Text::CSV::NV (), "type NV"); is (length $csv->{_types}, 3, "->{_types}"); my $inp = join "", map { chr $_ } Text::CSV::IV (), Text::CSV::PV (), Text::CSV::NV (); # should be "\001\000\002" is ($csv->{_types}, $inp, "IV PV NV"); ok ($csv->parse ("2.55,CSFDATVM01,3.75"), "parse ()"); my @fields = $csv->fields (); is ($fields[0], "2", "Field 1"); is ($fields[1], "CSFDATVM01", "Field 2"); is ($fields[2], "3.75", "Field 3"); ok ($csv->combine ("", "", "1.00"), "combine ()"); is ($csv->string, ',,1.00', "string"); my $warning; $SIG{__WARN__} = sub { $warning = shift }; ok ($csv->parse ($csv->string ()), "parse (combine ())"); like ($warning, qr/numeric/, "numeric warning"); @fields = $csv->fields (); is ($fields[0], "0", "Field 1"); is ($fields[1], "", "Field 2"); is ($fields[2], "1", "Field 3"); is ($csv->types (0), undef, "delete types"); is ($csv->types, undef, "types gone"); Text-CSV-2.06/t/66_formula.t0000644000175100017510000001326114760113543015601 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More tests => 119; BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", (); plan skip_all => "Cannot load Text::CSV" if $@; } my $tfn = "_66test.csv"; END { -f $tfn and unlink $tfn; } ok (my $csv = Text::CSV->new, "new"); is ($csv->formula, "none", "default"); is ($csv->formula (1), "die", "die"); is ($csv->formula ("die"), "die", "die"); is ($csv->formula (2), "croak", "croak"); is ($csv->formula ("croak"), "croak", "croak"); is ($csv->formula (3), "diag", "diag"); is ($csv->formula ("diag"), "diag", "diag"); is ($csv->formula (4), "empty", "empty"); is ($csv->formula ("empty"), "empty", "empty"); is ($csv->formula (""), "empty", "explicit empty"); is ($csv->formula (5), "undef", "undef"); is ($csv->formula ("undef"), "undef", "undef"); is ($csv->formula (undef), "undef", "explicit undef"); is ($csv->formula (sub { }), "cb", "callback"); is ($csv->formula (0), "none", "none"); is ($csv->formula ("none"), "none", "none"); is ($csv->formula_handling, "none", "default"); is ($csv->formula_handling ("DIE"), "die", "die"); is ($csv->formula_handling ("CROAK"), "croak", "croak"); is ($csv->formula_handling ("DIAG"), "diag", "diag"); is ($csv->formula_handling ("EMPTY"), "empty", "empty"); is ($csv->formula_handling ("UNDEF"), "undef", "undef"); is ($csv->formula_handling ("NONE"), "none", "none"); foreach my $f (-1, 9, "xxx", "DIAX", [], {}) { eval { $csv->formula ($f); }; like ($@, qr/\bformula-handling '\Q$f\E' is not supported/, "$f in invalid"); } my %f = qw( 0 none none none 1 die die die 2 croak croak croak 3 diag diag diag 4 empty empty empty 5 undef undef undef ); foreach my $f (sort keys %f) { ok (my $p = Text::CSV->new ({ formula => $f }), "new with $f"); is ($p->formula, $f{$f}, "Set to $f{$f}"); } eval { Text::CSV->new ({ formula => "xxx" }); }; like ($@, qr/\bformula-handling 'xxx' is not supported/, "xxx is invalid"); # TODO : $csv->formula (sub { 42; }); # Parser my @data = split m/\n/ => <<"EOC"; a,b,c 1,2,3 =1+2,3,4 1,=2+3,4 1,2,=3+4 EOC sub parse { my $f = shift; my @d; ok (my $csv = Text::CSV->new ({ formula => $f }), "new $f"); #diag ("Formula: ". $csv->formula); for (@data) { $csv->parse ($_); push @d, [ $csv->fields ]; } \@d; } # parse is_deeply (parse (0), [ [ "a", "b", "c", ], [ "1", "2", "3", ], [ "=1+2", "3", "4", ], [ "1", "=2+3", "4", ], [ "1", "2", "=3+4", ], ], "Default"); my $r = eval { parse (1) }; is ($r, undef, "Die on formulas"); is ($@, "Formulas are forbidden\n", "Message"); $@ = undef; $r = eval { parse (2) }; is ($r, undef, "Croak on formulas"); is ($@, "Formulas are forbidden\n", "Message"); $@ = undef; my @m; local $SIG{__WARN__} = sub { push @m, @_ }; is_deeply (parse (3), [ [ "a", "b", "c", ], [ "1", "2", "3", ], [ "=1+2", "3", "4", ], [ "1", "=2+3", "4", ], [ "1", "2", "=3+4", ], ], "Default"); is ($@, undef, "Legal with warnings"); is_deeply (\@m, [ "Field 1 in record 3 contains formula '=1+2'\n", "Field 2 in record 4 contains formula '=2+3'\n", "Field 3 in record 5 contains formula '=3+4'\n", ], "Warnings"); @m = (); is_deeply (parse (4), [ [ "a", "b", "c", ], [ "1", "2", "3", ], [ "", "3", "4", ], [ "1", "", "4", ], [ "1", "2", "", ], ], "Empty"); is_deeply (parse (5), [ [ "a", "b", "c", ], [ "1", "2", "3", ], [ undef, "3", "4", ], [ "1", undef, "4", ], [ "1", "2", undef, ], ], "Undef"); for ([ "Callback return", sub { 42; } ], [ "Callback assign", sub { $_ = 42; } ], [ "Callback subst", sub { s/.*/42/; $_ } ], # s///r requires 5.13.2 ) { my ($msg, $cb) = @$_; is_deeply (parse ($cb), [ [ "a", "b", "c", ], [ "1", "2", "3", ], [ "42", "3", "4", ], [ "1", "42", "4", ], [ "1", "2", "42", ], ], $msg); } is_deeply (parse (sub { eval { s{^=([-+*/0-9()]+)$}{$1}ee }; $_ }), [ [ "a", "b", "c", ], [ "1", "2", "3", ], [ "3", "3", "4", ], [ "1", "5", "4", ], [ "1", "2", "7", ], ], "Callback calculations"); { @m = (); ok (my $csv = Text::CSV->new ({ formula => 3 }), "new 3 hr"); ok ($csv->column_names ("code", "value", "desc"), "Set column names"); ok ($csv->parse ("1,=2+3,4"), "Parse"); is_deeply (\@m, [ qq{Field 2 (column: 'value') contains formula '=2+3'\n} ], "Warning for HR"); } # Writer sub writer { my $f = shift; ok (my $csv = Text::CSV->new ({ formula_handling => $f, quote_empty => 1 }), "new $f"); ok ($csv->combine ("1", "=2+3", "4"), "combine $f"); $csv->string; } # writer @m = (); is ( writer (0), q{1,=2+3,4}, "Out 0"); is (eval { writer (1) }, undef, "Out 1"); is (eval { writer (2) }, undef, "Out 2"); is ( writer (3), q{1,=2+3,4}, "Out 3"); is ( writer (4), q{1,"",4}, "Out 4"); is ( writer (5), q{1,,4}, "Out 5"); is_deeply (\@m, [ "Field 1 contains formula '=2+3'\n" ], "Warning 3"); @m = (); is ( writer ("none"), q{1,=2+3,4}, "Out none"); is (eval { writer ("die") }, undef, "Out die"); is (eval { writer ("croak") }, undef, "Out croak"); is ( writer ("diag"), q{1,=2+3,4}, "Out diag"); is ( writer ("empty"), q{1,"",4}, "Out empty"); is ( writer ("undef"), q{1,,4}, "Out undef"); is_deeply (\@m, [ "Field 1 contains formula '=2+3'\n" ], "Warning diag"); open my $fh, ">", $tfn; printf $fh <<"EOC"; 1,2,3 =1+2,3,4 1,=12-6,5 1,2,=4+(9-1)/2 EOC close $fh; is_deeply (Text::CSV::csv (in => $tfn, formula => sub { eval { s{^=([-+*/0-9()]+)$}{$1}ee }; $_ }), [[1,2,3],[3,3,4],[1,6,5],[1,2,8]], "Formula calc from csv function"); Text-CSV-2.06/t/67_emptrow.t0000644000175100017510000001106514760113543015632 0ustar ishigakiishigaki#!/usr/bin/perl use strict; $^W = 1; use Test::More; BEGIN { if ($] < 5.008001) { plan skip_all => "This test unit requires perl-5.8.1 or higher"; } else { plan tests => 56; } $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; use_ok "Text::CSV", ("csv"); plan skip_all => "Cannot load Text::CSV" if $@; } my $tfn = "_67test.csv"; END { -f $tfn and unlink $tfn; } ok (my $csv = Text::CSV->new, "new"); is ($csv->skip_empty_rows, 0, "default"); is ($csv->skip_empty_rows (1), 1, "+1"); is ($csv->skip_empty_rows ("skip"), 1, "skip"); is ($csv->skip_empty_rows ("SKIP"), 1, "SKIP"); is ($csv->skip_empty_rows (2), "eof", "+2"); is ($csv->skip_empty_rows ("eof"), "eof", "eof"); is ($csv->skip_empty_rows ("EOF"), "eof", "EOF"); is ($csv->skip_empty_rows ("stop"), "eof", "stop"); is ($csv->skip_empty_rows ("STOP"), "eof", "STOP"); is ($csv->skip_empty_rows (3), "die", "+3"); is ($csv->skip_empty_rows ("die"), "die", "die"); is ($csv->skip_empty_rows ("DIE"), "die", "DIE"); is ($csv->skip_empty_rows (4), "croak", "+4"); is ($csv->skip_empty_rows ("croak"), "croak", "croak"); is ($csv->skip_empty_rows ("CROAK"), "croak", "CROAK"); is ($csv->skip_empty_rows (5), "error", "+5"); is ($csv->skip_empty_rows ("error"), "error", "error"); is ($csv->skip_empty_rows ("ERROR"), "error", "ERROR"); sub cba { [ 3, 42, undef, 3 ] } sub cbh { { a => 3, b => 42, c => undef, d => 3 } } is ($csv->skip_empty_rows (\&cba), \&cba, "callback"); is ($csv->skip_empty_rows (0), 0, "+0"); is ($csv->skip_empty_rows (undef), 0, "undef"); open my $fh, ">", $tfn or BAIL_OUT "$tfn: $!\n"; print $fh "a,b,c,d\n"; print $fh "1,2,0,4\n"; print $fh "4,0,9,1\n"; print $fh "\n"; print $fh "8,2,7,1\n"; print $fh "\n"; print $fh "\n"; print $fh "5,7,9,3\n"; print $fh "\n"; close $fh; my @parg = (auto_diag => 0, in => $tfn); my @head = ([qw( a b c d )], [1,2,0,4], [4,0,9,1]); my @repl = (1..4); my $ea = \@repl; # Array behavior is_deeply (csv (@parg, skip_empty_rows => 0), [ @head, [""],[8,2,7,1],[""],[""],[5,7,9,3],[""]], "A Default"); is_deeply (csv (@parg, skip_empty_rows => 1), [ @head, [8,2,7,1],[5,7,9,3]], "A Skip"); is_deeply (csv (@parg, skip_empty_rows => 2), \@head, "A EOF"); is (eval { csv (@parg, skip_empty_rows => 3); }, undef, "A die"); like ($@, qr{^Empty row}, "A msg"); is (eval { csv (@parg, skip_empty_rows => 4); }, undef, "A croak"); like ($@, qr{^Empty row}, "A msg"); $@ = ""; $csv = Text::CSV->new ({ skip_empty_rows => 5 }); is_deeply ($csv->csv (@parg), \@head, "A error"); is ($@, "", "A msg"); is (0 + $csv->error_diag, 2015, "A code"); is_deeply (csv (@parg, skip_empty_rows => sub {\@repl}), [ @head, $ea,[8,2,7,1],$ea,$ea,[5,7,9,3],$ea], "A Callback"); is_deeply (csv (@parg, skip_empty_rows => sub {0}), \@head, "A Callback 0"); # Array behavior (line by line) open $fh, "<", $tfn; $csv = Text::CSV->new ({ skip_empty_rows => 1 }); while (my $row = $csv->getline ($fh)) { ok (@$row, "Row has columns"); } close $fh; # Hash behavior push @parg => bom => 1; my $eh = { a => "", b => undef, c => undef, d => undef }, @head = ({ a => 1, b => 2, c => 0, d => 4 }, { a => 4, b => 0, c => 9, d => 1 }); is_deeply (csv (@parg, skip_empty_rows => 0), [ @head, $eh, { a => 8, b => 2, c => 7, d => 1 },$eh,$eh, { a => 5, b => 7, c => 9, d => 3 },$eh], "H Default"); is_deeply (csv (@parg, skip_empty_rows => 1), [ @head, { a => 8, b => 2, c => 7, d => 1 }, { a => 5, b => 7, c => 9, d => 3 }], "H Skip"); is_deeply (csv (@parg, skip_empty_rows => 2), \@head, "H EOF"); is (eval { csv (@parg, skip_empty_rows => 3); }, undef, "H die"); like ($@, qr{^Empty row}, "H msg"); is (eval { csv (@parg, skip_empty_rows => 4); }, undef, "H croak"); like ($@, qr{^Empty row}, "H msg"); $@ = ""; $csv = Text::CSV->new ({ skip_empty_rows => 5 }); is_deeply ($csv->csv (@parg), \@head, "H error"); is ($@, "", "H msg"); is (0 + $csv->error_diag, 2015, "H code"); $eh = { a => 1, b => 2, c => 3, d => 4 }; is_deeply (csv (@parg, skip_empty_rows => sub {\@repl}), [ @head, $eh, { a => 8, b => 2, c => 7, d => 1 },$eh,$eh, { a => 5, b => 7, c => 9, d => 3 },$eh], "H Callback"); is_deeply (csv (@parg, skip_empty_rows => sub {0}), \@head, "H Callback 0"); # Hash behavior (line by line) open $fh, "<", $tfn; $csv = Text::CSV->new ({ skip_empty_rows => 1 }); my $cols = $csv->getline ($fh); $csv->column_names (@$cols); while (my $row = $csv->getline_hr ($fh)) { isnt ($row->{a}, undef, "Column 'a' is defined"); } close $fh; Text-CSV-2.06/Changes0000644000175100017510000002300114761120445014455 0ustar ishigakiishigakiRevision history for Perl extension Text::CSV. 2.06 2025-03-03 - Imported tests/fixes from Text::CSV_XS 1.60 2.05 2025-01-11 - Imported tests/fixes from Text::CSV_XS 1.59 2.04 2023-12-02 - Imported tests/fixes from Text::CSV_XS 1.53 - Fixed skip_empty_rows('skip') and trailing newlines (GH#65, bugfood++) 2.03 2023-08-11 - Imported tests/fixes from Text::CSV_XS 1.51 2.02 2022-08-08 - Imported tests/fixes from Text::CSV_XS 1.48 - Fixed a case where csv function is called as a method (GH#46) 2.01 2021-06-19 - Imported tests/fixes from Text::CSV_XS 1.46 - Updated XS_Version to 1.46, and if an older version of Text::CSV_XS is installed, make sure to update it (GH#49, mohawk2++) 2.00 2019-05-11 - Imported tests/fixes from Text::CSV_XS 1.39 - Fix strict on streaming EOF - Fixed to update (cached) eol_len correctly 1.99 2019-01-02 - Fixed a number of tests to skip for older perls 1.98 2019-01-02 - Imported tests/fixes from Text::CSV_XS 1.38 - Added munge as alias for munge_column_names - Added support for key-value pair and combined keys 1.97 2018-08-17 - Fix/add minimum perl version (GH-38, Kivanc Yazan++) - Updated MANIFEST 1.96 2018-08-14 - Imported tests/fixes from Text::CSV_XS 1.36 - Added undef_str and keep_headers attributes - Added csv(out => \"skip") - Added formula actions - Fixed BOM issues - Fixed internal cache handling - Added license and preferred issue tracker to META files (GH#26, garu++) 1.95 2017-04-27 - import "strict" attribute introduced in Text::CSV_XS 1.29 1.94 2017-04-11 - Fix 5.6.2 issues 1.93 2017-04-04 - Fix a test for perl without doc in @INC (kentnl++) 1.92 2017-04-01 - Imported tests/fixes from Text::CSV_XS 1.28 - Fix crlf issue for csv () on Windows (RT#120466) - New error code for illegal argument(s)/parameter(s) - Fix tests for perl without dot in @INC 1.91 2017-01-28 - production release 1.90_01 2017-01-20 - Text::CSV_PP is totally refactored using the code/doc of Text::CSV_XS 1.27. Almost all the code/docs in CSV_XS.pm are copied and a large portion of CSV_XS.xs is ported verbatim, and now CSV_PP passes all the tests for CSV_XS (with slight modification like s/XS/PP/g). 1.33 Tue Mar 3 14:13:41 2015 - Fix some reported bugs with handling fields with zeros. https://rt.cpan.org/Public/Bug/Display.html?id=93518 https://rt.cpan.org/Public/Bug/Display.html?id=92509 patched by shlomif - catch up Text::CSV_XS 1.02 * add decode_utf8 attribute by ktat - fix warnings: $. is undefined by ktat - typo fixes in doc by anirvan, dsteinbrunner and pdl. - parse() supports bind_columns() * TODO: Updating documents and adding diag_verbose in the next version. Catching up CSV_XS 1.04. 1.32 - fix t/rt71_pp.t 1.31 Thu Jun 13 14:06:49 2013 - fix handling UTF8 in parse method. - fix getline with allow_loose_quotes (rt#83705) - add allow_unquoted_escape - fix parsing escapted sep char (found in Text::CSV_XS rt#81295) 1.30 Tue Jun 11 00:06:02 2013 - catch up Text::CSV_XS 0.99 (except for diag_verbose and allow_unquoted_escape) 1.21 Mon Dec 27 12:35:35 2010 - updated the compatibility for Text::CSV_XS version 0.80 * added getline_all() and getaline_hr_all() * added missing test file 1.20 Wed Oct 20 13:53:59 2010 - couldn't parse the csv containing the column starting with '0'. (hiratara) * patched by hiratara * enhanced getline regexp (makamaka) * resolved a bug in bleadperl-fb85c04 - added tests into t/71_pp.t (hiratara) 1.19 Sat Oct 2 14:15:59 2010 - getline didn't work correctly with 0 or null containing lines (pointed by Bernhard Prott) - updated the compatibility for Text::CSV_XS version 0.74 * real eol support for parsing streams (beyond \n, \r and \r\n) * clarify doc for always_quote to not quote undef fields and XS and PP incompatibility of UTF8 process for print and combine 1.18 Sat Jun 19 10:34:07 2010 - fixed a combine bug with quote_space reported and patched by rt#58356 - updated test files compatible to CSV_XS 0.73 1.17 Tue Mar 16 15:20:34 2010 - fixed parse working when setting quote_char undef. - made Text::CSV_XS compat 0.71 * Text::CSV->error_diag() in void context warns instead of doing nothing * auto_diag also used for new () itself - added quote_null (introduced in Text::CSV_XS 0.72) 1.16 Tue Dec 8 19:02:58 2009 - updated the compatibility for Text::CSV_XS version 0.70 * Added quote_space attribute * Forbad \r and \n in sep_char, quote_char, and escape_char 1.15 Thu Oct 15 17:23:39 2009 - updated the compatibility for Text::CSV_XS version 0.69 * Auto detection of eol => "\r" in streams (but incomplete correspondence. I will rewrite CSV_PP in the future) 1.14 Thu Oct 8 15:02:24 2009 - updated the compatibility for Text::CSV_XS version 0.68 * fail if first arg to new () is not a hash ref * added empty_is_undef * error_diag () uses warn () in void context instead of STDERR * added auto_diag attribute (not yet implemented localization feature for autodie) * updated documents same as Text::CSV_XS 1.13 Fri Jul 31 12:02:53 2009 - getline() didn't handle '0' starting multi line data (pointed by Diego Santa Cruz). 1.12 Sat May 16 10:46:38 2009 - updated the compatibility for Text::CSV_XS version 0.65 * new()ing errors can be checked on number (1002) * modified doc for error_diag() return value in case of constructor failure - parse() didn't set the given string ref into {_STRING}. (rt#45215) - getline() didn't handle a line having null (ex. "0) 1.11 Sat Mar 21 16:07:29 2009 - updated the compatibility for Text::CSV_XS version 0.63 * added error 1002 - updated the compatibility for Text::CSV_XS version 0.58 * fixed allow_loose_escapes bug 1.10 Wed Oct 22 02:34:03 2008 - updated the compatibility for Text::CSV_XS version 0.56 * updated docs * setting eol with undef are treated as "" * in print method, don't print $\ twice * undef treated as 0 for boolean attributes 1.09 Fri Sep 5 11:34:00 2008 - updated the compatibility for Text::CSV_XS version 0.54 * default eol for print is $\ * fixed SetDiag(0) * IO failure in print **** Text::CSV_PP doesn't support the error msg 2023 **** 1.08 Fri Aug 22 11:21:38 2008 - fixed a bug in parsing tab separated values with allow_whitespace pointed by and thanks a patch to Mike O'Sullivan 1.07 Fri Aug 1 11:13:06 2008 - updated the compatibility for Text::CSV_XS version 0.52 modified column_names() - fixed a parsing bug with quote_char being undef pointed by Matt (rt#38083) 1.06 Wed Jun 18 14:35:40 2008 - updated the compatibility for Text::CSV_XS version 0.51 * set binary => 1 when UTF8 flag marked. * removed the max of 255 for bind_columns. - made the value type of $csv->{_STRING} corresponding to XS. 1.05 Fri May 2 13:15:49 2008 - fixed quoting process in combine. because of using bytes.pm, added a dummy for Perl 5.005 - renamed combine, parse, string and fields internally. (for coming Text::CSV::Encoded) - removed dynamic mode. 1.04 Tue Apr 22 16:01:19 2008 - updated the compatibility for Text::CSV_XS version 0.43 * parse errors try to remember failing position (but in using PP version backend, it is usually helpless) - fix a serious bug with setter methods. all setter methods couldn't take undef value... 1.03 Fri Apr 11 17:39:12 2008 - updated the compatibility for Text::CSV_XS version 0.41 getline_hr, column_names, bind_columns - Makefile.PL requires Perl versoin from 5.005 to 5.00503. - fixed combine() for quoting binary chars. - updated the document as same as Text::CSV_XS 0.41. 1.02 Fri Mar 7 07:37:11 2008 - updated the compatibility for Text::CSV_XS version 0.36 * auto-load IO::Handle when needed - fixed version() and its doc (Text::CSV and Text::CSV_PP). Text::CSV->version returns the worker module version. Thanks to Robin Barker's patche. 1.01 Tue Mar 4 02:33:28 2008 - updated the compatibilities for Text::CSV_XS version 0.35 * diagnostics for failed new () * 'blank_is_undef' option * enhanced the error messages - updated docs - fixed allow_whitespace() - modifiled t/80_diag.t for overloaded error object. 1.00 Wed Nov 28 14:28:30 2007 - renamed $ENV{TEXT_CSV_XS} to $ENV{PERL_TEXT_CSV} - added $ENV{PERL_TEXT_CSV} acceptable values - deleted the dynamic mode section from the pod doc - deleted t/exp01-dynamic.t (the feature still remains.) 0.99_06 Thu Nov 8 13:24:31 2007 - modified _set_methods for Pod::Coverage test - added t/exp01-dynamic.t 0.99_05 Wed Nov 7 16:15:34 2007 (Text::CSV_PP 1.08) - added 'dynamic mode' which can specify the worker module in new()ing This is so experimental that may be removed. - modified prototypes of Text::CSV_PP::NV, IV, PV 0.99_04 Tue Nov 6 13:40:47 2007 (Text::CSV_PP 1.07) - re-rename Text::CSV_PP - added TODO 0.99_03 Mon Nov 5 16:00:00 2007 - CPAN released but beta version. - test suits are from Text::CSV_XS 0.32 and modfied for Text::CSV tests. 0.99_02 Fri Nov 2 14:37:30 2007 - pre release version. - passed the all Text::CSV_XS 0.32 test suits 0.99 Sat Jun 23 17:10:47 2007 - maintainer was changed. - rewritten to make a wrapper to Text::CSV_XS and Text::CSV_PP 0.01 06/05/1997 - original version by Alan Citterman Text-CSV-2.06/files/0000755000175100017510000000000014761120516014267 5ustar ishigakiishigakiText-CSV-2.06/files/macosx.csv0000644000175100017510000000164314600712237016301 0ustar ishigakiishigaki"'\'\\'\\\'""\""\\""\\\""",,,,,,,,,,,,,, Exported 12/16/2008 10:30 AM,,,,,,Category,Category name,,,,,Category name 2,, Username,Last Name,First Name M.,Section/Group,Status,Notes,Assignment,Category name 1,Category name 2,Category name 3,woot!,dqwdqwd,Category name 2 1,Total Score,Class Grade ,,,,,,Grading scale,Points,Points,Points,Points,Points,Points,, ,,,,,,Points possible,11,11,11,11,11,11,, dcwalker,,,,Dropped,,,1,34,1,,,,109, jdr99,,,devs,Active,"qwd qwd qwd",,12,0,1,,,,39, jlaney,,,devs,Active,,,,2,23,,,,114, mcrawfor,,,devs,Active,"line 1 line 2 line 3 XX fwe and so on yea!",,,,,,,,, ,,,,,,,,,,,,,, ,,,,,,Mean,6.5,12.0,8.33,#DIV/0!,#DIV/0!,#DIV/0!,87.33, ,,,,,,Median,6.5,2.0,1.0,#NUM!,#NUM!,#NUM!,109.0, ,,,,,,Mode,#N/A,#N/A,1.0,#N/A,#N/A,#N/A,#N/A, ,,,,,,Min,1.0,0.0,1.0,0.0,0.0,0.0,39.0, ,,,,,,Max,12.0,34.0,23.0,0.0,0.0,0.0,114.0, ,,,,,,Std. Dev.,7.78,19.08,12.7,#DIV/0!,#DIV/0!,#DIV/0!,41.93,Text-CSV-2.06/files/utf8.csv0000644000175100017510000000001414600712237015664 0ustar ishigakiishigaki"Øl/Vin",0 Text-CSV-2.06/README.md0000644000175100017510000000173014600712237014444 0ustar ishigakiishigakiText::CSV version 1.33 ---------------------- Text::CSV provides facilities for the composition and decomposition of comma-separated values. An instance of the Text::CSV class can combine fields into a CSV string and parse a CSV string into fields. The module accepts either strings or files as input and can utilize any user-specified characters as delimiters, separators, and escapes so it is perhaps better called ASV (anything separated values) rather than just CSV. Please refer to the [complete documentation of Text::CSV](https://metacpan.org/pod/Text::CSV) for more information. #### Installation #### cpanm Text::CSV Or manually: perl Makefile.PL make make test make install #### Copyright and License #### Copyright (C) 1997 Alan Citterman. All rights reserved. Copyright (C) 2007-2015 Makamaka Hannyaharamitu. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Text-CSV-2.06/lib/0000755000175100017510000000000014761120516013733 5ustar ishigakiishigakiText-CSV-2.06/lib/Text/0000755000175100017510000000000014761120516014657 5ustar ishigakiishigakiText-CSV-2.06/lib/Text/CSV_PP.pm0000644000175100017510000062330014761120412016246 0ustar ishigakiishigakipackage Text::CSV_PP; ################################################################################ # # Text::CSV_PP - Text::CSV_XS compatible pure-Perl module # ################################################################################ require 5.006001; use strict; use Exporter (); use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS); use Carp; $VERSION = '2.06'; @ISA = qw(Exporter); sub PV { 0 } sub IV { 1 } sub NV { 2 } sub CSV_TYPE_PV { PV } sub CSV_TYPE_IV { IV } sub CSV_TYPE_NV { NV } sub IS_QUOTED () { 0x0001; } sub IS_BINARY () { 0x0002; } sub IS_ERROR () { 0x0004; } sub IS_MISSING () { 0x0010; } sub CSV_FLAGS_IS_QUOTED { IS_QUOTED } sub CSV_FLAGS_IS_BINARY { IS_BINARY } sub CSV_FLAGS_ERROR_IN_FIELD { IS_ERROR } sub CSV_FLAGS_IS_MISSING { IS_MISSING } sub HOOK_ERROR () { 0x0001; } sub HOOK_AFTER_PARSE () { 0x0002; } sub HOOK_BEFORE_PRINT () { 0x0004; } sub EOL_TYPE_UNDEF () { 0 } sub EOL_TYPE_NL () { 1 } sub EOL_TYPE_CR () { 2 } sub EOL_TYPE_CRNL () { 3 } sub EOL_TYPE_OTHER () { 4 } sub useIO_EOF () { 0x0010; } %EXPORT_TAGS = ( CONSTANTS => [qw( CSV_FLAGS_IS_QUOTED CSV_FLAGS_IS_BINARY CSV_FLAGS_ERROR_IN_FIELD CSV_FLAGS_IS_MISSING CSV_TYPE_PV CSV_TYPE_IV CSV_TYPE_NV )], ); @EXPORT_OK = (qw(csv PV IV NV), @{$EXPORT_TAGS{'CONSTANTS'}}); my $ERRORS = { # Generic errors 1000 => "INI - constructor failed", 1001 => "INI - sep_char is equal to quote_char or escape_char", 1002 => "INI - allow_whitespace with escape_char or quote_char SP or TAB", 1003 => "INI - \\r or \\n in main attr not allowed", 1004 => "INI - callbacks should be undef or a hashref", 1005 => "INI - EOL too long", 1006 => "INI - SEP too long", 1007 => "INI - QUOTE too long", 1008 => "INI - SEP undefined", 1010 => "INI - the header is empty", 1011 => "INI - the header contains more than one valid separator", 1012 => "INI - the header contains an empty field", 1013 => "INI - the header contains nun-unique fields", 1014 => "INI - header called on undefined stream", # Syntax errors 1500 => "PRM - Invalid/unsupported arguments(s)", 1501 => "PRM - The key attribute is passed as an unsupported type", 1502 => "PRM - The value attribute is passed without the key attribute", 1503 => "PRM - The value attribute is passed as an unsupported type", # Parse errors 2010 => "ECR - QUO char inside quotes followed by CR not part of EOL", 2011 => "ECR - Characters after end of quoted field", 2012 => "EOF - End of data in parsing input stream", 2013 => "ESP - Specification error for fragments RFC7111", 2014 => "ENF - Inconsistent number of fields", 2015 => "ERW - Empty row", 2016 => "EOL - Inconsistent EOL", # EIQ - Error Inside Quotes 2021 => "EIQ - NL char inside quotes, binary off", 2022 => "EIQ - CR char inside quotes, binary off", 2023 => "EIQ - QUO character not allowed", 2024 => "EIQ - EOF cannot be escaped, not even inside quotes", 2025 => "EIQ - Loose unescaped escape", 2026 => "EIQ - Binary character inside quoted field, binary off", 2027 => "EIQ - Quoted field not terminated", # EIF - Error Inside Field 2030 => "EIF - NL char inside unquoted verbatim, binary off", 2031 => "EIF - CR char is first char of field, not part of EOL", 2032 => "EIF - CR char inside unquoted, not part of EOL", 2034 => "EIF - Loose unescaped quote", 2035 => "EIF - Escaped EOF in unquoted field", 2036 => "EIF - ESC error", 2037 => "EIF - Binary character in unquoted field, binary off", # Combine errors 2110 => "ECB - Binary character in Combine, binary off", # IO errors 2200 => "EIO - print to IO failed. See errno", # Hash-Ref errors 3001 => "EHR - Unsupported syntax for column_names ()", 3002 => "EHR - getline_hr () called before column_names ()", 3003 => "EHR - bind_columns () and column_names () fields count mismatch", 3004 => "EHR - bind_columns () only accepts refs to scalars", 3006 => "EHR - bind_columns () did not pass enough refs for parsed fields", 3007 => "EHR - bind_columns needs refs to writable scalars", 3008 => "EHR - unexpected error in bound fields", 3009 => "EHR - print_hr () called before column_names ()", 3010 => "EHR - print_hr () called with invalid arguments", 4001 => "PRM - The key does not exist as field in the data", 5001 => "PRM - The result does not match the output to append to", 5002 => "PRM - Unsupported output", 0 => "", }; BEGIN { if ($] < 5.006) { $INC{'bytes.pm'} = 1 unless $INC{'bytes.pm'}; # dummy no strict 'refs'; *{"utf8::is_utf8"} = sub { 0; }; *{"utf8::decode"} = sub { }; } elsif ($] < 5.008) { no strict 'refs'; *{"utf8::is_utf8"} = sub { 0; }; *{"utf8::decode"} = sub { }; *{"utf8::encode"} = sub { }; } elsif (!defined &utf8::is_utf8) { require Encode; *utf8::is_utf8 = *Encode::is_utf8; } eval q| require Scalar::Util |; if ($@) { eval q| require B |; if ($@) { Carp::croak $@; } else { my %tmap = qw( B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP ); *Scalar::Util::reftype = sub (\$) { my $r = shift; return undef unless length(ref($r)); my $t = ref(B::svref_2object($r)); return exists $tmap{$t} ? $tmap{$t} : length(ref($$r)) ? 'REF' : 'SCALAR'; }; *Scalar::Util::readonly = sub (\$) { my $b = B::svref_2object($_[0]); $b->FLAGS & 0x00800000; # SVf_READONLY? }; } } } ################################################################################ # # Common pure perl methods, taken almost directly from Text::CSV_XS. # (These should be moved into a common class eventually, so that # both XS and PP don't need to apply the same changes.) # ################################################################################ ################################################################################ # version ################################################################################ sub version { return $VERSION; } ################################################################################ # new ################################################################################ my %def_attr = ( eol => '', sep_char => ',', quote_char => '"', escape_char => '"', binary => 0, decode_utf8 => 1, auto_diag => 0, diag_verbose => 0, strict => 0, strict_eol => 0, blank_is_undef => 0, empty_is_undef => 0, allow_whitespace => 0, allow_loose_quotes => 0, allow_loose_escapes => 0, allow_unquoted_escape => 0, always_quote => 0, quote_empty => 0, quote_space => 1, quote_binary => 1, escape_null => 1, keep_meta_info => 0, verbatim => 0, formula => 0, skip_empty_rows => 0, undef_str => undef, comment_str => undef, types => undef, callbacks => undef, _EOF => "", _RECNO => 0, _STATUS => undef, _FIELDS => undef, _FFLAGS => undef, _STRING => undef, _ERROR_INPUT => undef, _COLUMN_NAMES => undef, _BOUND_COLUMNS => undef, _AHEAD => undef, _FORMULA_CB => undef, _EMPTROW_CB => undef, ENCODING => undef, ); my %attr_alias = ( quote_always => "always_quote", verbose_diag => "diag_verbose", quote_null => "escape_null", escape => "escape_char", comment => "comment_str", ); my $last_err = Text::CSV_PP->SetDiag(0); my $ebcdic = ord("A") == 0xC1; # Faster than $Config{'ebcdic'} my @internal_kh; # NOT a method: is also used before bless sub _unhealthy_whitespace { my ($self, $aw) = @_; $aw or return 0; # no checks needed without allow_whitespace my $quo = $self->{quote}; defined $quo && length($quo) or $quo = $self->{quote_char}; my $esc = $self->{escape_char}; defined $quo && $quo =~ m/^[ \t]/ and return 1002; defined $esc && $esc =~ m/^[ \t]/ and return 1002; return 0; } sub _check_sanity { my $self = shift; my $eol = $self->{eol}; my $sep = $self->{sep}; defined $sep && length($sep) or $sep = $self->{sep_char}; my $quo = $self->{quote}; defined $quo && length($quo) or $quo = $self->{quote_char}; my $esc = $self->{escape_char}; # use DP;::diag ("SEP: '", DPeek ($sep), # "', QUO: '", DPeek ($quo), # "', ESC: '", DPeek ($esc),"'"); # sep_char should not be undefined $sep ne "" or return 1008; length($sep) > 16 and return 1006; $sep =~ m/[\r\n]/ and return 1003; if (defined $quo) { $quo eq $sep and return 1001; length($quo) > 16 and return 1007; $quo =~ m/[\r\n]/ and return 1003; } if (defined $esc) { $esc eq $sep and return 1001; $esc =~ m/[\r\n]/ and return 1003; } if (defined $eol) { length($eol) > 16 and return 1005; } return _unhealthy_whitespace($self, $self->{allow_whitespace}); } sub known_attributes { sort grep !m/^_/ => "sep", "quote", keys %def_attr; } sub new { $last_err = Text::CSV_PP->SetDiag(1000, "usage: my \$csv = Text::CSV_PP->new ([{ option => value, ... }]);"); my $proto = shift; my $class = ref $proto || $proto or return; @_ > 0 && ref $_[0] ne "HASH" and return; my $attr = shift || {}; my %attr = map { my $k = m/^[a-zA-Z]\w+$/ ? lc $_ : $_; exists $attr_alias{$k} and $k = $attr_alias{$k}; ($k => $attr->{$_}); } keys %{$attr}; my $sep_aliased = 0; if (exists $attr{sep}) { $attr{sep_char} = delete $attr{sep}; $sep_aliased = 1; } my $quote_aliased = 0; if (exists $attr{quote}) { $attr{quote_char} = delete $attr{quote}; $quote_aliased = 1; } exists $attr{formula_handling} and $attr{formula} = delete $attr{formula_handling}; my $attr_formula = delete $attr{formula}; for (keys %attr) { if (m/^[a-z]/ && exists $def_attr{$_}) { # uncoverable condition false defined $attr{$_} && m/_char$/ and utf8::decode($attr{$_}); next; } # croak? $last_err = Text::CSV_PP->SetDiag(1000, "INI - Unknown attribute '$_'"); $attr{auto_diag} and error_diag(); return; } if ($sep_aliased) { my @b = unpack "U0C*", $attr{sep_char}; if (@b > 1) { $attr{sep} = $attr{sep_char}; $attr{sep_char} = "\0"; } else { $attr{sep} = undef; } } if ($quote_aliased and defined $attr{quote_char}) { my @b = unpack "U0C*", $attr{quote_char}; if (@b > 1) { $attr{quote} = $attr{quote_char}; $attr{quote_char} = "\0"; } else { $attr{quote} = undef; } } my $self = {%def_attr, %attr}; if (my $ec = _check_sanity($self)) { $last_err = Text::CSV_PP->SetDiag($ec); $attr{auto_diag} and error_diag(); return; } if (defined $self->{callbacks} && ref $self->{callbacks} ne "HASH") { carp("The 'callbacks' attribute is set but is not a hash: ignored\n"); $self->{callbacks} = undef; } $last_err = Text::CSV_PP->SetDiag(0); defined $\ && !exists $attr{eol} and $self->{eol} = $\; bless $self, $class; defined $self->{'types'} and $self->types($self->{'types'}); defined $self->{'skip_empty_rows'} and $self->{'skip_empty_rows'} = _supported_skip_empty_rows($self, $self->{'skip_empty_rows'}); defined $attr_formula and $self->{'formula'} = _supported_formula($self, $attr_formula); $self; } # Keep in sync with XS! my %_cache_id = ( # Only expose what is accessed from within PM quote_char => 0, escape_char => 1, sep_char => 2, always_quote => 4, quote_empty => 5, quote_space => 6, quote_binary => 7, allow_loose_quotes => 8, allow_loose_escapes => 9, allow_unquoted_escape => 10, allow_whitespace => 11, blank_is_undef => 12, empty_is_undef => 13, auto_diag => 14, diag_verbose => 15, escape_null => 16, formula => 18, decode_utf8 => 21, verbatim => 23, strict_eol => 24, eol_type => 27, strict => 28, skip_empty_rows => 29, binary => 30, keep_meta_info => 31, _has_hooks => 32, _has_ahead => 33, _is_bound => 44, eol => 100, sep => 116, quote => 132, undef_str => 148, comment_str => 156, types => 92, ); my %_hidden_cache_id = ( has_error_input => 20, eol_is_cr => 26, eol_len => 36, sep_len => 37, quo_len => 38, ); my %_reverse_cache_id = ( map({ $_cache_id{$_} => $_ } keys %_cache_id), map({ $_hidden_cache_id{$_} => $_ } keys %_hidden_cache_id), ); # A `character' sub _set_attr_C { my ($self, $name, $val, $ec) = @_; defined $val and utf8::decode($val); $self->{$name} = $val; $ec = _check_sanity($self) and croak($self->SetDiag($ec)); $self->_cache_set($_cache_id{$name}, $val); } # A flag sub _set_attr_X { my ($self, $name, $val) = @_; defined $val or $val = 0; $self->{$name} = $val; $self->_cache_set($_cache_id{$name}, 0 + $val); } # A number sub _set_attr_N { my ($self, $name, $val) = @_; $self->{$name} = $val; $self->_cache_set($_cache_id{$name}, 0 + $val); } # Accessor methods. # It is unwise to change them halfway through a single file! sub quote_char { my $self = shift; if (@_) { $self->_set_attr_C("quote_char", shift); $self->_cache_set($_cache_id{quote}, ""); } $self->{quote_char}; } sub quote { my $self = shift; if (@_) { my $quote = shift; defined $quote or $quote = ""; utf8::decode($quote); my @b = unpack "U0C*", $quote; if (@b > 1) { @b > 16 and croak($self->SetDiag(1007)); $self->quote_char("\0"); } else { $self->quote_char($quote); $quote = ""; } $self->{quote} = $quote; my $ec = _check_sanity($self); $ec and croak($self->SetDiag($ec)); $self->_cache_set($_cache_id{quote}, $quote); } my $quote = $self->{quote}; defined $quote && length($quote) ? $quote : $self->{quote_char}; } sub escape_char { my $self = shift; if (@_) { my $ec = shift; $self->_set_attr_C("escape_char", $ec); $ec or $self->_set_attr_X("escape_null", 0); } $self->{escape_char}; } sub sep_char { my $self = shift; if (@_) { $self->_set_attr_C("sep_char", shift); $self->_cache_set($_cache_id{sep}, ""); } $self->{sep_char}; } sub sep { my $self = shift; if (@_) { my $sep = shift; defined $sep or $sep = ""; utf8::decode($sep); my @b = unpack "U0C*", $sep; if (@b > 1) { @b > 16 and croak($self->SetDiag(1006)); $self->sep_char("\0"); } else { $self->sep_char($sep); $sep = ""; } $self->{sep} = $sep; my $ec = _check_sanity($self); $ec and croak($self->SetDiag($ec)); $self->_cache_set($_cache_id{sep}, $sep); } my $sep = $self->{sep}; defined $sep && length($sep) ? $sep : $self->{sep_char}; } sub eol { my $self = shift; if (@_) { my $eol = shift; defined $eol or $eol = ""; # Also reset strict_eol? length($eol) > 16 and croak($self->SetDiag(1005)); $self->{eol} = $eol; $self->_cache_set($_cache_id{eol}, $eol); } $self->{eol}; } sub eol_type { my $self = shift; $self->_cache_get_eolt; } sub always_quote { my $self = shift; @_ and $self->_set_attr_X("always_quote", shift); $self->{always_quote}; } sub quote_space { my $self = shift; @_ and $self->_set_attr_X("quote_space", shift); $self->{quote_space}; } sub quote_empty { my $self = shift; @_ and $self->_set_attr_X("quote_empty", shift); $self->{quote_empty}; } sub escape_null { my $self = shift; @_ and $self->_set_attr_X("escape_null", shift); $self->{escape_null}; } sub quote_null { goto &escape_null; } sub quote_binary { my $self = shift; @_ and $self->_set_attr_X("quote_binary", shift); $self->{quote_binary}; } sub binary { my $self = shift; @_ and $self->_set_attr_X("binary", shift); $self->{binary}; } sub strict { my $self = shift; @_ and $self->_set_attr_X("strict", shift); $self->{strict}; } sub strict_eol { my $self = shift; @_ and $self->_set_attr_X("strict_eol", shift); $self->{'strict_eol'}; } sub _supported_skip_empty_rows { my ($self, $f) = @_; defined $f or return 0; if ($self && $f && ref $f && ref $f eq "CODE") { $self->{'_EMPTROW_CB'} = $f; return 6; } $f =~ m/^(?: 0 | undef )$/xi ? 0 : $f =~ m/^(?: 1 | skip )$/xi ? 1 : $f =~ m/^(?: 2 | eof | stop )$/xi ? 2 : $f =~ m/^(?: 3 | die )$/xi ? 3 : $f =~ m/^(?: 4 | croak )$/xi ? 4 : $f =~ m/^(?: 5 | error )$/xi ? 5 : $f =~ m/^(?: 6 | cb )$/xi ? 6 : do { $self ||= "Text::CSV_PP"; croak($self->_SetDiagInfo(1500, "skip_empty_rows '$f' is not supported")); }; } sub skip_empty_rows { my $self = shift; @_ and $self->_set_attr_N("skip_empty_rows", _supported_skip_empty_rows($self, shift)); my $ser = $self->{'skip_empty_rows'}; $ser == 6 or $self->{'_EMPTROW_CB'} = undef; $ser <= 1 ? $ser : $ser == 2 ? "eof" : $ser == 3 ? "die" : $ser == 4 ? "croak" : $ser == 5 ? "error" : $self->{'_EMPTROW_CB'}; } sub _SetDiagInfo { my ($self, $err, $msg) = @_; $self->SetDiag($err); my $em = $self->error_diag(); $em =~ s/^\d+$// and $msg =~ s/^/# /; my $sep = $em =~ m/[;\n]$/ ? "\n\t" : ": "; join $sep => grep m/\S\S\S/ => $em, $msg; } sub _supported_formula { my ($self, $f) = @_; defined $f or return 5; if ($self && $f && ref $f && ref $f eq "CODE") { $self->{_FORMULA_CB} = $f; return 6; } $f =~ m/^(?: 0 | none )$/xi ? 0 : $f =~ m/^(?: 1 | die )$/xi ? 1 : $f =~ m/^(?: 2 | croak )$/xi ? 2 : $f =~ m/^(?: 3 | diag )$/xi ? 3 : $f =~ m/^(?: 4 | empty | )$/xi ? 4 : $f =~ m/^(?: 5 | undef )$/xi ? 5 : $f =~ m/^(?: 6 | cb )$/xi ? 6 : do { $self ||= "Text::CSV_PP"; croak($self->_SetDiagInfo(1500, "formula-handling '$f' is not supported")); }; } sub formula { my $self = shift; @_ and $self->_set_attr_N("formula", _supported_formula($self, shift)); $self->{formula} == 6 or $self->{_FORMULA_CB} = undef; [qw( none die croak diag empty undef cb )]->[_supported_formula($self, $self->{formula})]; } sub formula_handling { my $self = shift; $self->formula(@_); } sub decode_utf8 { my $self = shift; @_ and $self->_set_attr_X("decode_utf8", shift); $self->{decode_utf8}; } sub keep_meta_info { my $self = shift; if (@_) { my $v = shift; !defined $v || $v eq "" and $v = 0; $v =~ m/^[0-9]/ or $v = lc $v eq "false" ? 0 : 1; # true/truth = 1 $self->_set_attr_X("keep_meta_info", $v); } $self->{keep_meta_info}; } sub allow_loose_quotes { my $self = shift; @_ and $self->_set_attr_X("allow_loose_quotes", shift); $self->{allow_loose_quotes}; } sub allow_loose_escapes { my $self = shift; @_ and $self->_set_attr_X("allow_loose_escapes", shift); $self->{allow_loose_escapes}; } sub allow_whitespace { my $self = shift; if (@_) { my $aw = shift; _unhealthy_whitespace($self, $aw) and croak($self->SetDiag(1002)); $self->_set_attr_X("allow_whitespace", $aw); } $self->{allow_whitespace}; } sub allow_unquoted_escape { my $self = shift; @_ and $self->_set_attr_X("allow_unquoted_escape", shift); $self->{allow_unquoted_escape}; } sub blank_is_undef { my $self = shift; @_ and $self->_set_attr_X("blank_is_undef", shift); $self->{blank_is_undef}; } sub empty_is_undef { my $self = shift; @_ and $self->_set_attr_X("empty_is_undef", shift); $self->{empty_is_undef}; } sub verbatim { my $self = shift; @_ and $self->_set_attr_X("verbatim", shift); $self->{verbatim}; } sub undef_str { my $self = shift; if (@_) { my $v = shift; $self->{undef_str} = defined $v ? "$v" : undef; $self->_cache_set($_cache_id{undef_str}, $self->{undef_str}); } $self->{undef_str}; } sub comment_str { my $self = shift; if (@_) { my $v = shift; $self->{comment_str} = defined $v ? "$v" : undef; $self->_cache_set($_cache_id{comment_str}, $self->{comment_str}); } $self->{comment_str}; } sub auto_diag { my $self = shift; if (@_) { my $v = shift; !defined $v || $v eq "" and $v = 0; $v =~ m/^[0-9]/ or $v = lc $v eq "false" ? 0 : 1; # true/truth = 1 $self->_set_attr_X("auto_diag", $v); } $self->{auto_diag}; } sub diag_verbose { my $self = shift; if (@_) { my $v = shift; !defined $v || $v eq "" and $v = 0; $v =~ m/^[0-9]/ or $v = lc $v eq "false" ? 0 : 1; # true/truth = 1 $self->_set_attr_X("diag_verbose", $v); } $self->{diag_verbose}; } ################################################################################ # status ################################################################################ sub status { my $self = shift; return $self->{_STATUS}; } sub eof { my $self = shift; return $self->{_EOF}; } sub types { my $self = shift; if (@_) { if (my $types = shift) { $self->{'_types'} = join "", map { chr } @{$types}; $self->{'types'} = $types; $self->_cache_set($_cache_id{'types'}, $self->{'_types'}); } else { delete $self->{'types'}; delete $self->{'_types'}; $self->_cache_set($_cache_id{'types'}, undef); undef; } } else { $self->{'types'}; } } sub callbacks { my $self = shift; if (@_) { my $cb; my $hf = 0x00; if (defined $_[0]) { grep { !defined } @_ and croak($self->SetDiag(1004)); $cb = @_ == 1 && ref $_[0] eq "HASH" ? shift : @_ % 2 == 0 ? {@_} : croak($self->SetDiag(1004)); foreach my $cbk (keys %{$cb}) { # A key cannot be a ref. That would be stored as the *string # 'SCALAR(0x1f3e710)' or 'ARRAY(0x1a5ae18)' $cbk =~ m/^[\w.]+$/ && ref $cb->{$cbk} eq "CODE" or croak($self->SetDiag(1004)); } exists $cb->{error} and $hf |= 0x01; exists $cb->{after_parse} and $hf |= 0x02; exists $cb->{before_print} and $hf |= 0x04; } elsif (@_ > 1) { # (undef, whatever) croak($self->SetDiag(1004)); } $self->_set_attr_X("_has_hooks", $hf); $self->{callbacks} = $cb; } $self->{callbacks}; } ################################################################################ # error_diag ################################################################################ sub error_diag { my $self = shift; my @diag = (0 + $last_err, $last_err, 0, 0, 0, 0); # Docs state to NEVER use UNIVERSAL::isa, because it will *never* call an # overridden isa method in any class. Well, that is exacly what I want here if ($self && ref $self and # Not a class method or direct call UNIVERSAL::isa($self, __PACKAGE__) && exists $self->{_ERROR_DIAG}) { $diag[0] = 0 + $self->{_ERROR_DIAG}; $diag[1] = $self->{_ERROR_DIAG}; $diag[2] = 1 + $self->{_ERROR_POS} if exists $self->{_ERROR_POS}; $diag[3] = $self->{_RECNO}; $diag[4] = $self->{_ERROR_FLD} if exists $self->{_ERROR_FLD}; $diag[5] = $self->{_ERROR_SRC} if exists $self->{_ERROR_SRC} && $self->{diag_verbose}; $diag[0] && $self->{callbacks} && $self->{callbacks}{error} and return $self->{callbacks}{error}->(@diag); } my $context = wantarray; unless (defined $context) { # Void context, auto-diag if ($diag[0] && $diag[0] != 2012) { my $msg = "# CSV_PP ERROR: $diag[0] - $diag[1] \@ rec $diag[3] pos $diag[2]\n"; $diag[4] and $msg =~ s/$/ field $diag[4]/; $diag[5] and $msg =~ s/$/ (PP#$diag[5])/; unless ($self && ref $self) { # auto_diag # called without args in void context warn $msg; return; } $self->{diag_verbose} && $self->{_ERROR_INPUT} and $msg .= $self->{_ERROR_INPUT} . "\n" . (" " x ($diag[2] - 1)) . "^\n"; my $lvl = $self->{auto_diag}; if ($lvl < 2) { my @c = caller(2); if (@c >= 11 && $c[10] && ref $c[10] eq "HASH") { my $hints = $c[10]; (exists $hints->{autodie} && $hints->{autodie} or exists $hints->{'guard Fatal'} && !exists $hints->{'no Fatal'}) and $lvl++; # Future releases of autodie will probably set $^H{autodie} # to "autodie @args", like "autodie :all" or "autodie open" # so we can/should check for "open" or "new" } } $lvl > 1 ? die $msg : warn $msg; } return; } return $context ? @diag : $diag[1]; } sub record_number { my $self = shift; return $self->{_RECNO}; } ################################################################################ # string ################################################################################ *string = \&_string; sub _string { my $self = shift; return ref $self->{_STRING} ? ${$self->{_STRING}} : undef; } ################################################################################ # fields ################################################################################ *fields = \&_fields; sub _fields { my $self = shift; return ref $self->{_FIELDS} ? @{$self->{_FIELDS}} : undef; } ################################################################################ # meta_info ################################################################################ sub meta_info { my $self = shift; return ref $self->{_FFLAGS} ? @{$self->{_FFLAGS}} : undef; } sub is_quoted { my ($self, $idx) = @_; ref $self->{_FFLAGS} && $idx >= 0 && $idx < @{$self->{_FFLAGS}} or return; $self->{_FFLAGS}[$idx] & CSV_FLAGS_IS_QUOTED() ? 1 : 0; } sub is_binary { my ($self, $idx) = @_; ref $self->{_FFLAGS} && $idx >= 0 && $idx < @{$self->{_FFLAGS}} or return; $self->{_FFLAGS}[$idx] & CSV_FLAGS_IS_BINARY() ? 1 : 0; } sub is_missing { my ($self, $idx) = @_; $idx < 0 || !ref $self->{_FFLAGS} and return; $idx >= @{$self->{_FFLAGS}} and return 1; $self->{_FFLAGS}[$idx] & CSV_FLAGS_IS_MISSING() ? 1 : 0; } ################################################################################ # combine ################################################################################ *combine = \&_combine; sub _combine { my $self = shift; my $str = ""; $self->{_FIELDS} = \@_; $self->{_STATUS} = (@_ > 0) && $self->__combine(\$str, \@_, 0); $self->{_STRING} = \$str; $self->{_STATUS}; } ################################################################################ # parse ################################################################################ *parse = \&_parse; sub _parse { my ($self, $str) = @_; ref $str and croak($self->SetDiag(1500)); my $fields = []; my $fflags = []; $self->{_STRING} = \$str; if (defined $str && $self->__parse($fields, $fflags, $str, 0)) { $self->{_FIELDS} = $fields; $self->{_FFLAGS} = $fflags; $self->{_STATUS} = 1; } else { $self->{_FIELDS} = undef; $self->{_FFLAGS} = undef; $self->{_STATUS} = 0; } $self->{_STATUS}; } sub column_names { my ($self, @keys) = @_; @keys or return defined $self->{_COLUMN_NAMES} ? @{$self->{_COLUMN_NAMES}} : (); @keys == 1 && !defined $keys[0] and return $self->{_COLUMN_NAMES} = undef; if (@keys == 1 && ref $keys[0] eq "ARRAY") { @keys = @{$keys[0]}; } elsif (join "", map { defined $_ ? ref $_ : "" } @keys) { croak($self->SetDiag(3001)); } $self->{_BOUND_COLUMNS} && @keys != @{$self->{_BOUND_COLUMNS}} and croak($self->SetDiag(3003)); $self->{_COLUMN_NAMES} = [map { defined $_ ? $_ : "\cAUNDEF\cA" } @keys]; @{$self->{_COLUMN_NAMES}}; } sub header { my ($self, $fh, @args) = @_; $fh or croak($self->SetDiag(1014)); my (@seps, %args); for (@args) { if (ref $_ eq "ARRAY") { push @seps, @{$_}; next; } if (ref $_ eq "HASH") { %args = %{$_}; next; } croak('usage: $csv->header ($fh, [ seps ], { options })'); } defined $args{munge} && !defined $args{munge_column_names} and $args{munge_column_names} = $args{munge}; # munge as alias defined $args{detect_bom} or $args{detect_bom} = 1; defined $args{set_column_names} or $args{set_column_names} = 1; defined $args{munge_column_names} or $args{munge_column_names} = "lc"; # Reset any previous leftovers $self->{_RECNO} = 0; $self->{_AHEAD} = undef; $self->{_COLUMN_NAMES} = undef if $args{set_column_names}; $self->{_BOUND_COLUMNS} = undef if $args{set_column_names}; $self->_cache_set($_cache_id{'_has_ahead'}, 0); if (defined $args{sep_set}) { ref $args{sep_set} eq "ARRAY" or croak($self->_SetDiagInfo(1500, "sep_set should be an array ref")); @seps = @{$args{sep_set}}; } $^O eq "MSWin32" and binmode $fh; my $hdr = <$fh>; # check if $hdr can be empty here, I don't think so defined $hdr && $hdr ne "" or croak($self->SetDiag(1010)); my %sep; @seps or @seps = (",", ";"); foreach my $sep (@seps) { index($hdr, $sep) >= 0 and $sep{$sep}++; } keys %sep >= 2 and croak($self->SetDiag(1011)); $self->sep(keys %sep); my $enc = ""; if ($args{detect_bom}) { # UTF-7 is not supported if ($hdr =~ s/^\x00\x00\xfe\xff//) { $enc = "utf-32be" } elsif ($hdr =~ s/^\xff\xfe\x00\x00//) { $enc = "utf-32le" } elsif ($hdr =~ s/^\xfe\xff//) { $enc = "utf-16be" } elsif ($hdr =~ s/^\xff\xfe//) { $enc = "utf-16le" } elsif ($hdr =~ s/^\xef\xbb\xbf//) { $enc = "utf-8" } elsif ($hdr =~ s/^\xf7\x64\x4c//) { $enc = "utf-1" } elsif ($hdr =~ s/^\xdd\x73\x66\x73//) { $enc = "utf-ebcdic" } elsif ($hdr =~ s/^\x0e\xfe\xff//) { $enc = "scsu" } elsif ($hdr =~ s/^\xfb\xee\x28//) { $enc = "bocu-1" } elsif ($hdr =~ s/^\x84\x31\x95\x33//) { $enc = "gb-18030" } elsif ($hdr =~ s/^\x{feff}//) { $enc = "" } $self->{ENCODING} = $enc ? uc $enc : undef; $hdr eq "" and croak($self->SetDiag(1010)); if ($enc) { $ebcdic && $enc eq "utf-ebcdic" and $enc = ""; if ($enc =~ m/([13]).le$/) { my $l = 0 + $1; my $x; $hdr .= "\0" x $l; read $fh, $x, $l; } if ($enc) { if ($enc ne "utf-8") { require Encode; $hdr = Encode::decode($enc, $hdr); } binmode $fh, ":encoding($enc)"; } } } my ($ahead, $eol); if ($hdr and $hdr =~ s/\Asep=(\S)([\r\n]+)//i) { # Also look in xs:Parse $self->sep($1); length $hdr or $hdr = <$fh>; } if ($hdr =~ s/^([^\r\n]+)([\r\n]+)([^\r\n].+)\z/$1/s) { $eol = $2; $ahead = $3; } my $hr = \$hdr; # Will cause croak on perl-5.6.x open my $h, "<", $hr or croak($self->SetDiag(1010)); my $row = $self->getline($h) or croak(); close $h; if ($args{'munge_column_names'} eq "lc") { $_ = lc for @{$row}; } elsif ($args{'munge_column_names'} eq "uc") { $_ = uc for @{$row}; } elsif ($args{'munge_column_names'} eq "db") { for (@{$row}) { s/\W+/_/g; s/^_+//; $_ = lc; } } if ($ahead) { # Must be after getline, which creates the cache $self->_cache_set($_cache_id{_has_ahead}, 1); $self->{_AHEAD} = $ahead; $eol =~ m/^\r([^\n]|\z)/ and $self->eol($eol); } my @hdr = @{$row}; ref $args{munge_column_names} eq "CODE" and @hdr = map { $args{munge_column_names}->($_) } @hdr; ref $args{munge_column_names} eq "HASH" and @hdr = map { $args{munge_column_names}->{$_} || $_ } @hdr; my %hdr; $hdr{$_}++ for @hdr; exists $hdr{''} and croak($self->SetDiag(1012)); unless (keys %hdr == @hdr) { croak($self->_SetDiagInfo(1013, join ", " => map { "$_ ($hdr{$_})" } grep { $hdr{$_} > 1 } keys %hdr)); } $args{set_column_names} and $self->column_names(@hdr); wantarray ? @hdr : $self; } sub bind_columns { my ($self, @refs) = @_; @refs or return defined $self->{_BOUND_COLUMNS} ? @{$self->{_BOUND_COLUMNS}} : undef; if (@refs == 1 && !defined $refs[0]) { $self->{_COLUMN_NAMES} = undef; return $self->{_BOUND_COLUMNS} = undef; } $self->{_COLUMN_NAMES} && @refs != @{$self->{_COLUMN_NAMES}} and croak($self->SetDiag(3003)); join "", map { ref $_ eq "SCALAR" ? "" : "*" } @refs and croak($self->SetDiag(3004)); $self->_set_attr_N("_is_bound", scalar @refs); $self->{_BOUND_COLUMNS} = [@refs]; @refs; } sub getline_hr { my ($self, @args, %hr) = @_; $self->{_COLUMN_NAMES} or croak($self->SetDiag(3002)); my $fr = $self->getline(@args) or return; if (ref $self->{_FFLAGS}) { # missing $self->{_FFLAGS}[$_] = CSV_FLAGS_IS_MISSING() for (@{$fr} ? $#{$fr} + 1 : 0) .. $#{$self->{_COLUMN_NAMES}}; @{$fr} == 1 && (!defined $fr->[0] || $fr->[0] eq "") and $self->{_FFLAGS}[0] ||= CSV_FLAGS_IS_MISSING(); } @hr{@{$self->{_COLUMN_NAMES}}} = @{$fr}; \%hr; } sub getline_hr_all { my ($self, @args) = @_; $self->{_COLUMN_NAMES} or croak($self->SetDiag(3002)); my @cn = @{$self->{_COLUMN_NAMES}}; [map { my %h; @h{@cn} = @{$_}; \%h } @{$self->getline_all(@args)}]; } sub say { my ($self, $io, @f) = @_; my $eol = $self->eol(); # say ($fh, undef) does not propage actual undef to print () my $state = $self->print($io, @f == 1 && !defined $f[0] ? undef : @f); unless (length $eol) { $eol = $self->eol_type() || $\ || $/; print $io $eol; } return $state; } sub print_hr { my ($self, $io, $hr) = @_; $self->{_COLUMN_NAMES} or croak($self->SetDiag(3009)); ref $hr eq "HASH" or croak($self->SetDiag(3010)); $self->print($io, [map { $hr->{$_} } $self->column_names()]); } sub fragment { my ($self, $io, $spec) = @_; my $qd = qr{\s* [0-9]+ \s* }x; # digit my $qs = qr{\s* (?: [0-9]+ | \* ) \s*}x; # digit or star my $qr = qr{$qd (?: - $qs )?}x; # range my $qc = qr{$qr (?: ; $qr )*}x; # list defined $spec && $spec =~ m{^ \s* \x23 ? \s* # optional leading # ( row | col | cell ) \s* = ( $qc # for row and col | $qd , $qd (?: - $qs , $qs)? # for cell (ranges) (?: ; $qd , $qd (?: - $qs , $qs)? )* # and cell (range) lists ) \s* $}xi or croak($self->SetDiag(2013)); my ($type, $range) = (lc $1, $2); my @h = $self->column_names(); my @c; if ($type eq "cell") { my @spec; my $min_row; my $max_row = 0; for (split m/\s*;\s*/ => $range) { my ($tlr, $tlc, $brr, $brc) = (m{ ^ \s* ([0-9]+ ) \s* , \s* ([0-9]+ ) \s* (?: - \s* ([0-9]+ | \*) \s* , \s* ([0-9]+ | \*) \s* )? $}x) or croak($self->SetDiag(2013)); defined $brr or ($brr, $brc) = ($tlr, $tlc); $tlr == 0 || $tlc == 0 || ($brr ne "*" && ($brr == 0 || $brr < $tlr)) || ($brc ne "*" && ($brc == 0 || $brc < $tlc)) and croak($self->SetDiag(2013)); $tlc--; $brc-- unless $brc eq "*"; defined $min_row or $min_row = $tlr; $tlr < $min_row and $min_row = $tlr; $brr eq "*" || $brr > $max_row and $max_row = $brr; push @spec, [$tlr, $tlc, $brr, $brc]; } my $r = 0; while (my $row = $self->getline($io)) { ++$r < $min_row and next; my %row; my $lc; foreach my $s (@spec) { my ($tlr, $tlc, $brr, $brc) = @{$s}; $r < $tlr || ($brr ne "*" && $r > $brr) and next; !defined $lc || $tlc < $lc and $lc = $tlc; my $rr = $brc eq "*" ? $#{$row} : $brc; $row{$_} = $row->[$_] for $tlc .. $rr; } push @c, [@row{sort { $a <=> $b } keys %row}]; if (@h) { my %h; @h{@h} = @{$c[-1]}; $c[-1] = \%h; } $max_row ne "*" && $r == $max_row and last; } return \@c; } # row or col my @r; my $eod = 0; for (split m/\s*;\s*/ => $range) { my ($from, $to) = m/^\s* ([0-9]+) (?: \s* - \s* ([0-9]+ | \* ))? \s* $/x or croak($self->SetDiag(2013)); $to ||= $from; $to eq "*" and ($to, $eod) = ($from, 1); # $to cannot be <= 0 due to regex and ||= $from <= 0 || $to < $from and croak($self->SetDiag(2013)); $r[$_] = 1 for $from .. $to; } my $r = 0; $type eq "col" and shift @r; $_ ||= 0 for @r; while (my $row = $self->getline($io)) { $r++; if ($type eq "row") { if (($r > $#r && $eod) || $r[$r]) { push @c, $row; if (@h) { my %h; @h{@h} = @{$c[-1]}; $c[-1] = \%h; } } next; } push @c, [map { ($_ > $#r && $eod) || $r[$_] ? $row->[$_] : () } 0 .. $#{$row}]; if (@h) { my %h; @h{@h} = @{$c[-1]}; $c[-1] = \%h; } } return \@c; } my $csv_usage = q{usage: my $aoa = csv (in => $file);}; sub _csv_attr { my %attr = (@_ == 1 && ref $_[0] eq "HASH" ? %{$_[0]} : @_) or croak(); $attr{binary} = 1; $attr{strict_eol} = 1; my $enc = delete $attr{enc} || delete $attr{encoding} || ""; $enc eq "auto" and ($attr{detect_bom}, $enc) = (1, ""); my $stack = $enc =~ s/(:\w.*)// ? $1 : ""; $enc =~ m/^[-\w.]+$/ and $enc = ":encoding($enc)"; $enc .= $stack; my $hdrs = delete $attr{'headers'}; my $frag = delete $attr{'fragment'}; my $key = delete $attr{'key'}; my $val = delete $attr{'value'}; my $kh = delete $attr{'keep_headers'} || delete $attr{'keep_column_names'} || delete $attr{'kh'}; my $cbai = delete $attr{'callbacks'}{'after_in'} || delete $attr{'after_in'} || delete $attr{'callbacks'}{'after_parse'} || delete $attr{'after_parse'}; my $cbbo = delete $attr{'callbacks'}{'before_out'} || delete $attr{'before_out'}; my $cboi = delete $attr{'callbacks'}{'on_in'} || delete $attr{'on_in'}; my $cboe = delete $attr{'callbacks'}{'on_error'} || delete $attr{'on_error'}; my $hd_s = delete $attr{'sep_set'} || delete $attr{'seps'}; my $hd_b = delete $attr{'detect_bom'} || delete $attr{'bom'}; my $hd_m = delete $attr{'munge'} || delete $attr{'munge_column_names'}; my $hd_c = delete $attr{'set_column_names'}; my $fh; my $sink = 0; my $cls = 0; # If I open a file, I have to close it my $in = delete $attr{in} || delete $attr{file} or croak($csv_usage); my $out = exists $attr{out} && !$attr{out} ? \"skip" : delete $attr{out} || delete $attr{file}; ref $in eq "CODE" || ref $in eq "ARRAY" and $out ||= \*STDOUT; my ($fho, $fho_cls); if ($in && $out and (!ref $in || ref $in eq "GLOB" || ref \$in eq "GLOB") and (!ref $out || ref $out eq "GLOB" || ref \$out eq "GLOB")) { if (ref $out or "GLOB" eq ref \$out) { $fho = $out; } else { open $fho, ">", $out or croak "$out: $!\n"; if (my $e = $attr{'encoding'}) { binmode $fho, ":encoding($e)"; $hd_b and print $fho "\x{feff}"; } $fho_cls = 1; } if ($cboi && !$cbai) { $cbai = $cboi; $cboi = undef; } if ($cbai) { my $cb = $cbai; $cbai = sub { $cb->(@_); $_[0]->say($fho, $_[1]); 0 }; } else { $cbai = sub { $_[0]->say($fho, $_[1]); 0 }; } # Put all callbacks back in place for streaming behavior $attr{'callbacks'}{'after_parse'} = $cbai; $cbai = undef; $attr{'callbacks'}{'before_out'} = $cbbo; $cbbo = undef; $attr{'callbacks'}{'on_in'} = $cboi; $cboi = undef; $attr{'callbacks'}{'on_error'} = $cboe; $cboe = undef; $out = undef; $sink = 1; } if ($out) { if (ref $out and ("ARRAY" eq ref $out or "HASH" eq ref $out)) { delete $attr{out}; $sink = 1; } elsif ((ref $out and "SCALAR" ne ref $out) or "GLOB" eq ref \$out) { $fh = $out; } elsif (ref $out and "SCALAR" eq ref $out and defined ${$out} and ${$out} eq "skip") { delete $attr{out}; $sink = 1; } else { open $fh, ">", $out or croak("$out: $!"); $cls = 1; } if ($fh) { if ($enc) { binmode $fh, $enc; my $fn = fileno $fh; # This is a workaround for a bug in PerlIO::via::gzip } unless (defined $attr{eol} || defined $fho) { my @layers = eval { PerlIO::get_layers($fh) }; $attr{eol} = (grep m/crlf/ => @layers) ? "\n" : "\r\n"; } } } if (ref $in eq "CODE" or ref $in eq "ARRAY") { # All done } elsif (ref $in eq "SCALAR") { # Strings with code points over 0xFF may not be mapped into in-memory file handles # "<$enc" does not change that :( open $fh, "<", $in or croak("Cannot open from SCALAR using PerlIO"); $cls = 1; } elsif (ref $in or "GLOB" eq ref \$in) { if (!ref $in && $] < 5.008005) { $fh = \*{$in}; # uncoverable statement ancient perl version required } else { $fh = $in; } } else { open $fh, "<$enc", $in or croak("$in: $!"); $cls = 1; } $fh || $sink or croak(qq{No valid source passed. "in" is required}); for ([quo => "quote"], [esc => "escape"], [escape => "escape_char"], ) { my ($f, $t) = @{$_}; exists $attr{$f} and !exists $attr{$t} and $attr{$t} = delete $attr{$f}; } my $fltr = delete $attr{filter}; my %fltr = ( not_blank => sub { @{$_[1]} > 1 or defined $_[1][0] && $_[1][0] ne "" }, not_empty => sub { grep { defined && $_ ne "" } @{$_[1]} }, filled => sub { grep { defined && m/\S/ } @{$_[1]} }, ); defined $fltr && !ref $fltr && exists $fltr{$fltr} and $fltr = {0 => $fltr{$fltr}}; ref $fltr eq "CODE" and $fltr = {0 => $fltr}; ref $fltr eq "HASH" or $fltr = undef; my $form = delete $attr{formula}; defined $attr{auto_diag} or $attr{auto_diag} = 1; defined $attr{escape_null} or $attr{escape_null} = 0; my $csv = delete $attr{csv} || Text::CSV_PP->new(\%attr) or croak($last_err); defined $form and $csv->formula($form); defined $cboe and $csv->callbacks(error => $cboe); $kh && !ref $kh && $kh =~ m/^(?:1|yes|true|internal|auto)$/i and $kh = \@internal_kh; return { csv => $csv, attr => {%attr}, fh => $fh, cls => $cls, in => $in, sink => $sink, out => $out, enc => $enc, fho => $fho, fhoc => $fho_cls, hdrs => $hdrs, key => $key, val => $val, kh => $kh, frag => $frag, fltr => $fltr, cbai => $cbai, cbbo => $cbbo, cboi => $cboi, hd_s => $hd_s, hd_b => $hd_b, hd_m => $hd_m, hd_c => $hd_c, }; } sub csv { @_ && (ref $_[0] eq __PACKAGE__ or ref $_[0] eq 'Text::CSV') and splice @_, 0, 0, "csv"; @_ or croak($csv_usage); my $c = _csv_attr(@_); my ($csv, $in, $fh, $hdrs) = @{$c}{qw( csv in fh hdrs )}; my %hdr; if (ref $hdrs eq "HASH") { %hdr = %{$hdrs}; $hdrs = "auto"; } if ($c->{out} && !$c->{sink}) { !$hdrs && ref $c->{'kh'} && $c->{'kh'} == \@internal_kh and $hdrs = $c->{'kh'}; if (ref $in eq "CODE") { my $hdr = 1; while (my $row = $in->($csv)) { if (ref $row eq "ARRAY") { $csv->print($fh, $row); next; } if (ref $row eq "HASH") { if ($hdr) { $hdrs ||= [map { $hdr{$_} || $_ } keys %{$row}]; $csv->print($fh, $hdrs); $hdr = 0; } $csv->print($fh, [@{$row}{@{$hdrs}}]); } } } elsif (@{$in} == 0 or ref $in->[0] eq "ARRAY") { # aoa ref $hdrs and $csv->print($fh, $hdrs); for (@{$in}) { $c->{cboi} and $c->{cboi}->($csv, $_); $c->{cbbo} and $c->{cbbo}->($csv, $_); $csv->print($fh, $_); } } else { # aoh my @hdrs = ref $hdrs ? @{$hdrs} : keys %{$in->[0]}; defined $hdrs or $hdrs = "auto"; ref $hdrs || $hdrs eq "auto" and @hdrs and $csv->print($fh, [map { $hdr{$_} || $_ } @hdrs]); for (@{$in}) { local %_; *_ = $_; $c->{cboi} and $c->{cboi}->($csv, $_); $c->{cbbo} and $c->{cbbo}->($csv, $_); $csv->print($fh, [@{$_}{@hdrs}]); } } $c->{cls} and close $fh; $c->{fho_cls} and close $c->{fho}; return 1; } my @row1; if (defined $c->{hd_s} || defined $c->{hd_b} || defined $c->{hd_m} || defined $c->{hd_c}) { my %harg; !defined $c->{'hd_s'} && $c->{'attr'}{'sep_char'} and $c->{'hd_s'} = [$c->{'attr'}{'sep_char'}]; !defined $c->{'hd_s'} && $c->{'attr'}{'sep'} and $c->{'hd_s'} = [$c->{'attr'}{'sep'}]; defined $c->{'hd_s'} and $harg{'sep_set'} = $c->{'hd_s'}; defined $c->{'hd_b'} and $harg{'detect_bom'} = $c->{'hd_b'}; defined $c->{'hd_m'} and $harg{'munge_column_names'} = $hdrs ? "none" : $c->{'hd_m'}; defined $c->{'hd_c'} and $harg{'set_column_names'} = $hdrs ? 0 : $c->{'hd_c'}; @row1 = $csv->header($fh, \%harg); my @hdr = $csv->column_names(); @hdr and $hdrs ||= \@hdr; } if ($c->{kh}) { @internal_kh = (); ref $c->{kh} eq "ARRAY" or croak($csv->SetDiag(1501)); $hdrs ||= "auto"; } my $key = $c->{key}; if ($key) { !ref $key or ref $key eq "ARRAY" && @{$key} > 1 or croak($csv->SetDiag(1501)); $hdrs ||= "auto"; } my $val = $c->{val}; if ($val) { $key or croak($csv->SetDiag(1502)); !ref $val or ref $val eq "ARRAY" && @{$val} > 0 or croak($csv->SetDiag(1503)); } $c->{fltr} && grep m/\D/ => keys %{$c->{fltr}} and $hdrs ||= "auto"; if (defined $hdrs) { if (!ref $hdrs or ref $hdrs eq "CODE") { my $h = $c->{'hd_b'} ? [$csv->column_names()] : $csv->getline($fh); my $has_h = $h && @$h; if (ref $hdrs) { $has_h or return; my $cr = $hdrs; $hdrs = [map { $cr->($hdr{$_} || $_) } @{$h}]; } elsif ($hdrs eq "skip") { # discard; } elsif ($hdrs eq "auto") { $has_h or return; $hdrs = [map { $hdr{$_} || $_ } @{$h}]; } elsif ($hdrs eq "lc") { $has_h or return; $hdrs = [map { lc($hdr{$_} || $_) } @{$h}]; } elsif ($hdrs eq "uc") { $has_h or return; $hdrs = [map { uc($hdr{$_} || $_) } @{$h}]; } } $c->{kh} and $hdrs and @{$c->{kh}} = @{$hdrs}; } if ($c->{fltr}) { my %f = %{$c->{fltr}}; # convert headers to index my @hdr; if (ref $hdrs) { @hdr = @{$hdrs}; for (0 .. $#hdr) { exists $f{$hdr[$_]} and $f{$_ + 1} = delete $f{$hdr[$_]}; } } $csv->callbacks(after_parse => sub { my ($CSV, $ROW) = @_; # lexical sub-variables in caps foreach my $FLD (sort keys %f) { local $_ = $ROW->[$FLD - 1]; local %_; @hdr and @_{@hdr} = @{$ROW}; $f{$FLD}->($CSV, $ROW) or return \"skip"; $ROW->[$FLD - 1] = $_; } }); } my $frag = $c->{frag}; my $ref = ref $hdrs ? # aoh do { my @h = $csv->column_names($hdrs); my %h; $h{$_}++ for @h; exists $h{''} and croak($csv->SetDiag(1012)); unless (keys %h == @h) { croak($csv->_SetDiagInfo(1013, join ", " => map { "$_ ($h{$_})" } grep { $h{$_} > 1 } keys %h)); } $frag ? $csv->fragment($fh, $frag) : $key ? do { my ($k, $j, @f) = ref $key ? (undef, @{$key}) : ($key); if (my @mk = grep { !exists $h{$_} } grep { defined } $k, @f) { croak($csv->_SetDiagInfo(4001, join ", " => @mk)); } +{map { my $r = $_; my $K = defined $k ? $r->{$k} : join $j => @{$r}{@f}; ($K => ( $val ? ref $val ? {map { $_ => $r->{$_} } @{$val}} : $r->{$val} : $r)); } @{$csv->getline_hr_all($fh)}}; } : $csv->getline_hr_all($fh); } : # aoa $frag ? $csv->fragment($fh, $frag) : $csv->getline_all($fh); if ($ref) { @row1 && !$c->{hd_c} && !ref $hdrs and unshift @{$ref}, \@row1; } else { Text::CSV_PP->auto_diag(); } $c->{cls} and close $fh; $c->{fho_cls} and close $c->{fho}; if ($ref and $c->{cbai} || $c->{cboi}) { # Default is ARRAYref, but with key =>, you'll get a hashref foreach my $r (ref $ref eq "ARRAY" ? @{$ref} : values %{$ref}) { local %_; ref $r eq "HASH" and *_ = $r; $c->{cbai} and $c->{cbai}->($csv, $r); $c->{cboi} and $c->{cboi}->($csv, $r); } } if ($c->{sink}) { my $ro = ref $c->{out} or return; $ro eq "SCALAR" && ${$c->{out}} eq "skip" and return; $ro eq ref $ref or croak($csv->_SetDiagInfo(5001, "Output type mismatch")); if ($ro eq "ARRAY") { if (@{$c->{out}} and @$ref and ref $c->{out}[0] eq ref $ref->[0]) { push @{$c->{out}} => @$ref; return $c->{out}; } croak($csv->_SetDiagInfo(5001, "Output type mismatch")); } if ($ro eq "HASH") { @{$c->{out}}{keys %{$ref}} = values %{$ref}; return $c->{out}; } croak($csv->_SetDiagInfo(5002, "Unsupported output type")); } defined wantarray or return csv( in => $ref, headers => $hdrs, %{$c->{attr}}, ); $last_err ||= $csv->{_ERROR_DIAG}; return $ref; } # The end of the common pure perl part. ################################################################################ # # The following are methods implemented in XS in Text::CSV_XS or # helper methods for Text::CSV_PP only # ################################################################################ my $last_error; sub _setup_ctx { my $self = shift; $last_error = undef; my $ctx; if ($self->{_CACHE}) { %$ctx = %{$self->{_CACHE}}; } else { $ctx->{sep} = ','; if (defined $self->{sep_char}) { $ctx->{sep} = $self->{sep_char}; } if (defined $self->{sep} and $self->{sep} ne '') { use bytes; $ctx->{sep} = $self->{sep}; my $sep_len = length($ctx->{sep}); $ctx->{sep_len} = $sep_len if $sep_len > 1; } $ctx->{quo} = '"'; if (exists $self->{quote_char}) { my $quote_char = $self->{quote_char}; if (defined $quote_char and length $quote_char) { $ctx->{quo} = $quote_char; } else { $ctx->{quo} = "\0"; } } if (defined $self->{quote} and $self->{quote} ne '') { use bytes; $ctx->{quo} = $self->{quote}; my $quote_len = length($ctx->{quo}); $ctx->{quo_len} = $quote_len if $quote_len > 1; } $ctx->{escape_char} = '"'; if (exists $self->{escape_char}) { my $escape_char = $self->{escape_char}; if (defined $escape_char and length $escape_char) { $ctx->{escape_char} = $escape_char; } else { $ctx->{escape_char} = "\0"; } } if (defined $self->{eol}) { my $eol = $self->{eol}; my $eol_len = length($eol); $ctx->{eol} = $eol; $ctx->{eol_len} = $eol_len; if ($eol_len == 1 and $eol eq "\015") { $ctx->{eol_is_cr} = 1; $ctx->{eol_type} = EOL_TYPE_CR; } elsif ($eol_len == 1 && $eol eq "\012") { $ctx->{eol_type} = EOL_TYPE_NL; } elsif ($eol_len == 2 && $eol eq "\015\012") { $ctx->{eol_type} = EOL_TYPE_CRNL; } } $ctx->{undef_flg} = 0; if (defined $self->{undef_str}) { $ctx->{undef_str} = $self->{undef_str}; $ctx->{undef_flg} = 3 if utf8::is_utf8($self->{undef_str}); } else { $ctx->{undef_str} = undef; } if (defined $self->{comment_str}) { $ctx->{comment_str} = $self->{comment_str}; } if (defined $self->{_types}) { $ctx->{types} = $self->{_types}; $ctx->{types_len} = length($ctx->{types}); } if (defined $self->{_is_bound}) { $ctx->{is_bound} = $self->{_is_bound}; } if (defined $self->{callbacks}) { my $cb = $self->{callbacks}; $ctx->{has_hooks} = 0; if (defined $cb->{after_parse} and ref $cb->{after_parse} eq 'CODE') { $ctx->{has_hooks} |= HOOK_AFTER_PARSE; } if (defined $cb->{before_print} and ref $cb->{before_print} eq 'CODE') { $ctx->{has_hooks} |= HOOK_BEFORE_PRINT; } } for (qw/ binary decode_utf8 always_quote strict strict_eol quote_empty allow_loose_quotes allow_loose_escapes allow_unquoted_escape allow_whitespace blank_is_undef empty_is_undef verbatim auto_diag diag_verbose keep_meta_info formula skip_empty_rows /) { $ctx->{$_} = defined $self->{$_} ? $self->{$_} : 0; } for (qw/quote_space escape_null quote_binary/) { $ctx->{$_} = defined $self->{$_} ? $self->{$_} : 1; } if ($ctx->{escape_char} eq "\0") { $ctx->{escape_null} = 0; } # FIXME: readonly %{$self->{_CACHE}} = %$ctx; } $ctx->{utf8} = 0; $ctx->{size} = 0; $ctx->{used} = 0; if ($ctx->{is_bound}) { my $bound = $self->{_BOUND_COLUMNS}; if ($bound and ref $bound eq 'ARRAY') { $ctx->{bound} = $bound; } else { $ctx->{is_bound} = 0; } } $ctx->{eol_pos} = -1; $ctx->{eolx} = $ctx->{eol_len} ? $ctx->{verbatim} || $ctx->{eol_len} >= 2 ? 1 : $ctx->{eol} =~ /\A[\015\012]/ ? 0 : 1 : 0; if ($ctx->{eol_type} && $ctx->{strict_eol} && !$ctx->{eol}) { $ctx->{eol_is_cr} = 0; } if ($ctx->{sep_len} and $ctx->{sep_len} > 1 and _is_valid_utf8($ctx->{sep})) { $ctx->{utf8} = 1; } if ($ctx->{quo_len} and $ctx->{quo_len} > 1 and _is_valid_utf8($ctx->{quo})) { $ctx->{utf8} = 1; } if ($ctx->{strict} && !$ctx->{strict_n} && $self->{_COLUMN_NAMES} && ref $self->{_COLUMN_NAMES} eq 'ARRAY') { $ctx->{strict_n} = @{$self->{_COLUMN_NAMES}}; } $ctx; } sub _eol_type { my $c = shift; return EOL_TYPE_NL if $c eq "\012"; return EOL_TYPE_CR if $c eq "\015"; return EOL_TYPE_OTHER; } sub _set_eol_type { my ($self, $ctx, $type) = @_; if (!$ctx->{eol_type}) { $ctx->{eol_type} = $type; $self->_cache_set($_cache_id{eol_type} => $type); } } sub _cache_get_eolt { my $self = shift; return unless exists $self->{_CACHE}; my $cache = $self->{_CACHE}; my $eol_type = $cache->{eol_type} || 0; return "\012" if $eol_type == EOL_TYPE_NL; return "\015" if $eol_type == EOL_TYPE_CR; return "\015\012" if $eol_type == EOL_TYPE_CRNL; return $cache->{eol} if $eol_type == EOL_TYPE_OTHER; return; } sub _cache_set { my ($self, $idx, $value) = @_; return unless exists $self->{_CACHE}; my $cache = $self->{_CACHE}; my $key = $_reverse_cache_id{$idx}; if (!defined $key) { warn(sprintf "Unknown cache index %d ignored\n", $idx); } elsif ($key eq 'sep_char') { $cache->{sep} = $value; $cache->{sep_len} = 0; } elsif ($key eq 'quote_char') { $cache->{quo} = $value; $cache->{quo_len} = 0; } elsif ($key eq '_has_ahead') { $cache->{has_ahead} = $value; } elsif ($key eq '_has_hooks') { $cache->{has_hooks} = $value; } elsif ($key eq '_is_bound') { $cache->{is_bound} = $value; } elsif ($key eq 'sep') { use bytes; my $len = bytes::length($value); $cache->{sep} = $value if $len; $cache->{sep_len} = $len == 1 ? 0 : $len; } elsif ($key eq 'quote') { use bytes; my $len = bytes::length($value); $cache->{quo} = $value if $len; $cache->{quo_len} = $len == 1 ? 0 : $len; } elsif ($key eq 'eol') { $cache->{eol} = $value; $cache->{eol_len} = my $len = defined $value ? length($value) : 0; $cache->{eol_type} = $len == 0 ? EOL_TYPE_UNDEF : $len == 1 && $value eq "\012" ? EOL_TYPE_NL : $len == 1 && $value eq "\015" ? EOL_TYPE_CR : $len == 2 && $value eq "\015\012" ? EOL_TYPE_CRNL : EOL_TYPE_OTHER; $cache->{eol_is_cr} = $cache->{eol_type} == EOL_TYPE_CR ? 1 : 0; } elsif ($key eq 'undef_str') { if (defined $value) { $cache->{undef_str} = $value; $cache->{undef_flg} = 3 if utf8::is_utf8($value); } else { $cache->{undef_str} = undef; $cache->{undef_flg} = 0; } } else { $cache->{$key} = $value; } return 1; } sub _cache_diag { my $self = shift; unless (exists $self->{_CACHE}) { warn("CACHE: invalid\n"); return; } my $cache = $self->{_CACHE}; warn("CACHE:\n"); $self->__cache_show_char(quote_char => $cache->{quo}); $self->__cache_show_char(escape_char => $cache->{escape_char}); $self->__cache_show_char(sep_char => $cache->{sep}); for (qw/ binary decode_utf8 allow_loose_escapes allow_loose_quotes allow_unquoted_escape allow_whitespace always_quote quote_empty quote_space escape_null quote_binary auto_diag diag_verbose formula strict strict_n strict_eol eol_type skip_empty_rows has_error_input blank_is_undef empty_is_undef has_ahead keep_meta_info verbatim useIO has_hooks eol_is_cr eol_len /) { $self->__cache_show_byte($_ => $cache->{$_}); } $self->__cache_show_str(eol => $cache->{eol_len}, $cache->{eol}); $self->__cache_show_byte(sep_len => $cache->{sep_len}); if ($cache->{sep_len} and $cache->{sep_len} > 1) { $self->__cache_show_str(sep => $cache->{sep_len}, $cache->{sep}); } $self->__cache_show_byte(quo_len => $cache->{quo_len}); if ($cache->{quo_len} and $cache->{quo_len} > 1) { $self->__cache_show_str(quote => $cache->{quo_len}, $cache->{quo}); } if ($cache->{types_len}) { $self->__cache_show_str(types => $cache->{types_len}, $cache->{types}); } else { $self->__cache_show_str(types => 0, ""); } if ($cache->{bptr}) { $self->__cache_show_str(bptr => length($cache->{bptr}), $cache->{bptr}); } if ($cache->{tmp}) { $self->__cache_show_str(tmp => length($cache->{tmp}), $cache->{tmp}); } } sub __cache_show_byte { my ($self, $key, $value) = @_; warn(sprintf " %-21s %02x:%3d\n", $key, defined $value ? ord($value) : 0, defined $value ? $value : 0); } sub __cache_show_char { my ($self, $key, $value) = @_; my $v = $value; if (defined $value) { my @b = unpack "U0C*", $value; $v = pack "U*", $b[0]; } warn(sprintf " %-21s %02x:%s\n", $key, defined $v ? ord($v) : 0, $self->__pretty_str($v, 1)); } sub __cache_show_str { my ($self, $key, $len, $value) = @_; warn(sprintf " %-21s %02d:%s\n", $key, $len, $self->__pretty_str($value, $len)); } sub __pretty_str { # FIXME my ($self, $str, $len) = @_; return '' unless defined $str; $str = substr($str, 0, $len); $str =~ s/"/\\"/g; $str =~ s/([^\x09\x20-\x7e])/sprintf '\\x{%x}', ord($1)/eg; qq{"$str"}; } sub _hook { my ($self, $name, $fields) = @_; return 0 unless $self->{callbacks}; my $cb = $self->{callbacks}{$name}; return 0 unless $cb && ref $cb eq 'CODE'; my (@res) = $cb->($self, $fields); if (@res) { return 0 if ref $res[0] eq 'SCALAR' and ${$res[0]} eq "skip"; } scalar @res; } ################################################################################ # methods for combine ################################################################################ sub __combine { my ($self, $dst, $fields, $useIO) = @_; my $ctx = $self->_setup_ctx; my ($binary, $quot, $sep, $esc, $quote_space) = @{$ctx}{qw/binary quo sep escape_char quote_space/}; if (!defined $quot or $quot eq "\0") { $quot = ''; } my $re_esc; if ($esc ne '' and $esc ne "\0") { if ($quot ne '') { $re_esc = $self->{_re_comb_escape}->{$quot}->{$esc} ||= qr/(\Q$quot\E|\Q$esc\E)/; } else { $re_esc = $self->{_re_comb_escape}->{$quot}->{$esc} ||= qr/(\Q$esc\E)/; } } my $bound = 0; my $n = @$fields - 1; if ($n < 0 and $ctx->{is_bound}) { $n = $ctx->{is_bound} - 1; $bound = 1; } my $check_meta = ($ctx->{keep_meta_info} >= 10 and @{$self->{_FFLAGS} || []} >= $n) ? 1 : 0; my $must_be_quoted; my @results; for (my $i = 0; $i <= $n; $i++) { my $v_ref; if ($bound) { $v_ref = $self->__bound_field($ctx, $i, 1); } else { if (@$fields > $i) { $v_ref = \($fields->[$i]); } } next unless $v_ref; my $value = $$v_ref; if (!defined $value) { if ($ctx->{undef_str}) { if ($ctx->{undef_flg}) { $ctx->{utf8} = 1; $ctx->{binary} = 1; } push @results, $ctx->{undef_str}; } else { push @results, ''; } next; } if (substr($value, 0, 1) eq '=' && $ctx->{formula}) { $value = $self->_formula($ctx, $value, $i); if (!defined $value) { push @results, ''; next; } } $must_be_quoted = $ctx->{always_quote} ? 1 : 0; if ($value eq '') { $must_be_quoted++ if $ctx->{quote_empty} or ($check_meta && $self->is_quoted($i)); } else { if (utf8::is_utf8 $value) { $ctx->{utf8} = 1; $ctx->{binary} = 1; } $must_be_quoted++ if $check_meta && $self->is_quoted($i); if (!$must_be_quoted and $quot ne '') { use bytes; $must_be_quoted++ if ($value =~ /\Q$quot\E/) || ($sep ne '' and $sep ne "\0" and $value =~ /\Q$sep\E/) || ($esc ne '' and $esc ne "\0" and $value =~ /\Q$esc\E/) || ($ctx->{quote_binary} && $value =~ /[\x00-\x1f\x7f-\xa0]/) || ($ctx->{quote_space} && $value =~ /[\x09\x20]/); } if (!$ctx->{binary} and $value =~ /[^\x09\x20-\x7E]/) { # an argument contained an invalid character... $self->{_ERROR_INPUT} = $value; $self->SetDiag(2110); return 0; } if ($re_esc) { $value =~ s/($re_esc)/$esc$1/g; } if ($ctx->{escape_null}) { $value =~ s/\0/${esc}0/g; } } if ($must_be_quoted) { $value = $quot . $value . $quot; } push @results, $value; } $$dst = join($sep, @results) . (defined $ctx->{eol} ? $ctx->{eol} : ''); return 1; } sub _formula { my ($self, $ctx, $value, $i) = @_; my $fa = $ctx->{formula} or return; if ($fa == 1) { die "Formulas are forbidden\n" } if ($fa == 2) { die "Formulas are forbidden\n" } # XS croak behaves like PP's "die" if ($fa == 3) { my $rec = ''; if ($ctx->{recno}) { $rec = sprintf " in record %lu", $ctx->{recno} + 1; } my $field = ''; my $column_names = $self->{_COLUMN_NAMES}; if (ref $column_names eq 'ARRAY' and @$column_names >= $i - 1) { my $column_name = $column_names->[$i - 1]; $field = sprintf " (column: '%.100s')", $column_name if defined $column_name; } warn sprintf("Field %d%s%s contains formula '%s'\n", $i, $field, $rec, $value); return $value; } if ($fa == 4) { return ''; } if ($fa == 5) { return undef; } if ($fa == 6) { if (ref $self->{_FORMULA_CB} eq 'CODE') { local $_ = $value; return $self->{_FORMULA_CB}->(); } } return; } sub print { my ($self, $io, $fields) = @_; require IO::Handle; if (!defined $fields) { $fields = []; } elsif (ref($fields) ne 'ARRAY') { Carp::croak("Expected fields to be an array ref"); } $self->_hook(before_print => $fields); my $str = ""; $self->__combine(\$str, $fields, 1) or return ''; local $\ = ''; $io->print($str) or $self->_set_error_diag(2200); } ################################################################################ # methods for parse ################################################################################ sub __parse { # cx_xsParse my ($self, $fields, $fflags, $src, $useIO) = @_; my $ctx = $self->_setup_ctx; my $state = $self->___parse($ctx, $fields, $fflags, $src, $useIO); if ($state and ($ctx->{has_hooks} || 0) & HOOK_AFTER_PARSE) { $self->_hook(after_parse => $fields); } return $state || !$last_error; } sub ___parse { # cx_c_xsParse my ($self, $ctx, $fields, $fflags, $src, $useIO) = @_; local $/ = $ctx->{eol} if $ctx->{eolx} or $ctx->{eol_is_cr}; if ($ctx->{useIO} = $useIO) { require IO::Handle; $ctx->{tmp} = undef; if ($ctx->{has_ahead} and defined $self->{_AHEAD}) { $ctx->{tmp} = $self->{_AHEAD}; $ctx->{size} = length $ctx->{tmp}; $ctx->{used} = 0; } } else { $ctx->{tmp} = $src; $ctx->{size} = length $src; $ctx->{used} = 0; $ctx->{utf8} = utf8::is_utf8($src); } if ($ctx->{has_error_input}) { $self->{_ERROR_INPUT} = undef; $ctx->{has_error_input} = 0; } my $result = $self->____parse($ctx, $src, $fields, $fflags); $self->{_RECNO} = ++($ctx->{recno}); $self->{_EOF} = ''; if ($ctx->{strict}) { my $nf = $ctx->{is_bound} ? $ctx->{fld_idx} : @$fields; if ($nf and !$ctx->{strict_n}) { $ctx->{strict_n} = $nf; } if ($ctx->{strict_n} > 0 and $nf != $ctx->{strict_n}) { unless ($ctx->{useIO} & useIO_EOF) { unless ($last_error || (!$ctx->{useIO} and $ctx->{has_ahead})) { $self->__parse_error($ctx, 2014, $ctx->{used}); } } if ($last_error) { $result = undef; } } } if ($ctx->{useIO}) { if (defined $ctx->{tmp} and $ctx->{used} < $ctx->{size} and $ctx->{has_ahead}) { $self->{_AHEAD} = substr($ctx->{tmp}, $ctx->{used}, $ctx->{size} - $ctx->{used}); } else { $ctx->{has_ahead} = 0; if ($ctx->{useIO} & useIO_EOF) { $self->{_EOF} = 1; } } %{$self->{_CACHE}} = %$ctx; if ($fflags) { if ($ctx->{keep_meta_info}) { $self->{_FFLAGS} = $fflags; } else { undef $fflags; } } } else { %{$self->{_CACHE}} = %$ctx; } if ($result and $ctx->{types}) { my $len = @$fields; for (my $i = 0; $i <= $len && $i <= $ctx->{types_len}; $i++) { my $value = $fields->[$i]; next unless defined $value; my $type = ord(substr($ctx->{types}, $i, 1)); if ($type == IV) { $fields->[$i] = int($value); } elsif ($type == NV) { $fields->[$i] = $value + 0.0; } } } $result; } sub ____parse { # cx_Parse my ($self, $ctx, $src, $fields, $fflags) = @_; my ($quot, $sep, $esc, $eol) = @{$ctx}{qw/quo sep escape_char eol/}; utf8::encode($sep) if !$ctx->{utf8} and $ctx->{sep_len}; utf8::encode($quot) if !$ctx->{utf8} and $ctx->{quo_len}; utf8::encode($eol) if !$ctx->{utf8} and $ctx->{eol_len}; my $seenSomething = 0; my $spl = -1; my $waitingForField = 1; my ($value, $v_ref, $c0); $ctx->{fld_idx} = my $fnum = 0; $ctx->{flag} = 0; 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", " "; $ctx->{_re} = qr/$re_str/; my $re = qr/$re_str|[^\x09\x20-\x7E]|$/; LOOP: while ($self->__get_from_src($ctx, $src)) { while ($ctx->{tmp} =~ /\G(.*?)($re)/gs) { my ($hit, $c) = ($1, $2); $ctx->{used} = pos($ctx->{tmp}); if (!$waitingForField and $c eq '' and $hit ne '' and $ctx->{useIO} and !($ctx->{useIO} & useIO_EOF)) { $self->{_AHEAD} = $hit; $ctx->{has_ahead} = 1; $ctx->{has_leftover} = 1; last; } last if $seenSomething and $hit eq '' and $c eq ''; # EOF # new field if (!$v_ref) { if ($ctx->{is_bound}) { $v_ref = $self->__bound_field($ctx, $fnum, 0); } else { $value = ''; $v_ref = \$value; } $fnum++; return unless $v_ref; $ctx->{flag} = 0; $ctx->{fld_idx}++; $c0 = ''; } $seenSomething = 1; $spl++; if (defined $hit and $hit ne '') { if ($waitingForField) { if (!$spl && $ctx->{comment_str} && $ctx->{tmp} =~ /\A\Q$ctx->{comment_str}/) { $ctx->{used} = $ctx->{size}; $ctx->{fld_idx} = $ctx->{strict_n} ? $ctx->{strict_n} : 0; $seenSomething = 0; unless ($ctx->{useIO}) { $ctx->{has_ahead} = 214; } next LOOP; } $waitingForField = 0; } if ($hit =~ /[^\x09\x20-\x7E]/) { $ctx->{flag} |= IS_BINARY; } $$v_ref .= $hit; } RESTART: if (defined $c and defined $sep and $c eq $sep) { if ($waitingForField) { # ,1,"foo, 3",,bar, # ^ ^ if ($ctx->{blank_is_undef} or $ctx->{empty_is_undef}) { $$v_ref = undef; } else { $$v_ref = ""; } unless ($ctx->{is_bound}) { push @$fields, $$v_ref; } $v_ref = undef; if ($ctx->{keep_meta_info} and $fflags) { push @$fflags, $ctx->{flag}; } } elsif ($ctx->{flag} & IS_QUOTED) { # ,1,"foo, 3",,bar, # ^ $$v_ref .= $c; } else { # ,1,"foo, 3",,bar, # ^ ^ ^ $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum); $v_ref = undef; $waitingForField = 1; } } elsif (defined $c and defined $quot and $quot ne "\0" and $c eq $quot) { if ($waitingForField) { # ,1,"foo, 3",,bar,\r\n # ^ $ctx->{flag} |= IS_QUOTED; $waitingForField = 0; next; } if ($ctx->{flag} & IS_QUOTED) { # ,1,"foo, 3",,bar,\r\n # ^ my $quoesc = 0; my $c2 = $self->__get($ctx, $src); if ($ctx->{allow_whitespace}) { # , 1 , "foo, 3" , , bar , \r\n # ^ while ($self->__is_whitespace($ctx, $c2)) { if ($ctx->{allow_loose_quotes} and !(defined $esc and $c2 eq $esc)) { $$v_ref .= $c; $c = $c2; } $c2 = $self->__get($ctx, $src); } } if (!defined $c2) { # EOF # ,1,"foo, 3" # ^ $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum); return 1; } if (defined $c2 and defined $sep and $c2 eq $sep) { # ,1,"foo, 3",,bar,\r\n # ^ $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum); $v_ref = undef; $waitingForField = 1; next; } if (defined $c2 and ($c2 eq "\012" or (defined $eol and $c2 eq $eol))) { # FIXME: EOLX # ,1,"foo, 3",,"bar"\n # ^ my $eolt = _eol_type($c2); if ($ctx->{strict_eol} and $ctx->{eol_type} and $ctx->{eol_type} != $eolt) { $self->__error_eol($ctx) or return; } $self->_set_eol_type($ctx, $eolt); $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum); return 1; } if (defined $esc and $c eq $esc) { $quoesc = 1; if (defined $c2 and $c2 eq '0') { # ,1,"foo, 3"056",,bar,\r\n # ^ $$v_ref .= "\0"; next; } if (defined $c2 and defined $quot and $c2 eq $quot) { # ,1,"foo, 3""56",,bar,\r\n # ^ if ($ctx->{utf8}) { $ctx->{flag} |= IS_BINARY; } $$v_ref .= $c2; next; } if ($ctx->{allow_loose_escapes} and defined $c2 and $c2 ne "\015") { # ,1,"foo, 3"56",,bar,\r\n # ^ $$v_ref .= $c; $c = $c2; goto RESTART; } } if (defined $c2 and $c2 eq "\015") { if ($ctx->{eol_is_cr}) { # ,1,"foo, 3"\r # ^ $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum); return 1; } my $c3 = $self->__get($ctx, $src); if (defined $c3 and $c3 eq "\012") { # ,1,"foo, 3"\r\n # ^ if ($ctx->{strict_eol} and $ctx->{eol_type} and $ctx->{eol_type} != EOL_TYPE_CRNL) { $self->__error_eol($ctx) or return; } $self->_set_eol_type($ctx, EOL_TYPE_CRNL); $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum); return 1; } if ($ctx->{useIO} and !$ctx->{eol_len}) { if ($c3 eq "\015") { # \r followed by an empty line # ,1,"foo, 3"\r\r # ^ if ($ctx->{strict_eol} and $ctx->{eol_type}) { unless ($ctx->{eol_type} == EOL_TYPE_CR) { $self->__error_eol($ctx) or return; } $ctx->{used}--; $ctx->{has_ahead}++; $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum); return 1; } $self->__set_eol_is_cr($ctx); if ($ctx->{flag} & IS_QUOTED) { $ctx->{flag} ^= IS_QUOTED; } $c = $c0 = "\015"; goto EOLX; } if ($c3 !~ /[^\x09\x20-\x7E]/) { # ,1,"foo\n 3",,"bar"\r # baz,4 # ^ if ($ctx->{strict_eol} and $ctx->{eol_type}) { unless ($ctx->{eol_type} == EOL_TYPE_CR) { $self->__error_eol($ctx) or return; } $ctx->{eol_is_cr} = 1; } else { $self->__set_eol_is_cr($ctx); } $ctx->{used}--; $ctx->{has_ahead} = 1; $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum); return 1; } } $self->__parse_error($ctx, $quoesc ? 2023 : 2010, $ctx->{used} - 2); return; } if ($ctx->{allow_loose_quotes} and !$quoesc) { # ,1,"foo, 3"456",,bar,\r\n # ^ $$v_ref .= $c; $c = $c2; goto RESTART; } # 1,"foo" ",3 # ^ if ($quoesc) { $ctx->{used}--; $self->__error_inside_quotes($ctx, 2023); return; } $self->__error_inside_quotes($ctx, 2011); return; } # !waitingForField, !InsideQuotes if ($ctx->{allow_loose_quotes}) { # 1,foo "boo" d'uh,1 $ctx->{flag} |= IS_ERROR; $$v_ref .= $c; } else { $self->__error_inside_field($ctx, 2034); return; } } elsif (defined $c and defined $esc and $esc ne "\0" and $c eq $esc) { # This means quote_char != escape_char if ($waitingForField) { $waitingForField = 0; if ($ctx->{allow_unquoted_escape}) { # The escape character is the first character of an # unquoted field # ... get and store next character my $c2 = $self->__get($ctx, $src); $$v_ref = ""; if (!defined $c2) { # EOF $ctx->{used}--; $self->__error_inside_field($ctx, 2035); return; } if ($c2 eq '0') { $$v_ref .= "\0"; } elsif ( (defined $quot and $c2 eq $quot) or (defined $sep and $c2 eq $sep) or (defined $esc and $c2 eq $esc) or $ctx->{allow_loose_escapes} ) { if ($ctx->{utf8}) { $ctx->{flag} |= IS_BINARY; } $$v_ref .= $c2; } else { $self->__parse_inside_quotes($ctx, 2025); return; } } } elsif ($ctx->{flag} & IS_QUOTED) { my $c2 = $self->__get($ctx, $src); if (!defined $c2) { # EOF $ctx->{used}--; $self->__error_inside_quotes($ctx, 2024); return; } if ($c2 eq '0') { $$v_ref .= "\0"; } elsif ( (defined $quot and $c2 eq $quot) or (defined $sep and $c2 eq $sep) or (defined $esc and $c2 eq $esc) or $ctx->{allow_loose_escapes} ) { if ($ctx->{utf8}) { $ctx->{flag} |= IS_BINARY; } $$v_ref .= $c2; } else { $ctx->{used}--; $self->__error_inside_quotes($ctx, 2025); return; } } elsif ($v_ref) { my $c2 = $self->__get($ctx, $src); if (!defined $c2) { # EOF $ctx->{used}--; $self->__error_inside_field($ctx, 2035); return; } $$v_ref .= $c2; } else { $self->__error_inside_field($ctx, 2036); return; } } elsif (defined $c and ($c eq "\012" or $c eq '' or (defined $eol and $c eq $eol and $eol ne "\015"))) { # EOL EOLX: my $eolt = (($c eq "\012" || $c eq "\015") && $c0 eq "\015") ? EOL_TYPE_CRNL : _eol_type($c); $c0 = ''; unless ($ctx->{flag} & CSV_FLAGS_IS_QUOTED) { if ($ctx->{strict_eol} and $ctx->{eol_type} and $ctx->{eol_type} != $eolt) { $self->__error_eol($ctx) or return; } $self->_set_eol_type($ctx, $eolt); } if ($fnum == 1 && $ctx->{flag} == 0 && (!$v_ref || $$v_ref eq '') && $ctx->{skip_empty_rows}) { ### SkipEmptyRow my $ser = $ctx->{skip_empty_rows}; if ($ser == 3) { $self->SetDiag(2015); die "Empty row\n"; } if ($ser == 4) { $self->SetDiag(2015); die "Empty row\n"; } if ($ser == 5) { $self->SetDiag(2015); return undef; } if ($ser <= 2) { # skip & eof $ctx->{fld_idx} = 0; $c = $self->__get($ctx, $src); if (!defined $c or $ser == 2) { # EOF $v_ref = undef; $seenSomething = 0; if ($ser == 2) { return undef; } last LOOP; } } if ($ser == 6) { my $cb = $self->{_EMPTROW_CB}; unless ($cb && ref $cb eq 'CODE') { return undef; # A callback is wanted, but none found } local $_ = $v_ref; my $rv = $cb->(); # Result should be a ref to a list. unless (ref $rv eq 'ARRAY') { return undef; } my $n = @$rv; if ($n <= 0) { return 1; } if ($ctx->{is_bound} && $ctx->{is_bound} < $n) { $n = $ctx->{is_bound} - 1; } for (my $i = 0; $i < $n; $i++) { my $rvi = $rv->[$i]; $self->__push_value($ctx, \$rvi, $fields, $fflags, $ctx->{flag}, $fnum); } return 1; } goto RESTART; } if ($waitingForField) { # ,1,"foo, 3",,bar, # ^ if ($ctx->{blank_is_undef} or $ctx->{empty_is_undef}) { $$v_ref = undef; } else { $$v_ref = ""; } unless ($ctx->{is_bound}) { push @$fields, $$v_ref; } if ($ctx->{keep_meta_info} and $fflags) { push @$fflags, $ctx->{flag}; } return 1; } if ($ctx->{flag} & IS_QUOTED) { # ,1,"foo\n 3",,bar, # ^ $ctx->{flag} |= IS_BINARY; unless ($ctx->{binary}) { $self->__error_inside_quotes($ctx, 2021); return; } $$v_ref .= $c; } elsif ($ctx->{verbatim}) { # ,1,foo\n 3,,bar, # This feature should be deprecated $ctx->{flag} |= IS_BINARY; unless ($ctx->{binary}) { $self->__error_inside_field($ctx, 2030); return; } $$v_ref .= $c unless $ctx->{eol} eq $c and $ctx->{useIO}; } else { # sep=, # ^ if (!$ctx->{recno} and $ctx->{fld_idx} == 1 and $ctx->{useIO} and $hit =~ /^sep=(.{1,16})$/i) { $ctx->{sep} = $1; use bytes; my $len = length $ctx->{sep}; if ($len <= 16) { $ctx->{sep_len} = $len == 1 ? 0 : $len; return $self->____parse($ctx, $src, $fields, $fflags); } } # ,1,"foo\n 3",,bar # ^ $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum); return 1; } } elsif (defined $c and $c eq "\015" and !$ctx->{verbatim}) { $c0 = "\015"; if ($waitingForField) { if ($ctx->{eol_is_cr}) { # ,1,"foo\n 3",,bar,\r # ^ $c = "\012"; goto EOLX; } my $c2 = $self->__get($ctx, $src); if (!defined $c2) { # EOF # ,1,"foo\n 3",,bar,\r # ^ $c = undef; last unless $seenSomething; goto RESTART; } if ($c2 eq "\012") { # \r is not optional before EOLX! # ,1,"foo\n 3",,bar,\r\n # ^ if ($ctx->{strict_eol} and $ctx->{eol_type} and $ctx->{eol_type} != EOL_TYPE_CRNL) { $self->__error_eol($ctx) or return; } $self->_set_eol_type($ctx, EOL_TYPE_CRNL); $c = $c2; goto EOLX; } if ($ctx->{useIO} and !$ctx->{eol_len}) { if ($c2 eq "\012") { # \r followed by an empty line # ,1,"foo\n 3",,bar,\r\r # ^ if ($ctx->{strict_eol} and $ctx->{eol_type}) { unless ($ctx->{eol_type} == EOL_TYPE_CR) { $self->__error_eol($ctx) or return; } $ctx->{eol_is_cr} = 1; } else { $self->__set_eol_is_cr($ctx); } goto EOLX; } $waitingForField = 0; if ($c2 !~ /[^\x09\x20-\x7E]/) { # ,1,"foo\n 3",,bar,\r # baz,4 # ^ if ($ctx->{strict_eol} and $ctx->{eol_type}) { unless ($ctx->{eol_type} == EOL_TYPE_CR) { $self->__error_eol($ctx) or return; } } else { $self->__set_eol_is_cr($ctx); } $ctx->{used}--; $ctx->{has_ahead} = 1; if ($fnum == 1 && $ctx->{flag} == 0 && (!$v_ref or $$v_ref eq '') && $ctx->{skip_empty_rows}) { ### SkipEmptyRow my $ser = $ctx->{skip_empty_rows}; if ($ser == 3) { $self->SetDiag(2015); die "Empty row\n"; } if ($ser == 4) { $self->SetDiag(2015); die "Empty row\n"; } if ($ser == 5) { $self->SetDiag(2015); return undef; } if ($ser <= 2) { # skip & eof $ctx->{fld_idx} = 0; $c = $self->__get($ctx, $src); if (!defined $c) { # EOF $v_ref = undef; $waitingForField = 1; $seenSomething = 0; last LOOP; } } if ($ser == 6) { my $cb = $self->{_EMPTROW_CB}; unless ($cb && ref $cb eq 'CODE') { return undef; # A callback is wanted, but none found } local $_ = $v_ref; my $rv = $cb->(); # Result should be a ref to a list. unless (ref $rv eq 'ARRAY') { return undef; } my $n = @$rv; if ($n <= 0) { return 1; } if ($ctx->{is_bound} && $ctx->{is_bound} < $n) { $n = $ctx->{is_bound} - 1; } for (my $i = 0; $i < $n; $i++) { my $rvi = $rv->[$i]; $self->__push_value($ctx, \$rvi, $fields, $fflags, $ctx->{flag}, $fnum); } return 1; } $$v_ref = $c2; goto RESTART; } $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum); return 1; } } # ,1,"foo\n 3",,bar,\r\t # ^ $ctx->{used}--; $self->__error_inside_field($ctx, 2031); return; } if ($ctx->{flag} & IS_QUOTED) { # ,1,"foo\r 3",,bar,\r\t # ^ $ctx->{flag} |= IS_BINARY; unless ($ctx->{binary}) { $self->__error_inside_quotes($ctx, 2022); return; } $$v_ref .= $c; } else { if ($ctx->{eol_is_cr}) { # ,1,"foo\n 3",,bar\r # ^ goto EOLX; } my $c2 = $self->__get($ctx, $src); if (defined $c2 and $c2 eq "\012") { # \r is not optional before EOLX! # ,1,"foo\n 3",,bar\r\n # ^ if ($ctx->{strict_eol} and $ctx->{eol_type} and $ctx->{eol_type} != EOL_TYPE_CRNL) { $self->__error_eol($ctx) or return; } $self->_set_eol_type($ctx, EOL_TYPE_CRNL); goto EOLX; } if ($ctx->{useIO} and !$ctx->{eol_len}) { if ($c2 !~ /[^\x09\x20-\x7E]/ # ,1,"foo\n 3",,bar\r # baz,4 # ^ or $c2 eq "\015" # ,1,"foo\n 3",,bar,\r\r # ^ ) { if ($ctx->{strict_eol} and $ctx->{eol_type}) { unless ($ctx->{eol_type} == EOL_TYPE_CR) { $self->__error_eol($ctx) or return; } } else { $self->__set_eol_is_cr($ctx); } $ctx->{used}--; $ctx->{has_ahead} = 1; if ($fnum == 1 && $ctx->{flag} == 0 && (!$v_ref or $$v_ref eq '') && $ctx->{skip_empty_rows}) { ### SKipEmptyRow my $ser = $ctx->{skip_empty_rows}; if ($ser == 3) { $self->SetDiag(2015); die "Empty row\n"; } if ($ser == 4) { $self->SetDiag(2015); die "Empty row\n"; } if ($ser == 5) { $self->SetDiag(2015); return undef; } if ($ser <= 2) { # skip & eof $ctx->{fld_idx} = 0; $c = $self->__get($ctx, $src); if (!defined $c) { # EOL $v_ref = undef; $seenSomething = 0; last LOOP; } } if ($ser == 6) { my $cb = $self->{_EMPTROW_CB}; unless ($cb && ref $cb eq 'CODE') { return undef; # A callback is wanted, but none found } local $_ = $v_ref; my $rv = $cb->(); # Result should be a ref to a list. unless (ref $rv eq 'ARRAY') { return undef; } my $n = @$rv; if ($n <= 0) { return 1; } if ($ctx->{is_bound} && $ctx->{is_bound} < $n) { $n = $ctx->{is_bound} - 1; } for (my $i = 0; $i < $n; $i++) { my $rvi = $rv->[$i]; $self->__push_value($ctx, \$rvi, $fields, $fflags, $ctx->{flag}, $fnum); } return 1; } goto RESTART; } $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum); return 1; } } # ,1,"foo\n 3",,bar\r\t # ^ $self->__error_inside_field($ctx, 2032); return; } } else { if ($ctx->{eolx} and $c eq $eol) { $c = ''; goto EOLX; } if ($waitingForField) { if (!$spl && $ctx->{comment_str} && $ctx->{tmp} =~ /\A$ctx->{comment_str}/) { $ctx->{used} = $ctx->{size}; $ctx->{fld_idx} = $ctx->{strict_n} ? $ctx->{strict_n} - 1 : 0; $seenSomething = 0; unless ($ctx->{useIO}) { $ctx->{has_ahead} = 214; # abuse } next LOOP; } if ($ctx->{allow_whitespace} and $self->__is_whitespace($ctx, $c)) { do { $c = $self->__get($ctx, $src); last if !defined $c; } while $self->__is_whitespace($ctx, $c); goto RESTART; } $waitingForField = 0; goto RESTART; } if ($ctx->{flag} & IS_QUOTED) { if (!defined $c or $c =~ /[^\x09\x20-\x7E]/) { $ctx->{flag} |= IS_BINARY; unless ($ctx->{binary} or $ctx->{utf8}) { $self->__error_inside_quotes($ctx, 2026); return; } } $$v_ref .= $c; } else { if (!defined $c or $c =~ /[^\x09\x20-\x7E]/) { last if $ctx->{useIO} && !defined $c; $ctx->{flag} |= IS_BINARY; unless ($ctx->{binary} or $ctx->{utf8}) { $self->__error_inside_field($ctx, 2037); return; } } $$v_ref .= $c; } } last LOOP if $ctx->{useIO} and $ctx->{verbatim} and $ctx->{used} == $ctx->{size}; } } if ($waitingForField) { unless ($ctx->{useIO}) { if ($ctx->{has_ahead} and $ctx->{has_ahead} == 214) { return 1; } $seenSomething++; } if ($seenSomething) { # new field if (!$v_ref) { if ($ctx->{is_bound}) { $v_ref = $self->__bound_field($ctx, $fnum, 0); } else { $value = ''; $v_ref = \$value; } $fnum++; return unless $v_ref; $ctx->{flag} = 0; $ctx->{fld_idx}++; } if ($ctx->{blank_is_undef} or $ctx->{empty_is_undef}) { $$v_ref = undef; } else { $$v_ref = ""; } unless ($ctx->{is_bound}) { push @$fields, $$v_ref; } if ($ctx->{keep_meta_info} and $fflags) { push @$fflags, $ctx->{flag}; } return 1; } $self->SetDiag(2012); return; } if ($ctx->{flag} & IS_QUOTED) { $self->__error_inside_quotes($ctx, 2027); return; } if ($v_ref) { $self->__push_value($ctx, $v_ref, $fields, $fflags, $ctx->{flag}, $fnum); } elsif ($ctx->{flag} == 0 && $fnum == 1 && $ctx->{skip_empty_rows} == 1) { return undef; } return 1; } sub __get_from_src { my ($self, $ctx, $src) = @_; return 1 if defined $ctx->{tmp} and $ctx->{used} <= 0; return 1 if $ctx->{used} < $ctx->{size}; return unless $ctx->{useIO}; my $res = $src->getline; if (defined $res) { if ($ctx->{has_ahead}) { $ctx->{tmp} = $self->{_AHEAD}; $ctx->{tmp} .= $ctx->{eol} if $ctx->{eol_len}; $ctx->{tmp} .= $res; $ctx->{has_ahead} = 0; } else { $ctx->{tmp} = $res; } if ($ctx->{size} = length $ctx->{tmp}) { $ctx->{used} = -1; $ctx->{utf8} = 1 if utf8::is_utf8($ctx->{tmp}); pos($ctx->{tmp}) = 0; return 1; } } elsif (delete $ctx->{has_leftover}) { $ctx->{tmp} = $self->{_AHEAD}; $ctx->{has_ahead} = 0; $ctx->{useIO} |= useIO_EOF; if ($ctx->{size} = length $ctx->{tmp}) { $ctx->{used} = -1; $ctx->{utf8} = 1 if utf8::is_utf8($ctx->{tmp}); pos($ctx->{tmp}) = 0; return 1; } } $ctx->{tmp} = '' unless defined $ctx->{tmp}; $ctx->{useIO} |= useIO_EOF; return; } sub __set_eol_is_cr { my ($self, $ctx) = @_; $ctx->{eol_is_cr} = 1; $ctx->{eol_len} = 1; $ctx->{eol} = "\015"; $ctx->{eol_type} = EOL_TYPE_CR; %{$self->{_CACHE}} = %$ctx; $self->{eol} = $ctx->{eol}; } sub __bound_field { my ($self, $ctx, $i, $keep) = @_; if ($i >= $ctx->{is_bound}) { $self->SetDiag(3006); return; } if (ref $ctx->{bound} eq 'ARRAY') { my $ref = $ctx->{bound}[$i]; if (ref $ref) { if ($keep) { return $ref; } unless (Scalar::Util::readonly($$ref)) { $$ref = ""; return $ref; } } } $self->SetDiag(3008); return; } sub __get { my ($self, $ctx, $src) = @_; return unless defined $ctx->{used}; if ($ctx->{used} >= $ctx->{size}) { if ($self->__get_from_src($ctx, $src)) { return $self->__get($ctx, $src); } return; } my $pos = pos($ctx->{tmp}); if ($ctx->{tmp} =~ /\G($ctx->{_re}|.)/gs) { my $c = $1; if ($c =~ /[^\x09\012\015\x20-\x7e]/) { $ctx->{flag} |= IS_BINARY; } $ctx->{used} = pos($ctx->{tmp}); return $c; } else { if ($self->__get_from_src($ctx, $src)) { return $self->__get($ctx, $src); } pos($ctx->{tmp}) = $pos; return; } } sub __error_inside_quotes { my ($self, $ctx, $error) = @_; $self->__parse_error($ctx, $error, $ctx->{used} - 1); } sub __error_inside_field { my ($self, $ctx, $error) = @_; $self->__parse_error($ctx, $error, $ctx->{used} - 1); } sub __parse_error { my ($self, $ctx, $error, $pos, $line) = @_; $line ||= (caller(1))[2]; $self->{_ERROR_POS} = $pos; $self->{_ERROR_FLD} = $ctx->{fld_idx}; $self->{_ERROR_INPUT} = $ctx->{tmp} if $ctx->{tmp}; $self->_set_diag($ctx, $error, $line); return; } sub __error_eol { my ($self, $ctx) = @_; unless ($ctx->{strict_eol} & 0x40) { $self->__parse_error($ctx, 2016, $ctx->{used} - 1); } if ($ctx->{strict_eol} & 0x0e) { if (!$ctx->{is_bound}) { return; } } $ctx->{strict_eol} |= 0x40; } sub __is_whitespace { my ($self, $ctx, $c) = @_; return unless defined $c; return ( (!defined $ctx->{sep} or $c ne $ctx->{sep}) && (!defined $ctx->{quo} or $c ne $ctx->{quo}) && (!defined $ctx->{escape_char} or $c ne $ctx->{escape_char}) && ($c eq " " or $c eq "\t") ); } sub __push_value { # AV_PUSH (part of) my ($self, $ctx, $v_ref, $fields, $fflags, $flag, $fnum) = @_; utf8::encode($$v_ref) if $ctx->{utf8}; if ($ctx->{formula} && defined $$v_ref && substr($$v_ref, 0, 1) eq '=') { my $value = $self->_formula($ctx, $$v_ref, $fnum); push @$fields, defined $value ? $value : undef; return; } if ( (!defined $$v_ref or $$v_ref eq '') and ($ctx->{empty_is_undef} or (!($flag & IS_QUOTED) and $ctx->{blank_is_undef})) ) { $$v_ref = undef; } else { if ($ctx->{allow_whitespace} && !($flag & IS_QUOTED)) { $$v_ref =~ s/[ \t]+$//; } if ($flag & IS_BINARY and $ctx->{decode_utf8} and ($ctx->{utf8} || _is_valid_utf8($$v_ref))) { utf8::decode($$v_ref); } } unless ($ctx->{is_bound}) { push @$fields, $$v_ref; } if ($ctx->{keep_meta_info} and $fflags) { push @$fflags, $flag; } } sub getline { my ($self, $io) = @_; my (@fields, @fflags); my $res = $self->__parse(\@fields, \@fflags, $io, 1); $res ? \@fields : undef; } sub getline_all { my ($self, $io, $offset, $len) = @_; my $ctx = $self->_setup_ctx; my $tail = 0; my $n = 0; $offset ||= 0; if ($offset < 0) { $tail = -$offset; $offset = -1; } my (@row, @list); while ($self->___parse($ctx, \@row, undef, $io, 1)) { $ctx = $self->_setup_ctx; if ($offset > 0) { $offset--; @row = (); next; } if ($n++ >= $tail and $tail) { shift @list; $n--; } if (($ctx->{has_hooks} || 0) & HOOK_AFTER_PARSE) { unless ($self->_hook(after_parse => \@row)) { @row = (); next; } } push @list, [@row]; @row = (); last if defined $len && $n >= $len and $offset >= 0; # exceeds limit size } if (defined $len && $n > $len) { @list = splice(@list, 0, $len); } return \@list; } sub _is_valid_utf8 { return ($_[0] =~ /^(?: [\x00-\x7F] |[\xC2-\xDF][\x80-\xBF] |[\xE0][\xA0-\xBF][\x80-\xBF] |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] |[\xED][\x80-\x9F][\x80-\xBF] |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] )+$/x) ? 1 : 0; } ################################################################################ # methods for errors ################################################################################ sub _set_error_diag { my ($self, $error, $pos) = @_; $self->SetDiag($error); if (defined $pos) { $_[0]->{_ERROR_POS} = $pos; } return; } sub error_input { my $self = shift; if ($self and ((Scalar::Util::reftype($self) || '') eq 'HASH' or (ref $self) =~ /^Text::CSV/)) { return $self->{_ERROR_INPUT}; } return; } sub _sv_diag { my ($self, $error) = @_; bless [$error, $ERRORS->{$error}], 'Text::CSV::ErrorDiag'; } sub _set_diag { my ($self, $ctx, $error, $line) = @_; $last_error = $self->_sv_diag($error); $self->{_ERROR_DIAG} = $last_error; if ($error == 0) { $self->{_ERROR_POS} = 0; $self->{_ERROR_FLD} = 0; $self->{_ERROR_INPUT} = undef; $ctx->{has_error_input} = 0; } if ($line) { $self->{_ERROR_SRC} = $line; } if ($error == 2012) { # EOF $self->{_EOF} = 1; } if ($ctx->{auto_diag}) { $self->error_diag; } return $last_error; } sub SetDiag { my ($self, $error, $errstr) = @_; my $res; if (ref $self) { my $ctx = $self->_setup_ctx; $res = $self->_set_diag($ctx, $error); } else { $last_error = $error; $res = $self->_sv_diag($error); } if (defined $errstr) { $res->[1] = $errstr; } $res; } ################################################################################ package Text::CSV::ErrorDiag; use strict; use overload ( '""' => \&stringify, '+' => \&numeric, '-' => \&numeric, '*' => \&numeric, '/' => \&numeric, fallback => 1, ); sub numeric { my ($left, $right) = @_; return ref $left ? $left->[0] : $right->[0]; } sub stringify { $_[0]->[1]; } ################################################################################ 1; __END__ =head1 NAME Text::CSV_PP - Text::CSV_XS compatible pure-Perl module =head1 SYNOPSIS This section is taken from Text::CSV_XS. # Functional interface use Text::CSV_PP qw( csv ); # Read whole file in memory my $aoa = csv (in => "data.csv"); # as array of array my $aoh = csv (in => "data.csv", headers => "auto"); # as array of hash # Write array of arrays as csv file csv (in => $aoa, out => "file.csv", sep_char => ";"); # Only show lines where "code" is odd csv (in => "data.csv", filter => { code => sub { $_ % 2 }}); # Object interface use Text::CSV_PP; my @rows; # Read/parse CSV my $csv = Text::CSV_PP->new ({ binary => 1, auto_diag => 1 }); open my $fh, "<:encoding(utf8)", "test.csv" or die "test.csv: $!"; while (my $row = $csv->getline ($fh)) { $row->[2] =~ m/pattern/ or next; # 3rd field should match push @rows, $row; } close $fh; # and write as CSV open $fh, ">:encoding(utf8)", "new.csv" or die "new.csv: $!"; $csv->say ($fh, $_) for @rows; close $fh or die "new.csv: $!"; =head1 DESCRIPTION Text::CSV_PP is a pure-perl module that provides facilities for the composition and decomposition of comma-separated values. This is (almost) compatible with much faster L, and mainly used as its fallback module when you use L module without having installed Text::CSV_XS. If you don't have any reason to use this module directly, use Text::CSV for speed boost and portability (or maybe Text::CSV_XS when you write an one-off script and don't need to care about portability). The following caveats are taken from the doc of Text::CSV_XS. =head2 Embedded newlines B: The default behavior is to accept only ASCII characters in the range from C<0x20> (space) to C<0x7E> (tilde). This means that the fields can not contain newlines. If your data contains newlines embedded in fields, or characters above C<0x7E> (tilde), or binary data, you B> set C<< binary => 1 >> in the call to L. To cover the widest range of parsing options, you will always want to set binary. But you still have the problem that you have to pass a correct line to the L method, which is more complicated from the usual point of usage: my $csv = Text::CSV_PP->new ({ binary => 1, eol => $/ }); while (<>) { # WRONG! $csv->parse ($_); my @fields = $csv->fields (); } this will break, as the C might read broken lines: it does not care about the quoting. If you need to support embedded newlines, the way to go is to B pass L|/eol> in the parser (it accepts C<\n>, C<\r>, B C<\r\n> by default) and then my $csv = Text::CSV_PP->new ({ binary => 1 }); open my $fh, "<", $file or die "$file: $!"; while (my $row = $csv->getline ($fh)) { my @fields = @$row; } The old(er) way of using global file handles is still supported while (my $row = $csv->getline (*ARGV)) { ... } =head2 Unicode Unicode is only tested to work with perl-5.8.2 and up. See also L. The simplest way to ensure the correct encoding is used for in- and output is by either setting layers on the filehandles, or setting the L argument for L. open my $fh, "<:encoding(UTF-8)", "in.csv" or die "in.csv: $!"; or my $aoa = csv (in => "in.csv", encoding => "UTF-8"); open my $fh, ">:encoding(UTF-8)", "out.csv" or die "out.csv: $!"; or csv (in => $aoa, out => "out.csv", encoding => "UTF-8"); On parsing (both for L and L), if the source is marked being UTF8, then all fields that are marked binary will also be marked UTF8. On combining (L and L): if any of the combining fields was marked UTF8, the resulting string will be marked as UTF8. Note however that all fields I the first field marked UTF8 and contained 8-bit characters that were not upgraded to UTF8, these will be C in the resulting string too, possibly causing unexpected errors. If you pass data of different encoding, or you don't know if there is different encoding, force it to be upgraded before you pass them on: $csv->print ($fh, [ map { utf8::upgrade (my $x = $_); $x } @data ]); For complete control over encoding, please use L: use Text::CSV::Encoded; my $csv = Text::CSV::Encoded->new ({ encoding_in => "iso-8859-1", # the encoding comes into Perl encoding_out => "cp1252", # the encoding comes out of Perl }); $csv = Text::CSV::Encoded->new ({ encoding => "utf8" }); # combine () and print () accept *literally* utf8 encoded data # parse () and getline () return *literally* utf8 encoded data $csv = Text::CSV::Encoded->new ({ encoding => undef }); # default # combine () and print () accept UTF8 marked data # parse () and getline () return UTF8 marked data =head2 BOM BOM (or Byte Order Mark) handling is available only inside the L method. This method supports the following encodings: C, C, C, C, C, C, C, C, C, and C. See L. If a file has a BOM, the easiest way to deal with that is my $aoh = csv (in => $file, detect_bom => 1); All records will be encoded based on the detected BOM. This implies a call to the L method, which defaults to also set the L. So this is B the same as my $aoh = csv (in => $file, headers => "auto"); which only reads the first record to set L but ignores any meaning of possible present BOM. =head1 METHODS This section is also taken from Text::CSV_XS. =head2 version (Class method) Returns the current module version. =head2 new (Class method) Returns a new instance of class Text::CSV_PP. The attributes are described by the (optional) hash ref C<\%attr>. my $csv = Text::CSV_PP->new ({ attributes ... }); The following attributes are available: =head3 eol my $csv = Text::CSV_PP->new ({ eol => $/ }); $csv->eol (undef); my $eol = $csv->eol; The end-of-line string to add to rows for L or the record separator for L. When not passed in a B instance, the default behavior is to accept C<\n>, C<\r>, and C<\r\n>, so it is probably safer to not specify C at all. Passing C or the empty string behave the same. When not passed in a B instance, records are not terminated at all, so it is probably wise to pass something you expect. A safe choice for C on output is either C<$/> or C<\r\n>. Common values for C are C<"\012"> (C<\n> or Line Feed), C<"\015\012"> (C<\r\n> or Carriage Return, Line Feed), and C<"\015"> (C<\r> or Carriage Return). The L|/eol> attribute cannot exceed 7 (ASCII) characters. If both C<$/> and L|/eol> equal C<"\015">, parsing lines that end on only a Carriage Return without Line Feed, will be Ld correct. =head3 eol_type my $eol = $csv->eol_type; This read-only method returns the internal state of what is considered the valid EOL for parsing. =head3 sep_char my $csv = Text::CSV_PP->new ({ sep_char => ";" }); $csv->sep_char (";"); my $c = $csv->sep_char; The char used to separate fields, by default a comma. (C<,>). Limited to a single-byte character, usually in the range from C<0x20> (space) to C<0x7E> (tilde). When longer sequences are required, use L|/sep>. The separation character can not be equal to the quote character or to the escape character. =head3 sep my $csv = Text::CSV_PP->new ({ sep => "\N{FULLWIDTH COMMA}" }); $csv->sep (";"); my $sep = $csv->sep; The chars used to separate fields, by default undefined. Limited to 8 bytes. When set, overrules L|/sep_char>. If its length is one byte it acts as an alias to L|/sep_char>. =head3 quote_char my $csv = Text::CSV_PP->new ({ quote_char => "'" }); $csv->quote_char (undef); my $c = $csv->quote_char; The character to quote fields containing blanks or binary data, by default the double quote character (C<">). A value of undef suppresses quote chars (for simple cases only). Limited to a single-byte character, usually in the range from C<0x20> (space) to C<0x7E> (tilde). When longer sequences are required, use L|/quote>. C can not be equal to L|/sep_char>. =head3 quote my $csv = Text::CSV_PP->new ({ quote => "\N{FULLWIDTH QUOTATION MARK}" }); $csv->quote ("'"); my $quote = $csv->quote; The chars used to quote fields, by default undefined. Limited to 8 bytes. When set, overrules L|/quote_char>. If its length is one byte it acts as an alias to L|/quote_char>. This method does not support C. Use L|/quote_char> to disable quotation. =head3 escape_char my $csv = Text::CSV_PP->new ({ escape_char => "\\" }); $csv->escape_char (":"); my $c = $csv->escape_char; The character to escape certain characters inside quoted fields. This is limited to a single-byte character, usually in the range from C<0x20> (space) to C<0x7E> (tilde). The C defaults to being the double-quote mark (C<">). In other words the same as the default L|/quote_char>. This means that doubling the quote mark in a field escapes it: "foo","bar","Escape ""quote mark"" with two ""quote marks""","baz" If you change the L|/quote_char> without changing the C, the C will still be the double-quote (C<">). If instead you want to escape the L|/quote_char> by doubling it you will need to also change the C to be the same as what you have changed the L|/quote_char> to. Setting C to C or C<""> will completely disable escapes and is greatly discouraged. This will also disable C. The escape character can not be equal to the separation character. =head3 binary my $csv = Text::CSV_PP->new ({ binary => 1 }); $csv->binary (0); my $f = $csv->binary; If this attribute is C<1>, you may use binary characters in quoted fields, including line feeds, carriage returns and C bytes. (The latter could be escaped as C<"0>.) By default this feature is off. If a string is marked UTF8, C will be turned on automatically when binary characters other than C and C are encountered. Note that a simple string like C<"\x{00a0}"> might still be binary, but not marked UTF8, so setting C<< { binary => 1 } >> is still a wise option. =head3 strict my $csv = Text::CSV_PP->new ({ strict => 1 }); $csv->strict (0); my $f = $csv->strict; If this attribute is set to C<1>, any row that parses to a different number of fields than the previous row will cause the parser to throw error 2014. Empty rows or rows that result in no fields (like comment lines) are exempt from these checks. =head3 strict_eol my $csv = Text::CSV_PP->new ({ strict_eol => 1 }); $csv->strict_eol (0); my $f = $csv->strict_eol; If this attribute is set to C<0>, no EOL consistency checks are done. If this attribute is set to C<1>, any row that parses with a EOL other than the EOL from the first row will cause a warning. The error will be ignored and parsing continues. This warning is only thrown once. Note that in data with various different line endings, C<\r\r> will still throw an error that cannot be ignored. If this attribute is set to C<2> or higher, any row that parses with a EOL other than the EOL from the first row will cause error C<2016> to be thrown. The line being parsed to this error might not be stored in the result. =head3 skip_empty_rows my $csv = Text::CSV_PP->new ({ skip_empty_rows => 1 }); $csv->skip_empty_rows ("eof"); my $f = $csv->skip_empty_rows; This attribute defines the behavior for empty rows: an L immediately following the start of line. Default behavior is to return one single empty field. This attribute is only used in parsing. This attribute is ineffective when using L and L. Possible values for this attribute are =over 2 =item 0 | undef my $csv = Text::CSV_PP->new ({ skip_empty_rows => 0 }); $csv->skip_empty_rows (undef); No special action is taken. The result will be one single empty field. =item 1 | "skip" my $csv = Text::CSV_PP->new ({ skip_empty_rows => 1 }); $csv->skip_empty_rows ("skip"); The row will be skipped. =item 2 | "eof" | "stop" my $csv = Text::CSV_PP->new ({ skip_empty_rows => 2 }); $csv->skip_empty_rows ("eof"); The parsing will stop as if an L was detected. =item 3 | "die" my $csv = Text::CSV_PP->new ({ skip_empty_rows => 3 }); $csv->skip_empty_rows ("die"); The parsing will stop. The internal error code will be set to 2015 and the parser will C. =item 4 | "croak" my $csv = Text::CSV_PP->new ({ skip_empty_rows => 4 }); $csv->skip_empty_rows ("croak"); The parsing will stop. The internal error code will be set to 2015 and the parser will C. =item 5 | "error" my $csv = Text::CSV_PP->new ({ skip_empty_rows => 5 }); $csv->skip_empty_rows ("error"); The parsing will fail. The internal error code will be set to 2015. =item callback my $csv = Text::CSV_PP->new ({ skip_empty_rows => sub { [] } }); $csv->skip_empty_rows (sub { [ 42, $., undef, "empty" ] }); The callback is invoked and its result used instead. If you want the parse to stop after the callback, make sure to return a false value. The returned value from the callback should be an array-ref. Any other type will cause the parse to stop, so these are equivalent in behavior: csv (in => $fh, skip_empty_rows => "stop"); csv (in => $fh. skip_empty_rows => sub { 0; }); =back Without arguments, the current value is returned: C<0>, C<1>, C, C, C or the callback. =head3 formula_handling Alias for L =head3 formula my $csv = Text::CSV_PP->new ({ formula => "none" }); $csv->formula ("none"); my $f = $csv->formula; This defines the behavior of fields containing I. As formulas are considered dangerous in spreadsheets, this attribute can define an optional action to be taken if a field starts with an equal sign (C<=>). For purpose of code-readability, this can also be written as my $csv = Text::CSV_PP->new ({ formula_handling => "none" }); $csv->formula_handling ("none"); my $f = $csv->formula_handling; Possible values for this attribute are =over 2 =item none Take no specific action. This is the default. $csv->formula ("none"); =item die Cause the process to C whenever a leading C<=> is encountered. $csv->formula ("die"); =item croak Cause the process to C whenever a leading C<=> is encountered. (See L) $csv->formula ("croak"); =item diag Report position and content of the field whenever a leading C<=> is found. The value of the field is unchanged. $csv->formula ("diag"); =item empty Replace the content of fields that start with a C<=> with the empty string. $csv->formula ("empty"); $csv->formula (""); =item undef Replace the content of fields that start with a C<=> with C. $csv->formula ("undef"); $csv->formula (undef); =item a callback Modify the content of fields that start with a C<=> with the return-value of the callback. The original content of the field is available inside the callback as C<$_>; # Replace all formula's with 42 $csv->formula (sub { 42; }); # same as $csv->formula ("empty") but slower $csv->formula (sub { "" }); # Allow =4+12 $csv->formula (sub { s/^=(\d+\+\d+)$/$1/eer }); # Allow more complex calculations $csv->formula (sub { eval { s{^=([-+*/0-9()]+)$}{$1}ee }; $_ }); =back All other values will give a warning and then fallback to C. =head3 decode_utf8 my $csv = Text::CSV_PP->new ({ decode_utf8 => 1 }); $csv->decode_utf8 (0); my $f = $csv->decode_utf8; This attributes defaults to TRUE. While I, fields that are valid UTF-8, are automatically set to be UTF-8, so that $csv->parse ("\xC4\xA8\n"); results in PV("\304\250"\0) [UTF8 "\x{128}"] Sometimes it might not be a desired action. To prevent those upgrades, set this attribute to false, and the result will be PV("\304\250"\0) =head3 auto_diag my $csv = Text::CSV_PP->new ({ auto_diag => 1 }); $csv->auto_diag (2); my $l = $csv->auto_diag; Set this attribute to a number between C<1> and C<9> causes L to be automatically called in void context upon errors. In case of error C<2012 - EOF>, this call will be void. If C is set to a numeric value greater than C<1>, it will C on errors instead of C. If set to anything unrecognized, it will be silently ignored. Future extensions to this feature will include more reliable auto-detection of C being active in the scope of which the error occurred which will increment the value of C with C<1> the moment the error is detected. =head3 diag_verbose my $csv = Text::CSV_PP->new ({ diag_verbose => 1 }); $csv->diag_verbose (2); my $l = $csv->diag_verbose; Set the verbosity of the output triggered by C. Currently only adds the current input-record-number (if known) to the diagnostic output with an indication of the position of the error. =head3 blank_is_undef my $csv = Text::CSV_PP->new ({ blank_is_undef => 1 }); $csv->blank_is_undef (0); my $f = $csv->blank_is_undef; Under normal circumstances, C data makes no distinction between quoted- and unquoted empty fields. These both end up in an empty string field once read, thus 1,"",," ",2 is read as ("1", "", "", " ", "2") When I C files with either L|/always_quote> or L|/quote_empty> set, the unquoted I field is the result of an undefined value. To enable this distinction when I C data, the C attribute will cause unquoted empty fields to be set to C, causing the above to be parsed as ("1", "", undef, " ", "2") Note that this is specifically important when loading C fields into a database that allows C values, as the perl equivalent for C is C in L land. =head3 empty_is_undef my $csv = Text::CSV_PP->new ({ empty_is_undef => 1 }); $csv->empty_is_undef (0); my $f = $csv->empty_is_undef; Going one step further than L|/blank_is_undef>, this attribute converts all empty fields to C, so 1,"",," ",2 is read as (1, undef, undef, " ", 2) Note that this affects only fields that are originally empty, not fields that are empty after stripping allowed whitespace. YMMV. =head3 allow_whitespace my $csv = Text::CSV_PP->new ({ allow_whitespace => 1 }); $csv->allow_whitespace (0); my $f = $csv->allow_whitespace; When this option is set to true, the whitespace (C's and C's) surrounding the separation character is removed when parsing. If either C or C is one of the three characters L|/sep_char>, L|/quote_char>, or L|/escape_char> it will not be considered whitespace. Now lines like: 1 , "foo" , bar , 3 , zapp are parsed as valid C, even though it violates the C specs. Note that B whitespace is stripped from both start and end of each field. That would make it I than a I to enable parsing bad C lines, as 1, 2.0, 3, ape , monkey will now be parsed as ("1", "2.0", "3", "ape", "monkey") even if the original line was perfectly acceptable C. =head3 allow_loose_quotes my $csv = Text::CSV_PP->new ({ allow_loose_quotes => 1 }); $csv->allow_loose_quotes (0); my $f = $csv->allow_loose_quotes; By default, parsing unquoted fields containing L|/quote_char> characters like 1,foo "bar" baz,42 would result in parse error 2034. Though it is still bad practice to allow this format, we cannot help the fact that some vendors make their applications spit out lines styled this way. If there is B bad C data, like 1,"foo "bar" baz",42 or 1,""foo bar baz"",42 there is a way to get this data-line parsed and leave the quotes inside the quoted field as-is. This can be achieved by setting C B making sure that the L|/escape_char> is I equal to L|/quote_char>. =head3 allow_loose_escapes my $csv = Text::CSV_PP->new ({ allow_loose_escapes => 1 }); $csv->allow_loose_escapes (0); my $f = $csv->allow_loose_escapes; Parsing fields that have L|/escape_char> characters that escape characters that do not need to be escaped, like: my $csv = Text::CSV_PP->new ({ escape_char => "\\" }); $csv->parse (qq{1,"my bar\'s",baz,42}); would result in parse error 2025. Though it is bad practice to allow this format, this attribute enables you to treat all escape character sequences equal. =head3 allow_unquoted_escape my $csv = Text::CSV_PP->new ({ allow_unquoted_escape => 1 }); $csv->allow_unquoted_escape (0); my $f = $csv->allow_unquoted_escape; A backward compatibility issue where L|/escape_char> differs from L|/quote_char> prevents L|/escape_char> to be in the first position of a field. If L|/quote_char> is equal to the default C<"> and L|/escape_char> is set to C<\>, this would be illegal: 1,\0,2 Setting this attribute to C<1> might help to overcome issues with backward compatibility and allow this style. =head3 always_quote my $csv = Text::CSV_PP->new ({ always_quote => 1 }); $csv->always_quote (0); my $f = $csv->always_quote; By default the generated fields are quoted only if they I to be. For example, if they contain the separator character. If you set this attribute to C<1> then I defined fields will be quoted. (C fields are not quoted, see L). This makes it quite often easier to handle exported data in external applications. =head3 quote_space my $csv = Text::CSV_PP->new ({ quote_space => 1 }); $csv->quote_space (0); my $f = $csv->quote_space; By default, a space in a field would trigger quotation. As no rule exists this to be forced in C, nor any for the opposite, the default is true for safety. You can exclude the space from this trigger by setting this attribute to 0. =head3 quote_empty my $csv = Text::CSV_PP->new ({ quote_empty => 1 }); $csv->quote_empty (0); my $f = $csv->quote_empty; By default the generated fields are quoted only if they I to be. An empty (defined) field does not need quotation. If you set this attribute to C<1> then I defined fields will be quoted. (C fields are not quoted, see L). See also L|/always_quote>. =head3 quote_binary my $csv = Text::CSV_PP->new ({ quote_binary => 1 }); $csv->quote_binary (0); my $f = $csv->quote_binary; By default, all "unsafe" bytes inside a string cause the combined field to be quoted. By setting this attribute to C<0>, you can disable that trigger for bytes C<< >= 0x7F >>. =head3 escape_null my $csv = Text::CSV_PP->new ({ escape_null => 1 }); $csv->escape_null (0); my $f = $csv->escape_null; By default, a C byte in a field would be escaped. This option enables you to treat the C byte as a simple binary character in binary mode (the C<< { binary => 1 } >> is set). The default is true. You can prevent C escapes by setting this attribute to C<0>. When the C attribute is set to undefined, this attribute will be set to false. The default setting will encode "=\x00=" as "="0=" With C set, this will result in "=\x00=" The default when using the C function is C. For backward compatibility reasons, the deprecated old name C is still recognized. =head3 keep_meta_info my $csv = Text::CSV_PP->new ({ keep_meta_info => 1 }); $csv->keep_meta_info (0); my $f = $csv->keep_meta_info; By default, the parsing of input records is as simple and fast as possible. However, some parsing information - like quotation of the original field - is lost in that process. Setting this flag to true enables retrieving that information after parsing with the methods L, L, and L described below. Default is false for performance. If you set this attribute to a value greater than 9, then you can control output quotation style like it was used in the input of the the last parsed record (unless quotation was added because of other reasons). my $csv = Text::CSV_PP->new ({ binary => 1, keep_meta_info => 1, quote_space => 0, }); my $row = $csv->parse (q{1,,"", ," ",f,"g","h""h",help,"help"}); $csv->print (*STDOUT, \@row); # 1,,, , ,f,g,"h""h",help,help $csv->keep_meta_info (11); $csv->print (*STDOUT, \@row); # 1,,"", ," ",f,"g","h""h",help,"help" =head3 undef_str my $csv = Text::CSV_PP->new ({ undef_str => "\\N" }); $csv->undef_str (undef); my $s = $csv->undef_str; This attribute optionally defines the output of undefined fields. The value passed is not changed at all, so if it needs quotation, the quotation needs to be included in the value of the attribute. Use with caution, as passing a value like C<",",,,,"""> will for sure mess up your output. The default for this attribute is C, meaning no special treatment. This attribute is useful when exporting CSV data to be imported in custom loaders, like for MySQL, that recognize special sequences for C data. This attribute has no meaning when parsing CSV data. =head3 comment_str my $csv = Text::CSV_PP->new ({ comment_str => "#" }); $csv->comment_str (undef); my $s = $csv->comment_str; This attribute optionally defines a string to be recognized as comment. If this attribute is defined, all lines starting with this sequence will not be parsed as CSV but skipped as comment. This attribute has no meaning when generating CSV. Comment strings that start with any of the special characters/sequences are not supported (so it cannot start with any of L, L, L, L, L, or L). For convenience, C is an alias for C. =head3 verbatim my $csv = Text::CSV_PP->new ({ verbatim => 1 }); $csv->verbatim (0); my $f = $csv->verbatim; This is a quite controversial attribute to set, but makes some hard things possible. The rationale behind this attribute is to tell the parser that the normally special characters newline (C) and Carriage Return (C) will not be special when this flag is set, and be dealt with as being ordinary binary characters. This will ease working with data with embedded newlines. When C is used with L, L auto-C's every line. Imagine a file format like M^^Hans^Janssen^Klas 2\n2A^Ja^11-06-2007#\r\n where, the line ending is a very specific C<"#\r\n">, and the sep_char is a C<^> (caret). None of the fields is quoted, but embedded binary data is likely to be present. With the specific line ending, this should not be too hard to detect. By default, Text::CSV_PP' parse function is instructed to only know about C<"\n"> and C<"\r"> to be legal line endings, and so has to deal with the embedded newline as a real C, so it can scan the next line if binary is true, and the newline is inside a quoted field. With this option, we tell L to parse the line as if C<"\n"> is just nothing more than a binary character. For L this means that the parser has no more idea about line ending and L Cs line endings on reading. =head3 types A set of column types; the attribute is immediately passed to the L method. =head3 callbacks See the L section below. =head3 accessors To sum it up, $csv = Text::CSV_PP->new (); is equivalent to $csv = Text::CSV_PP->new ({ eol => undef, # \r, \n, or \r\n sep_char => ',', sep => undef, quote_char => '"', quote => undef, escape_char => '"', binary => 0, decode_utf8 => 1, auto_diag => 0, diag_verbose => 0, blank_is_undef => 0, empty_is_undef => 0, allow_whitespace => 0, allow_loose_quotes => 0, allow_loose_escapes => 0, allow_unquoted_escape => 0, always_quote => 0, quote_empty => 0, quote_space => 1, escape_null => 1, quote_binary => 1, keep_meta_info => 0, strict => 0, skip_empty_rows => 0, formula => 0, verbatim => 0, undef_str => undef, comment_str => undef, types => undef, callbacks => undef, }); For all of the above mentioned flags, an accessor method is available where you can inquire the current value, or change the value my $quote = $csv->quote_char; $csv->binary (1); It is not wise to change these settings halfway through writing C data to a stream. If however you want to create a new stream using the available C object, there is no harm in changing them. If the L constructor call fails, it returns C, and makes the fail reason available through the L method. $csv = Text::CSV_PP->new ({ ecs_char => 1 }) or die "".Text::CSV_PP->error_diag (); L will return a string like "INI - Unknown attribute 'ecs_char'" =head2 known_attributes @attr = Text::CSV_PP->known_attributes; @attr = Text::CSV_PP::known_attributes; @attr = $csv->known_attributes; This method will return an ordered list of all the supported attributes as described above. This can be useful for knowing what attributes are valid in classes that use or extend Text::CSV_PP. =head2 print $status = $csv->print ($fh, $colref); Similar to L + L + L, but much more efficient. It expects an array ref as input (not an array!) and the resulting string is not really created, but immediately written to the C<$fh> object, typically an IO handle or any other object that offers a L method. For performance reasons C does not create a result string, so all L, L, L, and L methods will return undefined information after executing this method. If C<$colref> is C (explicit, not through a variable argument) and L was used to specify fields to be printed, it is possible to make performance improvements, as otherwise data would have to be copied as arguments to the method call: $csv->bind_columns (\($foo, $bar)); $status = $csv->print ($fh, undef); A short benchmark my @data = ("aa" .. "zz"); $csv->bind_columns (\(@data)); $csv->print ($fh, [ @data ]); # 11800 recs/sec $csv->print ($fh, \@data ); # 57600 recs/sec $csv->print ($fh, undef ); # 48500 recs/sec =head2 say $status = $csv->say ($fh, $colref); Like L|/print>, but L|/eol> defaults to C<$\>. =head2 print_hr $csv->print_hr ($fh, $ref); Provides an easy way to print a C<$ref> (as fetched with L) provided the column names are set with L. It is just a wrapper method with basic parameter checks over $csv->print ($fh, [ map { $ref->{$_} } $csv->column_names ]); =head2 combine $status = $csv->combine (@fields); This method constructs a C record from C<@fields>, returning success or failure. Failure can result from lack of arguments or an argument that contains an invalid character. Upon success, L can be called to retrieve the resultant C string. Upon failure, the value returned by L is undefined and L could be called to retrieve the invalid argument. =head2 string $line = $csv->string (); This method returns the input to L or the resultant C string of L, whichever was called more recently. =head2 getline $colref = $csv->getline ($fh); This is the counterpart to L, as L is the counterpart to L: it parses a row from the C<$fh> handle using the L method associated with C<$fh> and parses this row into an array ref. This array ref is returned by the function or C for failure. When C<$fh> does not support C, you are likely to hit errors. When fields are bound with L the return value is a reference to an empty list. The L, L, and L methods are meaningless again. =head2 getline_all $arrayref = $csv->getline_all ($fh); $arrayref = $csv->getline_all ($fh, $offset); $arrayref = $csv->getline_all ($fh, $offset, $length); This will return a reference to a list of L results. In this call, C is disabled. If C<$offset> is negative, as with C, only the last C records of C<$fh> are taken into consideration. Parameters C<$offset> and C<$length> are expected to be integers. Non-integer values are interpreted as integer without check. Given a CSV file with 10 lines: lines call ----- --------------------------------------------------------- 0..9 $csv->getline_all ($fh) # all 0..9 $csv->getline_all ($fh, 0) # all 8..9 $csv->getline_all ($fh, 8) # start at 8 - $csv->getline_all ($fh, 0, 0) # start at 0 first 0 rows 0..4 $csv->getline_all ($fh, 0, 5) # start at 0 first 5 rows 4..5 $csv->getline_all ($fh, 4, 2) # start at 4 first 2 rows 8..9 $csv->getline_all ($fh, -2) # last 2 rows 6..7 $csv->getline_all ($fh, -4, 2) # first 2 of last 4 rows =head2 getline_hr The L and L methods work together to allow you to have rows returned as hashrefs. You must call L first to declare your column names. $csv->column_names (qw( code name price description )); $hr = $csv->getline_hr ($fh); print "Price for $hr->{name} is $hr->{price} EUR\n"; L will croak if called before L. Note that L creates a hashref for every row and will be much slower than the combined use of L and L but still offering the same easy to use hashref inside the loop: my @cols = @{$csv->getline ($fh)}; $csv->column_names (@cols); while (my $row = $csv->getline_hr ($fh)) { print $row->{price}; } Could easily be rewritten to the much faster: my @cols = @{$csv->getline ($fh)}; my $row = {}; $csv->bind_columns (\@{$row}{@cols}); while ($csv->getline ($fh)) { print $row->{price}; } Your mileage may vary for the size of the data and the number of rows. With perl-5.14.2 the comparison for a 100_000 line file with 14 columns: Rate hashrefs getlines hashrefs 1.00/s -- -76% getlines 4.15/s 313% -- =head2 getline_hr_all $arrayref = $csv->getline_hr_all ($fh); $arrayref = $csv->getline_hr_all ($fh, $offset); $arrayref = $csv->getline_hr_all ($fh, $offset, $length); This will return a reference to a list of L results. In this call, L|/keep_meta_info> is disabled. =head2 parse $status = $csv->parse ($line); This method decomposes a C string into fields, returning success or failure. Failure can result from a lack of argument or the given C string is improperly formatted. Upon success, L can be called to retrieve the decomposed fields. Upon failure calling L will return undefined data and L can be called to retrieve the invalid argument. You may use the L method for setting column types. See L' description below. The C<$line> argument is supposed to be a simple scalar. Everything else is supposed to croak and set error 1500. =head2 fragment This function tries to implement RFC7111 (URI Fragment Identifiers for the text/csv Media Type) - https://datatracker.ietf.org/doc/html/rfc7111 my $AoA = $csv->fragment ($fh, $spec); In specifications, C<*> is used to specify the I item, a dash (C<->) to indicate a range. All indices are C<1>-based: the first row or column has index C<1>. Selections can be combined with the semi-colon (C<;>). When using this method in combination with L, the returned reference will point to a list of hashes instead of a list of lists. A disjointed cell-based combined selection might return rows with different number of columns making the use of hashes unpredictable. $csv->column_names ("Name", "Age"); my $AoH = $csv->fragment ($fh, "col=3;8"); If the L callback is active, it is also called on every line parsed and skipped before the fragment. =over 2 =item row row=4 row=5-7 row=6-* row=1-2;4;6-* =item col col=2 col=1-3 col=4-* col=1-2;4;7-* =item cell In cell-based selection, the comma (C<,>) is used to pair row and column cell=4,1 The range operator (C<->) using Cs can be used to define top-left and bottom-right C location cell=3,1-4,6 The C<*> is only allowed in the second part of a pair cell=3,2-*,2 # row 3 till end, only column 2 cell=3,2-3,* # column 2 till end, only row 3 cell=3,2-*,* # strip row 1 and 2, and column 1 Cells and cell ranges may be combined with C<;>, possibly resulting in rows with different numbers of columns cell=1,1-2,2;3,3-4,4;1,4;4,1 Disjointed selections will only return selected cells. The cells that are not specified will not be included in the returned set, not even as C. As an example given a C like 11,12,13,...19 21,22,...28,29 : : 91,...97,98,99 with C will return: 11,12,14 21,22 33,34 41,43,44 Overlapping cell-specs will return those cells only once, So C will return: 11,12,13 21,22,23,24 31,32,33,34 42,43,44 =back L does B allow different types of specs to be combined (either C I C I C). Passing an invalid fragment specification will croak and set error 2013. =head2 column_names Set the "keys" that will be used in the L calls. If no keys (column names) are passed, it will return the current setting as a list. L accepts a list of scalars (the column names) or a single array_ref, so you can pass the return value from L too: $csv->column_names ($csv->getline ($fh)); L does B checking on duplicates at all, which might lead to unexpected results. Undefined entries will be replaced with the string C<"\cAUNDEF\cA">, so $csv->column_names (undef, "", "name", "name"); $hr = $csv->getline_hr ($fh); will set C<< $hr->{"\cAUNDEF\cA"} >> to the 1st field, C<< $hr->{""} >> to the 2nd field, and C<< $hr->{name} >> to the 4th field, discarding the 3rd field. L croaks on invalid arguments. =head2 header This method does NOT work in perl-5.6.x Parse the CSV header and set L|/sep>, column_names and encoding. my @hdr = $csv->header ($fh); $csv->header ($fh, { sep_set => [ ";", ",", "|", "\t" ] }); $csv->header ($fh, { detect_bom => 1, munge_column_names => "lc" }); The first argument should be a file handle. This method resets some object properties, as it is supposed to be invoked only once per file or stream. It will leave attributes C and C alone if setting column names is disabled. Reading headers on previously process objects might fail on perl-5.8.0 and older. Assuming that the file opened for parsing has a header, and the header does not contain problematic characters like embedded newlines, read the first line from the open handle then auto-detect whether the header separates the column names with a character from the allowed separator list. If any of the allowed separators matches, and none of the I allowed separators match, set L|/sep> to that separator for the current CSV_PP instance and use it to parse the first line, map those to lowercase, and use that to set the instance L: my $csv = Text::CSV_PP->new ({ binary => 1, auto_diag => 1 }); open my $fh, "<", "file.csv"; binmode $fh; # for Windows $csv->header ($fh); while (my $row = $csv->getline_hr ($fh)) { ... } If the header is empty, contains more than one unique separator out of the allowed set, contains empty fields, or contains identical fields (after folding), it will croak with error 1010, 1011, 1012, or 1013 respectively. If the header contains embedded newlines or is not valid CSV in any other way, this method will croak and leave the parse error untouched. A successful call to C
will always set the L|/sep> of the C<$csv> object. This behavior can not be disabled. =head3 return value On error this method will croak. In list context, the headers will be returned whether they are used to set L or not. In scalar context, the instance itself is returned. B: the values as found in the header will effectively be B if C is false. =head3 Options =over 2 =item sep_set $csv->header ($fh, { sep_set => [ ";", ",", "|", "\t" ] }); The list of legal separators defaults to C<[ ";", "," ]> and can be changed by this option. As this is probably the most often used option, it can be passed on its own as an unnamed argument: $csv->header ($fh, [ ";", ",", "|", "\t", "::", "\x{2063}" ]); Multi-byte sequences are allowed, both multi-character and Unicode. See L|/sep>. =item detect_bom $csv->header ($fh, { detect_bom => 1 }); The default behavior is to detect if the header line starts with a BOM. If the header has a BOM, use that to set the encoding of C<$fh>. This default behavior can be disabled by passing a false value to C. Supported encodings from BOM are: UTF-8, UTF-16BE, UTF-16LE, UTF-32BE, and UTF-32LE. BOM also supports UTF-1, UTF-EBCDIC, SCSU, BOCU-1, and GB-18030 but L does not (yet). UTF-7 is not supported. If a supported BOM was detected as start of the stream, it is stored in the object attribute C. my $enc = $csv->{ENCODING}; The encoding is used with C on C<$fh>. If the handle was opened in a (correct) encoding, this method will B alter the encoding, as it checks the leading B of the first line. In case the stream starts with a decoded BOM (C), C<{ENCODING}> will be C<""> (empty) instead of the default C. =item munge_column_names This option offers the means to modify the column names into something that is most useful to the application. The default is to map all column names to lower case. $csv->header ($fh, { munge_column_names => "lc" }); The following values are available: lc - lower case uc - upper case db - valid DB field names none - do not change \%hash - supply a mapping \&cb - supply a callback =over 2 =item Lower case $csv->header ($fh, { munge_column_names => "lc" }); The header is changed to all lower-case $_ = lc; =item Upper case $csv->header ($fh, { munge_column_names => "uc" }); The header is changed to all upper-case $_ = uc; =item Literal $csv->header ($fh, { munge_column_names => "none" }); =item Hash $csv->header ($fh, { munge_column_names => { foo => "sombrero" }); if a value does not exist, the original value is used unchanged =item Database $csv->header ($fh, { munge_column_names => "db" }); =over 2 =item - lower-case =item - all sequences of non-word characters are replaced with an underscore =item - all leading underscores are removed =back $_ = lc (s/\W+/_/gr =~ s/^_+//r); =item Callback $csv->header ($fh, { munge_column_names => sub { fc } }); $csv->header ($fh, { munge_column_names => sub { "column_".$col++ } }); $csv->header ($fh, { munge_column_names => sub { lc (s/\W+/_/gr) } }); As this callback is called in a C, you can use C<$_> directly. =back =item set_column_names $csv->header ($fh, { set_column_names => 1 }); The default is to set the instances column names using L if the method is successful, so subsequent calls to L can return a hash. Disable setting the header can be forced by using a false value for this option. As described in L above, content is lost in scalar context. =back =head3 Validation When receiving CSV files from external sources, this method can be used to protect against changes in the layout by restricting to known headers (and typos in the header fields). my %known = ( "record key" => "c_rec", "rec id" => "c_rec", "id_rec" => "c_rec", "kode" => "code", "code" => "code", "vaule" => "value", "value" => "value", ); my $csv = Text::CSV_PP->new ({ binary => 1, auto_diag => 1 }); open my $fh, "<", $source or die "$source: $!"; $csv->header ($fh, { munge_column_names => sub { s/\s+$//; s/^\s+//; $known{lc $_} or die "Unknown column '$_' in $source"; }}); while (my $row = $csv->getline_hr ($fh)) { say join "\t", $row->{c_rec}, $row->{code}, $row->{value}; } =head2 bind_columns Takes a list of scalar references to be used for output with L or to store in the fields fetched by L. When you do not pass enough references to store the fetched fields in, L will fail with error C<3006>. If you pass more than there are fields to return, the content of the remaining references is left untouched. Under C the two should match, otherwise L will fail with error C<2014>. $csv->bind_columns (\$code, \$name, \$price, \$description); while ($csv->getline ($fh)) { print "The price of a $name is \x{20ac} $price\n"; } To reset or clear all column binding, call L with the single argument C. This will also clear column names. $csv->bind_columns (undef); If no arguments are passed at all, L will return the list of current bindings or C if no binds are active. Note that in parsing with C, the fields are set on the fly. That implies that if the third field of a row causes an error (or this row has just two fields where the previous row had more), the first two fields already have been assigned the values of the current row, while the rest of the fields will still hold the values of the previous row. If you want the parser to fail in these cases, use the L|/strict> attribute. =head2 eof $eof = $csv->eof (); If L or L was used with an IO stream, this method will return true (1) if the last call hit end of file, otherwise it will return false (''). This is useful to see the difference between a failure and end of file. Note that if the parsing of the last line caused an error, C is still true. That means that if you are I using L, an idiom like while (my $row = $csv->getline ($fh)) { # ... } $csv->eof or $csv->error_diag; will I report the error. You would have to change that to while (my $row = $csv->getline ($fh)) { # ... } +$csv->error_diag and $csv->error_diag; =head2 types $csv->types (\@tref); This method is used to force that (all) columns are of a given type. For example, if you have an integer column, two columns with doubles and a string column, then you might do a $csv->types ([Text::CSV_PP::IV (), Text::CSV_PP::NV (), Text::CSV_PP::NV (), Text::CSV_PP::PV ()]); Column types are used only for I columns while parsing, in other words by the L and L methods. You can unset column types by doing a $csv->types (undef); or fetch the current type settings with $types = $csv->types (); =over 4 =item IV =item CSV_TYPE_IV Set field type to integer. =item NV =item CSV_TYPE_NV Set field type to numeric/float. =item PV =item CSV_TYPE_PV Set field type to string. =back =head2 fields @columns = $csv->fields (); This method returns the input to L or the resultant decomposed fields of a successful L, whichever was called more recently. Note that the return value is undefined after using L, which does not fill the data structures returned by L. =head2 meta_info @flags = $csv->meta_info (); This method returns the "flags" of the input to L or the flags of the resultant decomposed fields of L, whichever was called more recently. For each field, a meta_info field will hold flags that inform something about the field returned by the L method or passed to the L method. The flags are bit-wise-C'd like: =over 2 =item C<0x0001> =item C The field was quoted. =item C<0x0002> =item C The field was binary. =item C<0x0004> =item C The field was invalid. Currently only used when C is active. =item C<0x0010> =item C The field was missing. =back See the C methods below. =head2 is_quoted my $quoted = $csv->is_quoted ($column_idx); where C<$column_idx> is the (zero-based) index of the column in the last result of L. This returns a true value if the data in the indicated column was enclosed in L|/quote_char> quotes. This might be important for fields where content C<,20070108,> is to be treated as a numeric value, and where C<,"20070108",> is explicitly marked as character string data. This method is only valid when L is set to a true value. =head2 is_binary my $binary = $csv->is_binary ($column_idx); where C<$column_idx> is the (zero-based) index of the column in the last result of L. This returns a true value if the data in the indicated column contained any byte in the range C<[\x00-\x08,\x10-\x1F,\x7F-\xFF]>. This method is only valid when L is set to a true value. =head2 is_missing my $missing = $csv->is_missing ($column_idx); where C<$column_idx> is the (zero-based) index of the column in the last result of L. $csv->keep_meta_info (1); while (my $hr = $csv->getline_hr ($fh)) { $csv->is_missing (0) and next; # This was an empty line } When using L, it is impossible to tell if the parsed fields are C because they where not filled in the C stream or because they were not read at all, as B the fields defined by L are set in the hash-ref. If you still need to know if all fields in each row are provided, you should enable L|/keep_meta_info> so you can check the flags. If L|/keep_meta_info> is C, C will always return C, regardless of C<$column_idx> being valid or not. If this attribute is C it will return either C<0> (the field is present) or C<1> (the field is missing). A special case is the empty line. If the line is completely empty - after dealing with the flags - this is still a valid CSV line: it is a record of just one single empty field. However, if C is set, invoking C with index C<0> will now return true. =head2 status $status = $csv->status (); This method returns the status of the last invoked L or L call. Status is success (true: C<1>) or failure (false: C or C<0>). Note that as this only keeps track of the status of above mentioned methods, you are probably looking for L|/error_diag> instead. =head2 error_input $bad_argument = $csv->error_input (); This method returns the erroneous argument (if it exists) of L or L, whichever was called more recently. If the last invocation was successful, C will return C. Depending on the type of error, it I also hold the data for the last error-input of L. =head2 error_diag Text::CSV_PP->error_diag (); $csv->error_diag (); $error_code = 0 + $csv->error_diag (); $error_str = "" . $csv->error_diag (); ($cde, $str, $pos, $rec, $fld, $xs) = $csv->error_diag (); If (and only if) an error occurred, this function returns the diagnostics of that error. If called in void context, this will print the internal error code and the associated error message to STDERR. If called in list context, this will return the error code and the error message in that order. If the last error was from parsing, the rest of the values returned are a best guess at the location within the line that was being parsed. Their values are 1-based. The position currently is index of the byte at which the parsing failed in the current record. It might change to be the index of the current character in a later release. The records is the index of the record parsed by the csv instance. The field number is the index of the field the parser thinks it is currently trying to parse. See F for how this can be used. If C<$xs> is set, it is the line number in XS where the error was triggered (for debugging). C will show in void context only when L is set. If called in scalar context, it will return the diagnostics in a single scalar, a-la C<$!>. It will contain the error code in numeric context, and the diagnostics message in string context. When called as a class method or a direct function call, the diagnostics are that of the last L call. =head3 _cache_diag Note: This is an internal function only, and output cannot be relied upon. Use at own risk. If debugging beyond what L is able to show, the internal cache can be shown with this function. # Something failed .. $csv->error_diag; $csv->_cache_diag (); =head2 record_number $recno = $csv->record_number (); Returns the records parsed by this csv instance. This value should be more accurate than C<$.> when embedded newlines come in play. Records written by this instance are not counted. =head2 SetDiag $csv->SetDiag (0); Use to reset the diagnostics if you are dealing with errors. =head1 FUNCTIONS This section is also taken from Text::CSV_XS. =head2 csv This function is not exported by default and should be explicitly requested: use Text::CSV_PP qw( csv ); This is a high-level function that aims at simple (user) interfaces. This can be used to read/parse a C file or stream (the default behavior) or to produce a file or write to a stream (define the C attribute). It returns an array- or hash-reference on parsing (or C on fail) or the numeric value of L on writing. When this function fails you can get to the error using the class call to L my $aoa = csv (in => "test.csv") or die Text::CSV_PP->error_diag; Note that failure here is the inability to start the parser, like when the input does not exist or the arguments are unknown or conflicting. Run-time parsing errors will return a valid reference, which can be empty, but still contains all results up till the error. See L. This function takes the arguments as key-value pairs. This can be passed as a list or as an anonymous hash: my $aoa = csv ( in => "test.csv", sep_char => ";"); my $aoh = csv ({ in => $fh, headers => "auto" }); The arguments passed consist of two parts: the arguments to L itself and the optional attributes to the C object used inside the function as enumerated and explained in L. If not overridden, the default option used for CSV is auto_diag => 1 escape_null => 0 strict_eol => 1 The option that is always set and cannot be altered is binary => 1 As this function will likely be used in one-liners, it allows C to be abbreviated as C, and C to be abbreviated as C or C. Alternative invocations: my $aoa = Text::CSV_PP::csv (in => "file.csv"); my $csv = Text::CSV_PP->new (); my $aoa = $csv->csv (in => "file.csv"); In the latter case, the object attributes are used from the existing object and the attribute arguments in the function call are ignored: my $csv = Text::CSV_PP->new ({ sep_char => ";" }); my $aoh = $csv->csv (in => "file.csv", bom => 1); will parse using C<;> as C, not C<,>. =head3 in Used to specify the source. C can be a file name (e.g. C<"file.csv">), which will be opened for reading and closed when finished, a file handle (e.g. C<$fh> or C), a reference to a glob (e.g. C<\*ARGV>), the glob itself (e.g. C<*STDIN>), or a reference to a scalar (e.g. C<\q{1,2,"csv"}>). When used with L, C should be a reference to a CSV structure (AoA or AoH) or a CODE-ref that returns an array-reference or a hash-reference. The code-ref will be invoked with no arguments. my $aoa = csv (in => "file.csv"); open my $fh, "<", "file.csv"; my $aoa = csv (in => $fh); my $csv = [ [qw( Foo Bar )], [ 1, 2 ], [ 2, 3 ]]; my $err = csv (in => $csv, out => "file.csv"); If called in void context without the L attribute, the resulting ref will be used as input to a subsequent call to csv: csv (in => "file.csv", filter => { 2 => sub { length > 2 }}) will be a shortcut to csv (in => csv (in => "file.csv", filter => { 2 => sub { length > 2 }})) where, in the absence of the C attribute, this is a shortcut to csv (in => csv (in => "file.csv", filter => { 2 => sub { length > 2 }}), out => *STDOUT) =head3 out csv (in => $aoa, out => "file.csv"); csv (in => $aoa, out => $fh); csv (in => $aoa, out => STDOUT); csv (in => $aoa, out => *STDOUT); csv (in => $aoa, out => \*STDOUT); csv (in => $aoa, out => \my $data); csv (in => $aoa, out => undef); csv (in => $aoa, out => \"skip"); csv (in => $fh, out => \@aoa); csv (in => $fh, out => \@aoh, bom => 1); csv (in => $fh, out => \%hsh, key => "key"); csv (in => $file, out => $file); csv (in => $file, out => $fh); csv (in => $fh, out => $file); csv (in => $fh, out => $fh); In output mode, the default CSV options when producing CSV are eol => "\r\n" The L attribute is ignored in output mode. C can be a file name (e.g. C<"file.csv">), which will be opened for writing and closed when finished, a file handle (e.g. C<$fh> or C), a reference to a glob (e.g. C<\*STDOUT>), the glob itself (e.g. C<*STDOUT>), or a reference to a scalar (e.g. C<\my $data>). csv (in => sub { $sth->fetch }, out => "dump.csv"); csv (in => sub { $sth->fetchrow_hashref }, out => "dump.csv", headers => $sth->{NAME_lc}); When a code-ref is used for C, the output is generated per invocation, so no buffering is involved. This implies that there is no size restriction on the number of records. The C function ends when the coderef returns a false value. If C is set to a reference of the literal string C<"skip">, the output will be suppressed completely, which might be useful in combination with a filter for side effects only. my %cache; csv (in => "dump.csv", out => \"skip", on_in => sub { $cache{$_[1][1]}++ }); Currently, setting C to any false value (C, C<"">, 0) will be equivalent to C<\"skip">. If the C argument point to something to parse, and the C is set to a reference to an C or a C, the output is appended to the data in the existing reference. The result of the parse should match what exists in the reference passed. This might come handy when you have to parse a set of files with similar content (like data stored per period) and you want to collect that into a single data structure: my %hash; csv (in => $_, out => \%hash, key => "id") for sort glob "foo-[0-9]*.csv"; my @list; # List of arrays csv (in => $_, out => \@list) for sort glob "foo-[0-9]*.csv"; my @list; # List of hashes csv (in => $_, out => \@list, bom => 1) for sort glob "foo-[0-9]*.csv"; =head4 Streaming If B C and C are files, file handles or globs, streaming is enforced by injecting an C callback that immediately uses the L|/say> method of the same instance to output the result and then rejects the record. If a C was already passed as attribute, that will be included in the injected call. If C was passed and C was not, it will be used instead. If both were passed, C is ignored. The EOL of the first record of the C source is consistently used as EOL for all records in the C destination. The C attribute is not available. All other attributes are shared for C and C, so you cannot define different encodings for C and C. You need to pass a C<$fh>, where C was used to apply the encoding layers. Note that this is work in progress and things might change. =head3 encoding If passed, it should be an encoding accepted by the C<:encoding()> option to C. There is no default value. This attribute does not work in perl 5.6.x. C can be abbreviated to C for ease of use in command line invocations. If C is set to the literal value C<"auto">, the method L
will be invoked on the opened stream to check if there is a BOM and set the encoding accordingly. This is equal to passing a true value in the option L|/detect_bom>. Encodings can be stacked, as supported by C: # Using PerlIO::via::gzip csv (in => \@csv, out => "test.csv:via.gz", encoding => ":via(gzip):encoding(utf-8)", ); $aoa = csv (in => "test.csv:via.gz", encoding => ":via(gzip)"); # Using PerlIO::gzip csv (in => \@csv, out => "test.csv:via.gz", encoding => ":gzip:encoding(utf-8)", ); $aoa = csv (in => "test.csv:gzip.gz", encoding => ":gzip"); =head3 detect_bom If C is given, the method L will be invoked on the opened stream to check if there is a BOM and set the encoding accordingly. C can be abbreviated to C. This is the same as setting L|/encoding> to C<"auto">. Note that as the method L is invoked, its default is to also set the headers. =head3 headers If this attribute is not given, the default behavior is to produce an array of arrays. If C is supplied, it should be an anonymous list of column names, an anonymous hashref, a coderef, or a literal flag: C, C, C, or C. =over 2 =item skip When C is used, the header will not be included in the output. my $aoa = csv (in => $fh, headers => "skip"); C is invalid/ignored in combinations with L|/detect_bom>. =item auto If C is used, the first line of the C source will be read as the list of field headers and used to produce an array of hashes. my $aoh = csv (in => $fh, headers => "auto"); =item lc If C is used, the first line of the C source will be read as the list of field headers mapped to lower case and used to produce an array of hashes. This is a variation of C. my $aoh = csv (in => $fh, headers => "lc"); =item uc If C is used, the first line of the C source will be read as the list of field headers mapped to upper case and used to produce an array of hashes. This is a variation of C. my $aoh = csv (in => $fh, headers => "uc"); =item CODE If a coderef is used, the first line of the C source will be read as the list of mangled field headers in which each field is passed as the only argument to the coderef. This list is used to produce an array of hashes. my $aoh = csv (in => $fh, headers => sub { lc ($_[0]) =~ s/kode/code/gr }); this example is a variation of using C where all occurrences of C are replaced with C. =item ARRAY If C is an anonymous list, the entries in the list will be used as field names. The first line is considered data instead of headers. my $aoh = csv (in => $fh, headers => [qw( Foo Bar )]); csv (in => $aoa, out => $fh, headers => [qw( code description price )]); =item HASH If C is a hash reference, this implies C, but header fields that exist as key in the hashref will be replaced by the value for that key. Given a CSV file like post-kode,city,name,id number,fubble 1234AA,Duckstad,Donald,13,"X313DF" using csv (headers => { "post-kode" => "pc", "id number" => "ID" }, ... will return an entry like { pc => "1234AA", city => "Duckstad", name => "Donald", ID => "13", fubble => "X313DF", } =back See also L|/munge_column_names> and L|/set_column_names>. =head3 munge_column_names If C is set, the method L is invoked on the opened stream with all matching arguments to detect and set the headers. C can be abbreviated to C. =head3 key If passed, will default L|/headers> to C<"auto"> and return a hashref instead of an array of hashes. Allowed values are simple scalars or array-references where the first element is the joiner and the rest are the fields to join to combine the key. my $ref = csv (in => "test.csv", key => "code"); my $ref = csv (in => "test.csv", key => [ ":" => "code", "color" ]); with test.csv like code,product,price,color 1,pc,850,gray 2,keyboard,12,white 3,mouse,5,black the first example will return { 1 => { code => 1, color => 'gray', price => 850, product => 'pc' }, 2 => { code => 2, color => 'white', price => 12, product => 'keyboard' }, 3 => { code => 3, color => 'black', price => 5, product => 'mouse' } } the second example will return { "1:gray" => { code => 1, color => 'gray', price => 850, product => 'pc' }, "2:white" => { code => 2, color => 'white', price => 12, product => 'keyboard' }, "3:black" => { code => 3, color => 'black', price => 5, product => 'mouse' } } The C attribute can be combined with L|/headers> for C date that has no header line, like my $ref = csv ( in => "foo.csv", headers => [qw( c_foo foo bar description stock )], key => "c_foo", ); =head3 value Used to create key-value hashes. Only allowed when C is valid. A C can be either a single column label or an anonymous list of column labels. In the first case, the value will be a simple scalar value, in the latter case, it will be a hashref. my $ref = csv (in => "test.csv", key => "code", value => "price"); my $ref = csv (in => "test.csv", key => "code", value => [ "product", "price" ]); my $ref = csv (in => "test.csv", key => [ ":" => "code", "color" ], value => "price"); my $ref = csv (in => "test.csv", key => [ ":" => "code", "color" ], value => [ "product", "price" ]); with test.csv like code,product,price,color 1,pc,850,gray 2,keyboard,12,white 3,mouse,5,black the first example will return { 1 => 850, 2 => 12, 3 => 5, } the second example will return { 1 => { price => 850, product => 'pc' }, 2 => { price => 12, product => 'keyboard' }, 3 => { price => 5, product => 'mouse' } } the third example will return { "1:gray" => 850, "2:white" => 12, "3:black" => 5, } the fourth example will return { "1:gray" => { price => 850, product => 'pc' }, "2:white" => { price => 12, product => 'keyboard' }, "3:black" => { price => 5, product => 'mouse' } } =head3 keep_headers When using hashes, keep the column names into the arrayref passed, so all headers are available after the call in the original order. my $aoh = csv (in => "file.csv", keep_headers => \my @hdr); This attribute can be abbreviated to C or passed as C. This attribute implies a default of C for the C attribute. The headers can also be kept internally to keep stable header order: csv (in => csv (in => "file.csv", kh => "internal"), out => "new.csv", kh => "internal"); where C can also be C<1>, C, or C. This is similar to my @h; csv (in => csv (in => "file.csv", kh => \@h), out => "new.csv", headers => \@h); =head3 fragment Only output the fragment as defined in the L method. This option is ignored when I C. See L. Combining all of them could give something like use Text::CSV_PP qw( csv ); my $aoh = csv ( in => "test.txt", encoding => "utf-8", headers => "auto", sep_char => "|", fragment => "row=3;6-9;15-*", ); say $aoh->[15]{Foo}; =head3 sep_set If C is set, the method L is invoked on the opened stream to detect and set L|/sep_char> with the given set. C can be abbreviated to C. If neither C not C is given, but C is defined, C defaults to C<[ sep ]>. This is only supported for perl version 5.10 and up. Note that as the L method is invoked, its default is to also set the headers. =head3 set_column_names If C is passed, the method L is invoked on the opened stream with all arguments meant for L. If C is passed as a false value, the content of the first row is only preserved if the output is AoA: With an input-file like bAr,foo 1,2 3,4,5 This call my $aoa = csv (in => $file, set_column_names => 0); will result in [[ "bar", "foo" ], [ "1", "2" ], [ "3", "4", "5" ]] and my $aoa = csv (in => $file, set_column_names => 0, munge => "none"); will result in [[ "bAr", "foo" ], [ "1", "2" ], [ "3", "4", "5" ]] =head3 csv The I L can also be called as a method or with an existing Text::CSV_PP object. This could help if the function is to be invoked a lot of times and the overhead of creating the object internally over and over again would be prevented by passing an existing instance. my $csv = Text::CSV_PP->new ({ binary => 1, auto_diag => 1 }); my $aoa = $csv->csv (in => $fh); my $aoa = csv (in => $fh, csv => $csv); both act the same. Running this 20000 times on a 20 lines CSV file, showed a 53% speedup. =head2 Callbacks Callbacks enable actions triggered from the I of Text::CSV_PP. While most of what this enables can easily be done in an unrolled loop as described in the L callbacks can be used to meet special demands or enhance the L function. =over 2 =item error $csv->callbacks (error => sub { $csv->SetDiag (0) }); the C callback is invoked when an error occurs, but I when L is set to a true value. A callback is invoked with the values returned by L: my ($c, $s); sub ignore3006 { my ($err, $msg, $pos, $recno, $fldno) = @_; if ($err == 3006) { # ignore this error ($c, $s) = (undef, undef); Text::CSV_PP->SetDiag (0); } # Any other error return; } # ignore3006 $csv->callbacks (error => \&ignore3006); $csv->bind_columns (\$c, \$s); while ($csv->getline ($fh)) { # Error 3006 will not stop the loop } =item after_parse $csv->callbacks (after_parse => sub { push @{$_[1]}, "NEW" }); while (my $row = $csv->getline ($fh)) { $row->[-1] eq "NEW"; } This callback is invoked after parsing with L only if no error occurred. The callback is invoked with two arguments: the current C parser object and an array reference to the fields parsed. The return code of the callback is ignored unless it is a reference to the string "skip", in which case the record will be skipped in L. sub add_from_db { my ($csv, $row) = @_; $sth->execute ($row->[4]); push @$row, $sth->fetchrow_array; } # add_from_db my $aoa = csv (in => "file.csv", callbacks => { after_parse => \&add_from_db }); This hook can be used for validation: =over 2 =item FAIL Die if any of the records does not validate a rule: after_parse => sub { $_[1][4] =~ m/^[0-9]{4}\s?[A-Z]{2}$/ or die "5th field does not have a valid Dutch zipcode"; } =item DEFAULT Replace invalid fields with a default value: after_parse => sub { $_[1][2] =~ m/^\d+$/ or $_[1][2] = 0 } =item SKIP Skip records that have invalid fields (only applies to L): after_parse => sub { $_[1][0] =~ m/^\d+$/ or return \"skip"; } =back =item before_print my $idx = 1; $csv->callbacks (before_print => sub { $_[1][0] = $idx++ }); $csv->print (*STDOUT, [ 0, $_ ]) for @members; This callback is invoked before printing with L only if no error occurred. The callback is invoked with two arguments: the current C parser object and an array reference to the fields passed. The return code of the callback is ignored. sub max_4_fields { my ($csv, $row) = @_; @$row > 4 and splice @$row, 4; } # max_4_fields csv (in => csv (in => "file.csv"), out => *STDOUT, callbacks => { before_print => \&max_4_fields }); This callback is not active for L. =back =head3 Callbacks for csv () The L allows for some callbacks that do not integrate in XS internals but only feature the L function. csv (in => "file.csv", callbacks => { filter => { 6 => sub { $_ > 15 } }, # first after_parse => sub { say "AFTER PARSE"; }, # first after_in => sub { say "AFTER IN"; }, # second on_in => sub { say "ON IN"; }, # third }, ); csv (in => $aoh, out => "file.csv", callbacks => { on_in => sub { say "ON IN"; }, # first before_out => sub { say "BEFORE OUT"; }, # second before_print => sub { say "BEFORE PRINT"; }, # third }, ); =over 2 =item filter This callback can be used to filter records. It is called just after a new record has been scanned. The callback accepts a: =over 2 =item hashref The keys are the index to the row (the field name or field number, 1-based) and the values are subs to return a true or false value. csv (in => "file.csv", filter => { 3 => sub { m/a/ }, # third field should contain an "a" 5 => sub { length > 4 }, # length of the 5th field minimal 5 }); csv (in => "file.csv", filter => { foo => sub { $_ > 4 }}); If the keys to the filter hash contain any character that is not a digit it will also implicitly set L to C<"auto"> unless L was already passed as argument. When headers are active, returning an array of hashes, the filter is not applicable to the header itself. All sub results should match, as in AND. The context of the callback sets C<$_> localized to the field indicated by the filter. The two arguments are as with all other callbacks, so the other fields in the current row can be seen: filter => { 3 => sub { $_ > 100 ? $_[1][1] =~ m/A/ : $_[1][6] =~ m/B/ }} If the context is set to return a list of hashes (L is defined), the current record will also be available in the localized C<%_>: filter => { 3 => sub { $_ > 100 && $_{foo} =~ m/A/ && $_{bar} < 1000 }} If the filter is used to I the content by changing C<$_>, make sure that the sub returns true in order not to have that record skipped: filter => { 2 => sub { $_ = uc }} will upper-case the second field, and then skip it if the resulting content evaluates to false. To always accept, end with truth: filter => { 2 => sub { $_ = uc; 1 }} =item coderef csv (in => "file.csv", filter => sub { $n++; 0; }); If the argument to C is a coderef, it is an alias or shortcut to a filter on column 0: csv (filter => sub { $n++; 0 }); is equal to csv (filter => { 0 => sub { $n++; 0 }); =item filter-name csv (in => "file.csv", filter => "not_blank"); csv (in => "file.csv", filter => "not_empty"); csv (in => "file.csv", filter => "filled"); These are predefined filters Given a file like (line numbers prefixed for doc purpose only): 1:1,2,3 2: 3:, 4:"" 5:,, 6:, , 7:"", 8:" " 9:4,5,6 =over 2 =item not_blank Filter out the blank lines This filter is a shortcut for filter => { 0 => sub { @{$_[1]} > 1 or defined $_[1][0] && $_[1][0] ne "" } } Due to the implementation, it is currently impossible to also filter lines that consists only of a quoted empty field. These lines are also considered blank lines. With the given example, lines 2 and 4 will be skipped. =item not_empty Filter out lines where all the fields are empty. This filter is a shortcut for filter => { 0 => sub { grep { defined && $_ ne "" } @{$_[1]} } } A space is not regarded being empty, so given the example data, lines 2, 3, 4, 5, and 7 are skipped. =item filled Filter out lines that have no visible data This filter is a shortcut for filter => { 0 => sub { grep { defined && m/\S/ } @{$_[1]} } } This filter rejects all lines that I have at least one field that does not evaluate to the empty string. With the given example data, this filter would skip lines 2 through 8. =back =back One could also use modules like L: use Types::Standard -types; my $type = Tuple[Str, Str, Int, Bool, Optional[Num]]; my $check = $type->compiled_check; # filter with compiled check and warnings my $aoa = csv ( in => \$data, filter => { 0 => sub { my $ok = $check->($_[1]) or warn $type->get_message ($_[1]), "\n"; return $ok; }, }, ); =item after_in This callback is invoked for each record after all records have been parsed but before returning the reference to the caller. The hook is invoked with two arguments: the current C parser object and a reference to the record. The reference can be a reference to a HASH or a reference to an ARRAY as determined by the arguments. This callback can also be passed as an attribute without the C wrapper. =item before_out This callback is invoked for each record before the record is printed. The hook is invoked with two arguments: the current C parser object and a reference to the record. The reference can be a reference to a HASH or a reference to an ARRAY as determined by the arguments. This callback can also be passed as an attribute without the C wrapper. This callback makes the row available in C<%_> if the row is a hashref. In this case C<%_> is writable and will change the original row. =item on_in This callback acts exactly as the L or the L hooks. This callback can also be passed as an attribute without the C wrapper. This callback makes the row available in C<%_> if the row is a hashref. In this case C<%_> is writable and will change the original row. So e.g. with my $aoh = csv ( in => \"foo\n1\n2\n", headers => "auto", on_in => sub { $_{bar} = 2; }, ); C<$aoh> will be: [ { foo => 1, bar => 2, } { foo => 2, bar => 2, } ] =item on_error This callback acts exactly as the L hook. my @err; my $aoa = csv (in => $fh, on_error => sub { @err = @_ }); is identical to my $aoa = csv (in => $fh, callbacks => { error => sub { @err = @_ }, }); It can be used for ignoring errors as well as for just keeping the error in case of analysis after the C function has returned. my @err; my $aoa = csv (in => "bad.csv, on_error => sub { @err = @_ }); die Text::CSV_PP->error_diag if @err or !$aoa; =back =head1 DIAGNOSTICS This section is also taken from Text::CSV_XS. Still under construction ... If an error occurs, C<< $csv->error_diag >> can be used to get information on the cause of the failure. Note that for speed reasons the internal value is never cleared on success, so using the value returned by L in normal cases - when no error occurred - may cause unexpected results. If the constructor failed, the cause can be found using L as a class method, like C<< Text::CSV_PP->error_diag >>. The C<< $csv->error_diag >> method is automatically invoked upon error when the contractor was called with L|/auto_diag> set to C<1> or C<2>, or when L is in effect. When set to C<1>, this will cause a C with the error message, when set to C<2>, it will C. C<2012 - EOF> is excluded from L|/auto_diag> reports. Errors can be (individually) caught using the L callback. The errors as described below are available. I have tried to make the error itself explanatory enough, but more descriptions will be added. For most of these errors, the first three capitals describe the error category: =over 2 =item * INI Initialization error or option conflict. =item * ECR Carriage-Return related parse error. =item * EOF End-Of-File related parse error. =item * EIQ Parse error inside quotation. =item * EIF Parse error inside field. =item * ECB Combine error. =item * EHR HashRef parse related error. =back And below should be the complete list of error codes that can be returned: =over 2 =item * 1001 "INI - sep_char is equal to quote_char or escape_char" The L cannot be equal to L or to L, as this would invalidate all parsing rules. =item * 1002 "INI - allow_whitespace with escape_char or quote_char SP or TAB" Using the L|/allow_whitespace> attribute when either L|/quote_char> or L|/escape_char> is equal to C or C is too ambiguous to allow. =item * 1003 "INI - \r or \n in main attr not allowed" Using default L|/eol> characters in either L|/sep_char>, L|/quote_char>, or L|/escape_char> is not allowed. =item * 1004 "INI - callbacks should be undef or a hashref" The L|/Callbacks> attribute only allows one to be C or a hash reference. =item * 1005 "INI - EOL too long" The value passed for EOL is exceeding its maximum length (16). =item * 1006 "INI - SEP too long" The value passed for SEP is exceeding its maximum length (16). =item * 1007 "INI - QUOTE too long" The value passed for QUOTE is exceeding its maximum length (16). =item * 1008 "INI - SEP undefined" The value passed for SEP should be defined and not empty. =item * 1010 "INI - the header is empty" The header line parsed in the L is empty. =item * 1011 "INI - the header contains more than one valid separator" The header line parsed in the L contains more than one (unique) separator character out of the allowed set of separators. =item * 1012 "INI - the header contains an empty field" The header line parsed in the L contains an empty field. =item * 1013 "INI - the header contains nun-unique fields" The header line parsed in the L contains at least two identical fields. =item * 1014 "INI - header called on undefined stream" The header line cannot be parsed from an undefined source. =item * 1500 "PRM - Invalid/unsupported argument(s)" Function or method called with invalid argument(s) or parameter(s). =item * 1501 "PRM - The key attribute is passed as an unsupported type" The C attribute is of an unsupported type. =item * 1502 "PRM - The value attribute is passed without the key attribute" The C attribute is only allowed when a valid key is given. =item * 1503 "PRM - The value attribute is passed as an unsupported type" The C attribute is of an unsupported type. =item * 2010 "ECR - QUO char inside quotes followed by CR not part of EOL" When L|/eol> has been set to anything but the default, like C<"\r\t\n">, and the C<"\r"> is following the B (closing) L|/quote_char>, where the characters following the C<"\r"> do not make up the L|/eol> sequence, this is an error. =item * 2011 "ECR - Characters after end of quoted field" Sequences like C<1,foo,"bar"baz,22,1> are not allowed. C<"bar"> is a quoted field and after the closing double-quote, there should be either a new-line sequence or a separation character. =item * 2012 "EOF - End of data in parsing input stream" Self-explaining. End-of-file while inside parsing a stream. Can happen only when reading from streams with L, as using L is done on strings that are not required to have a trailing L|/eol>. =item * 2013 "INI - Specification error for fragments RFC7111" Invalid specification for URI L specification. =item * 2014 "ENF - Inconsistent number of fields" Inconsistent number of fields under strict parsing. =item * 2015 "ERW - Empty row" An empty row was not allowed. =item * 2016 "EOL - Inconsistent EOL" Inconsistent End-Of-Line detected under strict_eol parsing. =item * 2021 "EIQ - NL char inside quotes, binary off" Sequences like C<1,"foo\nbar",22,1> are allowed only when the binary option has been selected with the constructor. =item * 2022 "EIQ - CR char inside quotes, binary off" Sequences like C<1,"foo\rbar",22,1> are allowed only when the binary option has been selected with the constructor. =item * 2023 "EIQ - QUO character not allowed" Sequences like C<"foo "bar" baz",qu> and C<2023,",2008-04-05,"Foo, Bar",\n> will cause this error. =item * 2024 "EIQ - EOF cannot be escaped, not even inside quotes" The escape character is not allowed as last character in an input stream. =item * 2025 "EIQ - Loose unescaped escape" An escape character should escape only characters that need escaping. Allowing the escape for other characters is possible with the attribute L. =item * 2026 "EIQ - Binary character inside quoted field, binary off" Binary characters are not allowed by default. Exceptions are fields that contain valid UTF-8, that will automatically be upgraded if the content is valid UTF-8. Set L|/binary> to C<1> to accept binary data. =item * 2027 "EIQ - Quoted field not terminated" When parsing a field that started with a quotation character, the field is expected to be closed with a quotation character. When the parsed line is exhausted before the quote is found, that field is not terminated. =item * 2030 "EIF - NL char inside unquoted verbatim, binary off" =item * 2031 "EIF - CR char is first char of field, not part of EOL" =item * 2032 "EIF - CR char inside unquoted, not part of EOL" =item * 2034 "EIF - Loose unescaped quote" =item * 2035 "EIF - Escaped EOF in unquoted field" =item * 2036 "EIF - ESC error" =item * 2037 "EIF - Binary character in unquoted field, binary off" =item * 2110 "ECB - Binary character in Combine, binary off" =item * 2200 "EIO - print to IO failed. See errno" =item * 3001 "EHR - Unsupported syntax for column_names ()" =item * 3002 "EHR - getline_hr () called before column_names ()" =item * 3003 "EHR - bind_columns () and column_names () fields count mismatch" =item * 3004 "EHR - bind_columns () only accepts refs to scalars" =item * 3006 "EHR - bind_columns () did not pass enough refs for parsed fields" =item * 3007 "EHR - bind_columns needs refs to writable scalars" =item * 3008 "EHR - unexpected error in bound fields" =item * 3009 "EHR - print_hr () called before column_names ()" =item * 3010 "EHR - print_hr () called with invalid arguments" =back =head1 SEE ALSO L, L Older versions took many regexp from L =head1 AUTHOR Kenichi Ishigaki, Eishigaki[at]cpan.orgE Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE Text::CSV_XS was written by Ejoe[at]ispsoft.deE and maintained by Eh.m.brand[at]xs4all.nlE. Text::CSV was written by Ealan[at]mfgrtl.comE. =head1 COPYRIGHT AND LICENSE Copyright 2017- by Kenichi Ishigaki, Eishigaki[at]cpan.orgE Copyright 2005-2015 by Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE Most of the code and doc is directly taken from the pure perl part of Text::CSV_XS. Copyright (C) 2007-2016 H.Merijn Brand. All rights reserved. Copyright (C) 1998-2001 Jochen Wiedmann. All rights reserved. Copyright (C) 1997 Alan Citterman. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Text-CSV-2.06/lib/Text/CSV.pm0000644000175100017510000027177614761120412015667 0ustar ishigakiishigakipackage Text::CSV; use strict; use Exporter; use Carp (); use vars qw( $VERSION $DEBUG @ISA @EXPORT_OK %EXPORT_TAGS ); @ISA = qw( Exporter ); BEGIN { $VERSION = '2.06'; $DEBUG = 0; } # if use CSV_XS, requires version my $Module_XS = 'Text::CSV_XS'; my $Module_PP = 'Text::CSV_PP'; my $XS_Version = '1.60'; my $Is_Dynamic = 0; my @PublicMethods = qw/ version error_diag error_input known_attributes PV IV NV CSV_TYPE_PV CSV_TYPE_IV CSV_TYPE_NV CSV_FLAGS_IS_QUOTED CSV_FLAGS_IS_BINARY CSV_FLAGS_ERROR_IN_FIELD CSV_FLAGS_IS_MISSING /; %EXPORT_TAGS = ( CONSTANTS => [qw( CSV_FLAGS_IS_QUOTED CSV_FLAGS_IS_BINARY CSV_FLAGS_ERROR_IN_FIELD CSV_FLAGS_IS_MISSING CSV_TYPE_PV CSV_TYPE_IV CSV_TYPE_NV )], ); @EXPORT_OK = (qw(csv PV IV NV), @{$EXPORT_TAGS{CONSTANTS}}); # # Check the environment variable to decide worker module. unless ($Text::CSV::Worker) { $Text::CSV::DEBUG and Carp::carp("Check used worker module..."); if (exists $ENV{PERL_TEXT_CSV}) { if ($ENV{PERL_TEXT_CSV} eq '0' or $ENV{PERL_TEXT_CSV} eq 'Text::CSV_PP') { _load_pp() or Carp::croak $@; } elsif ($ENV{PERL_TEXT_CSV} eq '1' or $ENV{PERL_TEXT_CSV} =~ /Text::CSV_XS\s*,\s*Text::CSV_PP/) { _load_xs() or _load_pp() or Carp::croak $@; } elsif ($ENV{PERL_TEXT_CSV} eq '2' or $ENV{PERL_TEXT_CSV} eq 'Text::CSV_XS') { _load_xs() or Carp::croak $@; } else { Carp::croak "The value of environmental variable 'PERL_TEXT_CSV' is invalid."; } } else { _load_xs() or _load_pp() or Carp::croak $@; } } sub new { # normal mode my $proto = shift; my $class = ref($proto) || $proto; unless ($proto) { # for Text::CSV_XS/PP::new(0); return eval qq| $Text::CSV::Worker\::new( \$proto ) |; } #if (ref $_[0] and $_[0]->{module}) { # Carp::croak("Can't set 'module' in non dynamic mode."); #} if (my $obj = $Text::CSV::Worker->new(@_)) { $obj->{_MODULE} = $Text::CSV::Worker; bless $obj, $class; return $obj; } else { return; } } sub csv { if (@_ && ref $_[0] eq __PACKAGE__ or ref $_[0] eq __PACKAGE__->backend) { splice @_, 0, 0, "csv"; } my $backend = __PACKAGE__->backend; no strict 'refs'; &{"$backend\::csv"}(@_); } sub require_xs_version { $XS_Version; } sub module { my $proto = shift; return !ref($proto) ? $Text::CSV::Worker : ref($proto->{_MODULE}) ? ref($proto->{_MODULE}) : $proto->{_MODULE}; } *backend = *module; sub is_xs { return $_[0]->module eq $Module_XS; } sub is_pp { return $_[0]->module eq $Module_PP; } sub is_dynamic { $Is_Dynamic; } sub _load_xs { _load($Module_XS, $XS_Version) } sub _load_pp { _load($Module_PP) } sub _load { my ($module, $version) = @_; $version ||= ''; $Text::CSV::DEBUG and Carp::carp "Load $module."; eval qq| use $module $version |; return if $@; push @Text::CSV::ISA, $module; $Text::CSV::Worker = $module; local $^W; no strict qw(refs); for my $method (@PublicMethods) { *{"Text::CSV::$method"} = \&{"$module\::$method"}; } return 1; } 1; __END__ =pod =head1 NAME Text::CSV - comma-separated values manipulator (using XS or PurePerl) =head1 SYNOPSIS This section is taken from Text::CSV_XS. # Functional interface use Text::CSV qw( csv ); # Read whole file in memory my $aoa = csv (in => "data.csv"); # as array of array my $aoh = csv (in => "data.csv", headers => "auto"); # as array of hash # Write array of arrays as csv file csv (in => $aoa, out => "file.csv", sep_char => ";"); # Only show lines where "code" is odd csv (in => "data.csv", filter => { code => sub { $_ % 2 }}); # Object interface use Text::CSV; my @rows; # Read/parse CSV my $csv = Text::CSV->new ({ binary => 1, auto_diag => 1 }); open my $fh, "<:encoding(utf8)", "test.csv" or die "test.csv: $!"; while (my $row = $csv->getline ($fh)) { $row->[2] =~ m/pattern/ or next; # 3rd field should match push @rows, $row; } close $fh; # and write as CSV open $fh, ">:encoding(utf8)", "new.csv" or die "new.csv: $!"; $csv->say ($fh, $_) for @rows; close $fh or die "new.csv: $!"; =head1 DESCRIPTION Text::CSV is a thin wrapper for L-compatible modules now. All the backend modules provide facilities for the composition and decomposition of comma-separated values. Text::CSV uses Text::CSV_XS by default, and when Text::CSV_XS is not available, falls back on L, which is bundled in the same distribution as this module. =head1 CHOOSING BACKEND This module respects an environmental variable called C when it decides a backend module to use. If this environmental variable is not set, it tries to load Text::CSV_XS, and if Text::CSV_XS is not available, falls back on Text::CSV_PP; If you always don't want it to fall back on Text::CSV_PP, set the variable like this (C may be C, C and the likes, depending on your environment): > export PERL_TEXT_CSV=Text::CSV_XS If you prefer Text::CSV_XS to Text::CSV_PP (default), then: > export PERL_TEXT_CSV=Text::CSV_XS,Text::CSV_PP You may also want to set this variable at the top of your test files, in order not to be bothered with incompatibilities between backends (you need to wrap this in C, and set before actually C-ing Text::CSV module, as it decides its backend as soon as it's loaded): BEGIN { $ENV{PERL_TEXT_CSV}='Text::CSV_PP'; } use Text::CSV; =head1 NOTES This section is also taken from Text::CSV_XS. =head2 Embedded newlines B: The default behavior is to accept only ASCII characters in the range from C<0x20> (space) to C<0x7E> (tilde). This means that the fields can not contain newlines. If your data contains newlines embedded in fields, or characters above C<0x7E> (tilde), or binary data, you B> set C<< binary => 1 >> in the call to L. To cover the widest range of parsing options, you will always want to set binary. But you still have the problem that you have to pass a correct line to the L method, which is more complicated from the usual point of usage: my $csv = Text::CSV->new ({ binary => 1, eol => $/ }); while (<>) { # WRONG! $csv->parse ($_); my @fields = $csv->fields (); } this will break, as the C might read broken lines: it does not care about the quoting. If you need to support embedded newlines, the way to go is to B pass L|/eol> in the parser (it accepts C<\n>, C<\r>, B C<\r\n> by default) and then my $csv = Text::CSV->new ({ binary => 1 }); open my $fh, "<", $file or die "$file: $!"; while (my $row = $csv->getline ($fh)) { my @fields = @$row; } The old(er) way of using global file handles is still supported while (my $row = $csv->getline (*ARGV)) { ... } =head2 Unicode Unicode is only tested to work with perl-5.8.2 and up. See also L. The simplest way to ensure the correct encoding is used for in- and output is by either setting layers on the filehandles, or setting the L argument for L. open my $fh, "<:encoding(UTF-8)", "in.csv" or die "in.csv: $!"; or my $aoa = csv (in => "in.csv", encoding => "UTF-8"); open my $fh, ">:encoding(UTF-8)", "out.csv" or die "out.csv: $!"; or csv (in => $aoa, out => "out.csv", encoding => "UTF-8"); On parsing (both for L and L), if the source is marked being UTF8, then all fields that are marked binary will also be marked UTF8. On combining (L and L): if any of the combining fields was marked UTF8, the resulting string will be marked as UTF8. Note however that all fields I the first field marked UTF8 and contained 8-bit characters that were not upgraded to UTF8, these will be C in the resulting string too, possibly causing unexpected errors. If you pass data of different encoding, or you don't know if there is different encoding, force it to be upgraded before you pass them on: $csv->print ($fh, [ map { utf8::upgrade (my $x = $_); $x } @data ]); For complete control over encoding, please use L: use Text::CSV::Encoded; my $csv = Text::CSV::Encoded->new ({ encoding_in => "iso-8859-1", # the encoding comes into Perl encoding_out => "cp1252", # the encoding comes out of Perl }); $csv = Text::CSV::Encoded->new ({ encoding => "utf8" }); # combine () and print () accept *literally* utf8 encoded data # parse () and getline () return *literally* utf8 encoded data $csv = Text::CSV::Encoded->new ({ encoding => undef }); # default # combine () and print () accept UTF8 marked data # parse () and getline () return UTF8 marked data =head2 BOM BOM (or Byte Order Mark) handling is available only inside the L method. This method supports the following encodings: C, C, C, C, C, C, C, C, C, and C. See L. If a file has a BOM, the easiest way to deal with that is my $aoh = csv (in => $file, detect_bom => 1); All records will be encoded based on the detected BOM. This implies a call to the L method, which defaults to also set the L. So this is B the same as my $aoh = csv (in => $file, headers => "auto"); which only reads the first record to set L but ignores any meaning of possible present BOM. =head1 METHODS This section is also taken from Text::CSV_XS. =head2 version (Class method) Returns the current module version. =head2 new (Class method) Returns a new instance of class Text::CSV. The attributes are described by the (optional) hash ref C<\%attr>. my $csv = Text::CSV->new ({ attributes ... }); The following attributes are available: =head3 eol my $csv = Text::CSV->new ({ eol => $/ }); $csv->eol (undef); my $eol = $csv->eol; The end-of-line string to add to rows for L or the record separator for L. When not passed in a B instance, the default behavior is to accept C<\n>, C<\r>, and C<\r\n>, so it is probably safer to not specify C at all. Passing C or the empty string behave the same. When not passed in a B instance, records are not terminated at all, so it is probably wise to pass something you expect. A safe choice for C on output is either C<$/> or C<\r\n>. Common values for C are C<"\012"> (C<\n> or Line Feed), C<"\015\012"> (C<\r\n> or Carriage Return, Line Feed), and C<"\015"> (C<\r> or Carriage Return). The L|/eol> attribute cannot exceed 7 (ASCII) characters. If both C<$/> and L|/eol> equal C<"\015">, parsing lines that end on only a Carriage Return without Line Feed, will be Ld correct. =head3 eol_type my $eol = $csv->eol_type; This read-only method returns the internal state of what is considered the valid EOL for parsing. =head3 sep_char my $csv = Text::CSV->new ({ sep_char => ";" }); $csv->sep_char (";"); my $c = $csv->sep_char; The char used to separate fields, by default a comma. (C<,>). Limited to a single-byte character, usually in the range from C<0x20> (space) to C<0x7E> (tilde). When longer sequences are required, use L|/sep>. The separation character can not be equal to the quote character or to the escape character. =head3 sep my $csv = Text::CSV->new ({ sep => "\N{FULLWIDTH COMMA}" }); $csv->sep (";"); my $sep = $csv->sep; The chars used to separate fields, by default undefined. Limited to 8 bytes. When set, overrules L|/sep_char>. If its length is one byte it acts as an alias to L|/sep_char>. =head3 quote_char my $csv = Text::CSV->new ({ quote_char => "'" }); $csv->quote_char (undef); my $c = $csv->quote_char; The character to quote fields containing blanks or binary data, by default the double quote character (C<">). A value of undef suppresses quote chars (for simple cases only). Limited to a single-byte character, usually in the range from C<0x20> (space) to C<0x7E> (tilde). When longer sequences are required, use L|/quote>. C can not be equal to L|/sep_char>. =head3 quote my $csv = Text::CSV->new ({ quote => "\N{FULLWIDTH QUOTATION MARK}" }); $csv->quote ("'"); my $quote = $csv->quote; The chars used to quote fields, by default undefined. Limited to 8 bytes. When set, overrules L|/quote_char>. If its length is one byte it acts as an alias to L|/quote_char>. This method does not support C. Use L|/quote_char> to disable quotation. =head3 escape_char my $csv = Text::CSV->new ({ escape_char => "\\" }); $csv->escape_char (":"); my $c = $csv->escape_char; The character to escape certain characters inside quoted fields. This is limited to a single-byte character, usually in the range from C<0x20> (space) to C<0x7E> (tilde). The C defaults to being the double-quote mark (C<">). In other words the same as the default L|/quote_char>. This means that doubling the quote mark in a field escapes it: "foo","bar","Escape ""quote mark"" with two ""quote marks""","baz" If you change the L|/quote_char> without changing the C, the C will still be the double-quote (C<">). If instead you want to escape the L|/quote_char> by doubling it you will need to also change the C to be the same as what you have changed the L|/quote_char> to. Setting C to C or C<""> will completely disable escapes and is greatly discouraged. This will also disable C. The escape character can not be equal to the separation character. =head3 binary my $csv = Text::CSV->new ({ binary => 1 }); $csv->binary (0); my $f = $csv->binary; If this attribute is C<1>, you may use binary characters in quoted fields, including line feeds, carriage returns and C bytes. (The latter could be escaped as C<"0>.) By default this feature is off. If a string is marked UTF8, C will be turned on automatically when binary characters other than C and C are encountered. Note that a simple string like C<"\x{00a0}"> might still be binary, but not marked UTF8, so setting C<< { binary => 1 } >> is still a wise option. =head3 strict my $csv = Text::CSV->new ({ strict => 1 }); $csv->strict (0); my $f = $csv->strict; If this attribute is set to C<1>, any row that parses to a different number of fields than the previous row will cause the parser to throw error 2014. Empty rows or rows that result in no fields (like comment lines) are exempt from these checks. =head3 strict_eol my $csv = Text::CSV->new ({ strict_eol => 1 }); $csv->strict_eol (0); my $f = $csv->strict_eol; If this attribute is set to C<0>, no EOL consistency checks are done. If this attribute is set to C<1>, any row that parses with a EOL other than the EOL from the first row will cause a warning. The error will be ignored and parsing continues. This warning is only thrown once. Note that in data with various different line endings, C<\r\r> will still throw an error that cannot be ignored. If this attribute is set to C<2> or higher, any row that parses with a EOL other than the EOL from the first row will cause error C<2016> to be thrown. The line being parsed to this error might not be stored in the result. =head3 skip_empty_rows my $csv = Text::CSV->new ({ skip_empty_rows => 1 }); $csv->skip_empty_rows ("eof"); my $f = $csv->skip_empty_rows; This attribute defines the behavior for empty rows: an L immediately following the start of line. Default behavior is to return one single empty field. This attribute is only used in parsing. This attribute is ineffective when using L and L. Possible values for this attribute are =over 2 =item 0 | undef my $csv = Text::CSV->new ({ skip_empty_rows => 0 }); $csv->skip_empty_rows (undef); No special action is taken. The result will be one single empty field. =item 1 | "skip" my $csv = Text::CSV->new ({ skip_empty_rows => 1 }); $csv->skip_empty_rows ("skip"); The row will be skipped. =item 2 | "eof" | "stop" my $csv = Text::CSV->new ({ skip_empty_rows => 2 }); $csv->skip_empty_rows ("eof"); The parsing will stop as if an L was detected. =item 3 | "die" my $csv = Text::CSV->new ({ skip_empty_rows => 3 }); $csv->skip_empty_rows ("die"); The parsing will stop. The internal error code will be set to 2015 and the parser will C. =item 4 | "croak" my $csv = Text::CSV->new ({ skip_empty_rows => 4 }); $csv->skip_empty_rows ("croak"); The parsing will stop. The internal error code will be set to 2015 and the parser will C. =item 5 | "error" my $csv = Text::CSV->new ({ skip_empty_rows => 5 }); $csv->skip_empty_rows ("error"); The parsing will fail. The internal error code will be set to 2015. =item callback my $csv = Text::CSV->new ({ skip_empty_rows => sub { [] } }); $csv->skip_empty_rows (sub { [ 42, $., undef, "empty" ] }); The callback is invoked and its result used instead. If you want the parse to stop after the callback, make sure to return a false value. The returned value from the callback should be an array-ref. Any other type will cause the parse to stop, so these are equivalent in behavior: csv (in => $fh, skip_empty_rows => "stop"); csv (in => $fh. skip_empty_rows => sub { 0; }); =back Without arguments, the current value is returned: C<0>, C<1>, C, C, C or the callback. =head3 formula_handling Alias for L =head3 formula my $csv = Text::CSV->new ({ formula => "none" }); $csv->formula ("none"); my $f = $csv->formula; This defines the behavior of fields containing I. As formulas are considered dangerous in spreadsheets, this attribute can define an optional action to be taken if a field starts with an equal sign (C<=>). For purpose of code-readability, this can also be written as my $csv = Text::CSV->new ({ formula_handling => "none" }); $csv->formula_handling ("none"); my $f = $csv->formula_handling; Possible values for this attribute are =over 2 =item none Take no specific action. This is the default. $csv->formula ("none"); =item die Cause the process to C whenever a leading C<=> is encountered. $csv->formula ("die"); =item croak Cause the process to C whenever a leading C<=> is encountered. (See L) $csv->formula ("croak"); =item diag Report position and content of the field whenever a leading C<=> is found. The value of the field is unchanged. $csv->formula ("diag"); =item empty Replace the content of fields that start with a C<=> with the empty string. $csv->formula ("empty"); $csv->formula (""); =item undef Replace the content of fields that start with a C<=> with C. $csv->formula ("undef"); $csv->formula (undef); =item a callback Modify the content of fields that start with a C<=> with the return-value of the callback. The original content of the field is available inside the callback as C<$_>; # Replace all formula's with 42 $csv->formula (sub { 42; }); # same as $csv->formula ("empty") but slower $csv->formula (sub { "" }); # Allow =4+12 $csv->formula (sub { s/^=(\d+\+\d+)$/$1/eer }); # Allow more complex calculations $csv->formula (sub { eval { s{^=([-+*/0-9()]+)$}{$1}ee }; $_ }); =back All other values will give a warning and then fallback to C. =head3 decode_utf8 my $csv = Text::CSV->new ({ decode_utf8 => 1 }); $csv->decode_utf8 (0); my $f = $csv->decode_utf8; This attributes defaults to TRUE. While I, fields that are valid UTF-8, are automatically set to be UTF-8, so that $csv->parse ("\xC4\xA8\n"); results in PV("\304\250"\0) [UTF8 "\x{128}"] Sometimes it might not be a desired action. To prevent those upgrades, set this attribute to false, and the result will be PV("\304\250"\0) =head3 auto_diag my $csv = Text::CSV->new ({ auto_diag => 1 }); $csv->auto_diag (2); my $l = $csv->auto_diag; Set this attribute to a number between C<1> and C<9> causes L to be automatically called in void context upon errors. In case of error C<2012 - EOF>, this call will be void. If C is set to a numeric value greater than C<1>, it will C on errors instead of C. If set to anything unrecognized, it will be silently ignored. Future extensions to this feature will include more reliable auto-detection of C being active in the scope of which the error occurred which will increment the value of C with C<1> the moment the error is detected. =head3 diag_verbose my $csv = Text::CSV->new ({ diag_verbose => 1 }); $csv->diag_verbose (2); my $l = $csv->diag_verbose; Set the verbosity of the output triggered by C. Currently only adds the current input-record-number (if known) to the diagnostic output with an indication of the position of the error. =head3 blank_is_undef my $csv = Text::CSV->new ({ blank_is_undef => 1 }); $csv->blank_is_undef (0); my $f = $csv->blank_is_undef; Under normal circumstances, C data makes no distinction between quoted- and unquoted empty fields. These both end up in an empty string field once read, thus 1,"",," ",2 is read as ("1", "", "", " ", "2") When I C files with either L|/always_quote> or L|/quote_empty> set, the unquoted I field is the result of an undefined value. To enable this distinction when I C data, the C attribute will cause unquoted empty fields to be set to C, causing the above to be parsed as ("1", "", undef, " ", "2") Note that this is specifically important when loading C fields into a database that allows C values, as the perl equivalent for C is C in L land. =head3 empty_is_undef my $csv = Text::CSV->new ({ empty_is_undef => 1 }); $csv->empty_is_undef (0); my $f = $csv->empty_is_undef; Going one step further than L|/blank_is_undef>, this attribute converts all empty fields to C, so 1,"",," ",2 is read as (1, undef, undef, " ", 2) Note that this affects only fields that are originally empty, not fields that are empty after stripping allowed whitespace. YMMV. =head3 allow_whitespace my $csv = Text::CSV->new ({ allow_whitespace => 1 }); $csv->allow_whitespace (0); my $f = $csv->allow_whitespace; When this option is set to true, the whitespace (C's and C's) surrounding the separation character is removed when parsing. If either C or C is one of the three characters L|/sep_char>, L|/quote_char>, or L|/escape_char> it will not be considered whitespace. Now lines like: 1 , "foo" , bar , 3 , zapp are parsed as valid C, even though it violates the C specs. Note that B whitespace is stripped from both start and end of each field. That would make it I than a I to enable parsing bad C lines, as 1, 2.0, 3, ape , monkey will now be parsed as ("1", "2.0", "3", "ape", "monkey") even if the original line was perfectly acceptable C. =head3 allow_loose_quotes my $csv = Text::CSV->new ({ allow_loose_quotes => 1 }); $csv->allow_loose_quotes (0); my $f = $csv->allow_loose_quotes; By default, parsing unquoted fields containing L|/quote_char> characters like 1,foo "bar" baz,42 would result in parse error 2034. Though it is still bad practice to allow this format, we cannot help the fact that some vendors make their applications spit out lines styled this way. If there is B bad C data, like 1,"foo "bar" baz",42 or 1,""foo bar baz"",42 there is a way to get this data-line parsed and leave the quotes inside the quoted field as-is. This can be achieved by setting C B making sure that the L|/escape_char> is I equal to L|/quote_char>. =head3 allow_loose_escapes my $csv = Text::CSV->new ({ allow_loose_escapes => 1 }); $csv->allow_loose_escapes (0); my $f = $csv->allow_loose_escapes; Parsing fields that have L|/escape_char> characters that escape characters that do not need to be escaped, like: my $csv = Text::CSV->new ({ escape_char => "\\" }); $csv->parse (qq{1,"my bar\'s",baz,42}); would result in parse error 2025. Though it is bad practice to allow this format, this attribute enables you to treat all escape character sequences equal. =head3 allow_unquoted_escape my $csv = Text::CSV->new ({ allow_unquoted_escape => 1 }); $csv->allow_unquoted_escape (0); my $f = $csv->allow_unquoted_escape; A backward compatibility issue where L|/escape_char> differs from L|/quote_char> prevents L|/escape_char> to be in the first position of a field. If L|/quote_char> is equal to the default C<"> and L|/escape_char> is set to C<\>, this would be illegal: 1,\0,2 Setting this attribute to C<1> might help to overcome issues with backward compatibility and allow this style. =head3 always_quote my $csv = Text::CSV->new ({ always_quote => 1 }); $csv->always_quote (0); my $f = $csv->always_quote; By default the generated fields are quoted only if they I to be. For example, if they contain the separator character. If you set this attribute to C<1> then I defined fields will be quoted. (C fields are not quoted, see L). This makes it quite often easier to handle exported data in external applications. =head3 quote_space my $csv = Text::CSV->new ({ quote_space => 1 }); $csv->quote_space (0); my $f = $csv->quote_space; By default, a space in a field would trigger quotation. As no rule exists this to be forced in C, nor any for the opposite, the default is true for safety. You can exclude the space from this trigger by setting this attribute to 0. =head3 quote_empty my $csv = Text::CSV->new ({ quote_empty => 1 }); $csv->quote_empty (0); my $f = $csv->quote_empty; By default the generated fields are quoted only if they I to be. An empty (defined) field does not need quotation. If you set this attribute to C<1> then I defined fields will be quoted. (C fields are not quoted, see L). See also L|/always_quote>. =head3 quote_binary my $csv = Text::CSV->new ({ quote_binary => 1 }); $csv->quote_binary (0); my $f = $csv->quote_binary; By default, all "unsafe" bytes inside a string cause the combined field to be quoted. By setting this attribute to C<0>, you can disable that trigger for bytes C<< >= 0x7F >>. =head3 escape_null my $csv = Text::CSV->new ({ escape_null => 1 }); $csv->escape_null (0); my $f = $csv->escape_null; By default, a C byte in a field would be escaped. This option enables you to treat the C byte as a simple binary character in binary mode (the C<< { binary => 1 } >> is set). The default is true. You can prevent C escapes by setting this attribute to C<0>. When the C attribute is set to undefined, this attribute will be set to false. The default setting will encode "=\x00=" as "="0=" With C set, this will result in "=\x00=" The default when using the C function is C. For backward compatibility reasons, the deprecated old name C is still recognized. =head3 keep_meta_info my $csv = Text::CSV->new ({ keep_meta_info => 1 }); $csv->keep_meta_info (0); my $f = $csv->keep_meta_info; By default, the parsing of input records is as simple and fast as possible. However, some parsing information - like quotation of the original field - is lost in that process. Setting this flag to true enables retrieving that information after parsing with the methods L, L, and L described below. Default is false for performance. If you set this attribute to a value greater than 9, then you can control output quotation style like it was used in the input of the the last parsed record (unless quotation was added because of other reasons). my $csv = Text::CSV->new ({ binary => 1, keep_meta_info => 1, quote_space => 0, }); my $row = $csv->parse (q{1,,"", ," ",f,"g","h""h",help,"help"}); $csv->print (*STDOUT, \@row); # 1,,, , ,f,g,"h""h",help,help $csv->keep_meta_info (11); $csv->print (*STDOUT, \@row); # 1,,"", ," ",f,"g","h""h",help,"help" =head3 undef_str my $csv = Text::CSV->new ({ undef_str => "\\N" }); $csv->undef_str (undef); my $s = $csv->undef_str; This attribute optionally defines the output of undefined fields. The value passed is not changed at all, so if it needs quotation, the quotation needs to be included in the value of the attribute. Use with caution, as passing a value like C<",",,,,"""> will for sure mess up your output. The default for this attribute is C, meaning no special treatment. This attribute is useful when exporting CSV data to be imported in custom loaders, like for MySQL, that recognize special sequences for C data. This attribute has no meaning when parsing CSV data. =head3 comment_str my $csv = Text::CSV->new ({ comment_str => "#" }); $csv->comment_str (undef); my $s = $csv->comment_str; This attribute optionally defines a string to be recognized as comment. If this attribute is defined, all lines starting with this sequence will not be parsed as CSV but skipped as comment. This attribute has no meaning when generating CSV. Comment strings that start with any of the special characters/sequences are not supported (so it cannot start with any of L, L, L, L, L, or L). For convenience, C is an alias for C. =head3 verbatim my $csv = Text::CSV->new ({ verbatim => 1 }); $csv->verbatim (0); my $f = $csv->verbatim; This is a quite controversial attribute to set, but makes some hard things possible. The rationale behind this attribute is to tell the parser that the normally special characters newline (C) and Carriage Return (C) will not be special when this flag is set, and be dealt with as being ordinary binary characters. This will ease working with data with embedded newlines. When C is used with L, L auto-C's every line. Imagine a file format like M^^Hans^Janssen^Klas 2\n2A^Ja^11-06-2007#\r\n where, the line ending is a very specific C<"#\r\n">, and the sep_char is a C<^> (caret). None of the fields is quoted, but embedded binary data is likely to be present. With the specific line ending, this should not be too hard to detect. By default, Text::CSV' parse function is instructed to only know about C<"\n"> and C<"\r"> to be legal line endings, and so has to deal with the embedded newline as a real C, so it can scan the next line if binary is true, and the newline is inside a quoted field. With this option, we tell L to parse the line as if C<"\n"> is just nothing more than a binary character. For L this means that the parser has no more idea about line ending and L Cs line endings on reading. =head3 types A set of column types; the attribute is immediately passed to the L method. =head3 callbacks See the L section below. =head3 accessors To sum it up, $csv = Text::CSV->new (); is equivalent to $csv = Text::CSV->new ({ eol => undef, # \r, \n, or \r\n sep_char => ',', sep => undef, quote_char => '"', quote => undef, escape_char => '"', binary => 0, decode_utf8 => 1, auto_diag => 0, diag_verbose => 0, blank_is_undef => 0, empty_is_undef => 0, allow_whitespace => 0, allow_loose_quotes => 0, allow_loose_escapes => 0, allow_unquoted_escape => 0, always_quote => 0, quote_empty => 0, quote_space => 1, escape_null => 1, quote_binary => 1, keep_meta_info => 0, strict => 0, skip_empty_rows => 0, formula => 0, verbatim => 0, undef_str => undef, comment_str => undef, types => undef, callbacks => undef, }); For all of the above mentioned flags, an accessor method is available where you can inquire the current value, or change the value my $quote = $csv->quote_char; $csv->binary (1); It is not wise to change these settings halfway through writing C data to a stream. If however you want to create a new stream using the available C object, there is no harm in changing them. If the L constructor call fails, it returns C, and makes the fail reason available through the L method. $csv = Text::CSV->new ({ ecs_char => 1 }) or die "".Text::CSV->error_diag (); L will return a string like "INI - Unknown attribute 'ecs_char'" =head2 known_attributes @attr = Text::CSV->known_attributes; @attr = Text::CSV::known_attributes; @attr = $csv->known_attributes; This method will return an ordered list of all the supported attributes as described above. This can be useful for knowing what attributes are valid in classes that use or extend Text::CSV. =head2 print $status = $csv->print ($fh, $colref); Similar to L + L + L, but much more efficient. It expects an array ref as input (not an array!) and the resulting string is not really created, but immediately written to the C<$fh> object, typically an IO handle or any other object that offers a L method. For performance reasons C does not create a result string, so all L, L, L, and L methods will return undefined information after executing this method. If C<$colref> is C (explicit, not through a variable argument) and L was used to specify fields to be printed, it is possible to make performance improvements, as otherwise data would have to be copied as arguments to the method call: $csv->bind_columns (\($foo, $bar)); $status = $csv->print ($fh, undef); A short benchmark my @data = ("aa" .. "zz"); $csv->bind_columns (\(@data)); $csv->print ($fh, [ @data ]); # 11800 recs/sec $csv->print ($fh, \@data ); # 57600 recs/sec $csv->print ($fh, undef ); # 48500 recs/sec =head2 say $status = $csv->say ($fh, $colref); Like L|/print>, but L|/eol> defaults to C<$\>. =head2 print_hr $csv->print_hr ($fh, $ref); Provides an easy way to print a C<$ref> (as fetched with L) provided the column names are set with L. It is just a wrapper method with basic parameter checks over $csv->print ($fh, [ map { $ref->{$_} } $csv->column_names ]); =head2 combine $status = $csv->combine (@fields); This method constructs a C record from C<@fields>, returning success or failure. Failure can result from lack of arguments or an argument that contains an invalid character. Upon success, L can be called to retrieve the resultant C string. Upon failure, the value returned by L is undefined and L could be called to retrieve the invalid argument. =head2 string $line = $csv->string (); This method returns the input to L or the resultant C string of L, whichever was called more recently. =head2 getline $colref = $csv->getline ($fh); This is the counterpart to L, as L is the counterpart to L: it parses a row from the C<$fh> handle using the L method associated with C<$fh> and parses this row into an array ref. This array ref is returned by the function or C for failure. When C<$fh> does not support C, you are likely to hit errors. When fields are bound with L the return value is a reference to an empty list. The L, L, and L methods are meaningless again. =head2 getline_all $arrayref = $csv->getline_all ($fh); $arrayref = $csv->getline_all ($fh, $offset); $arrayref = $csv->getline_all ($fh, $offset, $length); This will return a reference to a list of L results. In this call, C is disabled. If C<$offset> is negative, as with C, only the last C records of C<$fh> are taken into consideration. Parameters C<$offset> and C<$length> are expected to be integers. Non-integer values are interpreted as integer without check. Given a CSV file with 10 lines: lines call ----- --------------------------------------------------------- 0..9 $csv->getline_all ($fh) # all 0..9 $csv->getline_all ($fh, 0) # all 8..9 $csv->getline_all ($fh, 8) # start at 8 - $csv->getline_all ($fh, 0, 0) # start at 0 first 0 rows 0..4 $csv->getline_all ($fh, 0, 5) # start at 0 first 5 rows 4..5 $csv->getline_all ($fh, 4, 2) # start at 4 first 2 rows 8..9 $csv->getline_all ($fh, -2) # last 2 rows 6..7 $csv->getline_all ($fh, -4, 2) # first 2 of last 4 rows =head2 getline_hr The L and L methods work together to allow you to have rows returned as hashrefs. You must call L first to declare your column names. $csv->column_names (qw( code name price description )); $hr = $csv->getline_hr ($fh); print "Price for $hr->{name} is $hr->{price} EUR\n"; L will croak if called before L. Note that L creates a hashref for every row and will be much slower than the combined use of L and L but still offering the same easy to use hashref inside the loop: my @cols = @{$csv->getline ($fh)}; $csv->column_names (@cols); while (my $row = $csv->getline_hr ($fh)) { print $row->{price}; } Could easily be rewritten to the much faster: my @cols = @{$csv->getline ($fh)}; my $row = {}; $csv->bind_columns (\@{$row}{@cols}); while ($csv->getline ($fh)) { print $row->{price}; } Your mileage may vary for the size of the data and the number of rows. With perl-5.14.2 the comparison for a 100_000 line file with 14 columns: Rate hashrefs getlines hashrefs 1.00/s -- -76% getlines 4.15/s 313% -- =head2 getline_hr_all $arrayref = $csv->getline_hr_all ($fh); $arrayref = $csv->getline_hr_all ($fh, $offset); $arrayref = $csv->getline_hr_all ($fh, $offset, $length); This will return a reference to a list of L results. In this call, L|/keep_meta_info> is disabled. =head2 parse $status = $csv->parse ($line); This method decomposes a C string into fields, returning success or failure. Failure can result from a lack of argument or the given C string is improperly formatted. Upon success, L can be called to retrieve the decomposed fields. Upon failure calling L will return undefined data and L can be called to retrieve the invalid argument. You may use the L method for setting column types. See L' description below. The C<$line> argument is supposed to be a simple scalar. Everything else is supposed to croak and set error 1500. =head2 fragment This function tries to implement RFC7111 (URI Fragment Identifiers for the text/csv Media Type) - https://datatracker.ietf.org/doc/html/rfc7111 my $AoA = $csv->fragment ($fh, $spec); In specifications, C<*> is used to specify the I item, a dash (C<->) to indicate a range. All indices are C<1>-based: the first row or column has index C<1>. Selections can be combined with the semi-colon (C<;>). When using this method in combination with L, the returned reference will point to a list of hashes instead of a list of lists. A disjointed cell-based combined selection might return rows with different number of columns making the use of hashes unpredictable. $csv->column_names ("Name", "Age"); my $AoH = $csv->fragment ($fh, "col=3;8"); If the L callback is active, it is also called on every line parsed and skipped before the fragment. =over 2 =item row row=4 row=5-7 row=6-* row=1-2;4;6-* =item col col=2 col=1-3 col=4-* col=1-2;4;7-* =item cell In cell-based selection, the comma (C<,>) is used to pair row and column cell=4,1 The range operator (C<->) using Cs can be used to define top-left and bottom-right C location cell=3,1-4,6 The C<*> is only allowed in the second part of a pair cell=3,2-*,2 # row 3 till end, only column 2 cell=3,2-3,* # column 2 till end, only row 3 cell=3,2-*,* # strip row 1 and 2, and column 1 Cells and cell ranges may be combined with C<;>, possibly resulting in rows with different numbers of columns cell=1,1-2,2;3,3-4,4;1,4;4,1 Disjointed selections will only return selected cells. The cells that are not specified will not be included in the returned set, not even as C. As an example given a C like 11,12,13,...19 21,22,...28,29 : : 91,...97,98,99 with C will return: 11,12,14 21,22 33,34 41,43,44 Overlapping cell-specs will return those cells only once, So C will return: 11,12,13 21,22,23,24 31,32,33,34 42,43,44 =back L does B allow different types of specs to be combined (either C I C I C). Passing an invalid fragment specification will croak and set error 2013. =head2 column_names Set the "keys" that will be used in the L calls. If no keys (column names) are passed, it will return the current setting as a list. L accepts a list of scalars (the column names) or a single array_ref, so you can pass the return value from L too: $csv->column_names ($csv->getline ($fh)); L does B checking on duplicates at all, which might lead to unexpected results. Undefined entries will be replaced with the string C<"\cAUNDEF\cA">, so $csv->column_names (undef, "", "name", "name"); $hr = $csv->getline_hr ($fh); will set C<< $hr->{"\cAUNDEF\cA"} >> to the 1st field, C<< $hr->{""} >> to the 2nd field, and C<< $hr->{name} >> to the 4th field, discarding the 3rd field. L croaks on invalid arguments. =head2 header This method does NOT work in perl-5.6.x Parse the CSV header and set L|/sep>, column_names and encoding. my @hdr = $csv->header ($fh); $csv->header ($fh, { sep_set => [ ";", ",", "|", "\t" ] }); $csv->header ($fh, { detect_bom => 1, munge_column_names => "lc" }); The first argument should be a file handle. This method resets some object properties, as it is supposed to be invoked only once per file or stream. It will leave attributes C and C alone if setting column names is disabled. Reading headers on previously process objects might fail on perl-5.8.0 and older. Assuming that the file opened for parsing has a header, and the header does not contain problematic characters like embedded newlines, read the first line from the open handle then auto-detect whether the header separates the column names with a character from the allowed separator list. If any of the allowed separators matches, and none of the I allowed separators match, set L|/sep> to that separator for the current CSV instance and use it to parse the first line, map those to lowercase, and use that to set the instance L: my $csv = Text::CSV->new ({ binary => 1, auto_diag => 1 }); open my $fh, "<", "file.csv"; binmode $fh; # for Windows $csv->header ($fh); while (my $row = $csv->getline_hr ($fh)) { ... } If the header is empty, contains more than one unique separator out of the allowed set, contains empty fields, or contains identical fields (after folding), it will croak with error 1010, 1011, 1012, or 1013 respectively. If the header contains embedded newlines or is not valid CSV in any other way, this method will croak and leave the parse error untouched. A successful call to C
will always set the L|/sep> of the C<$csv> object. This behavior can not be disabled. =head3 return value On error this method will croak. In list context, the headers will be returned whether they are used to set L or not. In scalar context, the instance itself is returned. B: the values as found in the header will effectively be B if C is false. =head3 Options =over 2 =item sep_set $csv->header ($fh, { sep_set => [ ";", ",", "|", "\t" ] }); The list of legal separators defaults to C<[ ";", "," ]> and can be changed by this option. As this is probably the most often used option, it can be passed on its own as an unnamed argument: $csv->header ($fh, [ ";", ",", "|", "\t", "::", "\x{2063}" ]); Multi-byte sequences are allowed, both multi-character and Unicode. See L|/sep>. =item detect_bom $csv->header ($fh, { detect_bom => 1 }); The default behavior is to detect if the header line starts with a BOM. If the header has a BOM, use that to set the encoding of C<$fh>. This default behavior can be disabled by passing a false value to C. Supported encodings from BOM are: UTF-8, UTF-16BE, UTF-16LE, UTF-32BE, and UTF-32LE. BOM also supports UTF-1, UTF-EBCDIC, SCSU, BOCU-1, and GB-18030 but L does not (yet). UTF-7 is not supported. If a supported BOM was detected as start of the stream, it is stored in the object attribute C. my $enc = $csv->{ENCODING}; The encoding is used with C on C<$fh>. If the handle was opened in a (correct) encoding, this method will B alter the encoding, as it checks the leading B of the first line. In case the stream starts with a decoded BOM (C), C<{ENCODING}> will be C<""> (empty) instead of the default C. =item munge_column_names This option offers the means to modify the column names into something that is most useful to the application. The default is to map all column names to lower case. $csv->header ($fh, { munge_column_names => "lc" }); The following values are available: lc - lower case uc - upper case db - valid DB field names none - do not change \%hash - supply a mapping \&cb - supply a callback =over 2 =item Lower case $csv->header ($fh, { munge_column_names => "lc" }); The header is changed to all lower-case $_ = lc; =item Upper case $csv->header ($fh, { munge_column_names => "uc" }); The header is changed to all upper-case $_ = uc; =item Literal $csv->header ($fh, { munge_column_names => "none" }); =item Hash $csv->header ($fh, { munge_column_names => { foo => "sombrero" }); if a value does not exist, the original value is used unchanged =item Database $csv->header ($fh, { munge_column_names => "db" }); =over 2 =item - lower-case =item - all sequences of non-word characters are replaced with an underscore =item - all leading underscores are removed =back $_ = lc (s/\W+/_/gr =~ s/^_+//r); =item Callback $csv->header ($fh, { munge_column_names => sub { fc } }); $csv->header ($fh, { munge_column_names => sub { "column_".$col++ } }); $csv->header ($fh, { munge_column_names => sub { lc (s/\W+/_/gr) } }); As this callback is called in a C, you can use C<$_> directly. =back =item set_column_names $csv->header ($fh, { set_column_names => 1 }); The default is to set the instances column names using L if the method is successful, so subsequent calls to L can return a hash. Disable setting the header can be forced by using a false value for this option. As described in L above, content is lost in scalar context. =back =head3 Validation When receiving CSV files from external sources, this method can be used to protect against changes in the layout by restricting to known headers (and typos in the header fields). my %known = ( "record key" => "c_rec", "rec id" => "c_rec", "id_rec" => "c_rec", "kode" => "code", "code" => "code", "vaule" => "value", "value" => "value", ); my $csv = Text::CSV->new ({ binary => 1, auto_diag => 1 }); open my $fh, "<", $source or die "$source: $!"; $csv->header ($fh, { munge_column_names => sub { s/\s+$//; s/^\s+//; $known{lc $_} or die "Unknown column '$_' in $source"; }}); while (my $row = $csv->getline_hr ($fh)) { say join "\t", $row->{c_rec}, $row->{code}, $row->{value}; } =head2 bind_columns Takes a list of scalar references to be used for output with L or to store in the fields fetched by L. When you do not pass enough references to store the fetched fields in, L will fail with error C<3006>. If you pass more than there are fields to return, the content of the remaining references is left untouched. Under C the two should match, otherwise L will fail with error C<2014>. $csv->bind_columns (\$code, \$name, \$price, \$description); while ($csv->getline ($fh)) { print "The price of a $name is \x{20ac} $price\n"; } To reset or clear all column binding, call L with the single argument C. This will also clear column names. $csv->bind_columns (undef); If no arguments are passed at all, L will return the list of current bindings or C if no binds are active. Note that in parsing with C, the fields are set on the fly. That implies that if the third field of a row causes an error (or this row has just two fields where the previous row had more), the first two fields already have been assigned the values of the current row, while the rest of the fields will still hold the values of the previous row. If you want the parser to fail in these cases, use the L|/strict> attribute. =head2 eof $eof = $csv->eof (); If L or L was used with an IO stream, this method will return true (1) if the last call hit end of file, otherwise it will return false (''). This is useful to see the difference between a failure and end of file. Note that if the parsing of the last line caused an error, C is still true. That means that if you are I using L, an idiom like while (my $row = $csv->getline ($fh)) { # ... } $csv->eof or $csv->error_diag; will I report the error. You would have to change that to while (my $row = $csv->getline ($fh)) { # ... } +$csv->error_diag and $csv->error_diag; =head2 types $csv->types (\@tref); This method is used to force that (all) columns are of a given type. For example, if you have an integer column, two columns with doubles and a string column, then you might do a $csv->types ([Text::CSV::IV (), Text::CSV::NV (), Text::CSV::NV (), Text::CSV::PV ()]); Column types are used only for I columns while parsing, in other words by the L and L methods. You can unset column types by doing a $csv->types (undef); or fetch the current type settings with $types = $csv->types (); =over 4 =item IV =item CSV_TYPE_IV Set field type to integer. =item NV =item CSV_TYPE_NV Set field type to numeric/float. =item PV =item CSV_TYPE_PV Set field type to string. =back =head2 fields @columns = $csv->fields (); This method returns the input to L or the resultant decomposed fields of a successful L, whichever was called more recently. Note that the return value is undefined after using L, which does not fill the data structures returned by L. =head2 meta_info @flags = $csv->meta_info (); This method returns the "flags" of the input to L or the flags of the resultant decomposed fields of L, whichever was called more recently. For each field, a meta_info field will hold flags that inform something about the field returned by the L method or passed to the L method. The flags are bit-wise-C'd like: =over 2 =item C<0x0001> =item C The field was quoted. =item C<0x0002> =item C The field was binary. =item C<0x0004> =item C The field was invalid. Currently only used when C is active. =item C<0x0010> =item C The field was missing. =back See the C methods below. =head2 is_quoted my $quoted = $csv->is_quoted ($column_idx); where C<$column_idx> is the (zero-based) index of the column in the last result of L. This returns a true value if the data in the indicated column was enclosed in L|/quote_char> quotes. This might be important for fields where content C<,20070108,> is to be treated as a numeric value, and where C<,"20070108",> is explicitly marked as character string data. This method is only valid when L is set to a true value. =head2 is_binary my $binary = $csv->is_binary ($column_idx); where C<$column_idx> is the (zero-based) index of the column in the last result of L. This returns a true value if the data in the indicated column contained any byte in the range C<[\x00-\x08,\x10-\x1F,\x7F-\xFF]>. This method is only valid when L is set to a true value. =head2 is_missing my $missing = $csv->is_missing ($column_idx); where C<$column_idx> is the (zero-based) index of the column in the last result of L. $csv->keep_meta_info (1); while (my $hr = $csv->getline_hr ($fh)) { $csv->is_missing (0) and next; # This was an empty line } When using L, it is impossible to tell if the parsed fields are C because they where not filled in the C stream or because they were not read at all, as B the fields defined by L are set in the hash-ref. If you still need to know if all fields in each row are provided, you should enable L|/keep_meta_info> so you can check the flags. If L|/keep_meta_info> is C, C will always return C, regardless of C<$column_idx> being valid or not. If this attribute is C it will return either C<0> (the field is present) or C<1> (the field is missing). A special case is the empty line. If the line is completely empty - after dealing with the flags - this is still a valid CSV line: it is a record of just one single empty field. However, if C is set, invoking C with index C<0> will now return true. =head2 status $status = $csv->status (); This method returns the status of the last invoked L or L call. Status is success (true: C<1>) or failure (false: C or C<0>). Note that as this only keeps track of the status of above mentioned methods, you are probably looking for L|/error_diag> instead. =head2 error_input $bad_argument = $csv->error_input (); This method returns the erroneous argument (if it exists) of L or L, whichever was called more recently. If the last invocation was successful, C will return C. Depending on the type of error, it I also hold the data for the last error-input of L. =head2 error_diag Text::CSV->error_diag (); $csv->error_diag (); $error_code = 0 + $csv->error_diag (); $error_str = "" . $csv->error_diag (); ($cde, $str, $pos, $rec, $fld, $xs) = $csv->error_diag (); If (and only if) an error occurred, this function returns the diagnostics of that error. If called in void context, this will print the internal error code and the associated error message to STDERR. If called in list context, this will return the error code and the error message in that order. If the last error was from parsing, the rest of the values returned are a best guess at the location within the line that was being parsed. Their values are 1-based. The position currently is index of the byte at which the parsing failed in the current record. It might change to be the index of the current character in a later release. The records is the index of the record parsed by the csv instance. The field number is the index of the field the parser thinks it is currently trying to parse. See F for how this can be used. If C<$xs> is set, it is the line number in XS where the error was triggered (for debugging). C will show in void context only when L is set. If called in scalar context, it will return the diagnostics in a single scalar, a-la C<$!>. It will contain the error code in numeric context, and the diagnostics message in string context. When called as a class method or a direct function call, the diagnostics are that of the last L call. =head3 _cache_diag Note: This is an internal function only, and output cannot be relied upon. Use at own risk. If debugging beyond what L is able to show, the internal cache can be shown with this function. # Something failed .. $csv->error_diag; $csv->_cache_diag (); =head2 record_number $recno = $csv->record_number (); Returns the records parsed by this csv instance. This value should be more accurate than C<$.> when embedded newlines come in play. Records written by this instance are not counted. =head2 SetDiag $csv->SetDiag (0); Use to reset the diagnostics if you are dealing with errors. =head1 ADDITIONAL METHODS =over =item backend Returns the backend module name called by Text::CSV. C is an alias. =item is_xs Returns true value if Text::CSV uses an XS backend. =item is_pp Returns true value if Text::CSV uses a pure-Perl backend. =back =head1 FUNCTIONS This section is also taken from Text::CSV_XS. =head2 csv This function is not exported by default and should be explicitly requested: use Text::CSV qw( csv ); This is a high-level function that aims at simple (user) interfaces. This can be used to read/parse a C file or stream (the default behavior) or to produce a file or write to a stream (define the C attribute). It returns an array- or hash-reference on parsing (or C on fail) or the numeric value of L on writing. When this function fails you can get to the error using the class call to L my $aoa = csv (in => "test.csv") or die Text::CSV->error_diag; Note that failure here is the inability to start the parser, like when the input does not exist or the arguments are unknown or conflicting. Run-time parsing errors will return a valid reference, which can be empty, but still contains all results up till the error. See L. This function takes the arguments as key-value pairs. This can be passed as a list or as an anonymous hash: my $aoa = csv ( in => "test.csv", sep_char => ";"); my $aoh = csv ({ in => $fh, headers => "auto" }); The arguments passed consist of two parts: the arguments to L itself and the optional attributes to the C object used inside the function as enumerated and explained in L. If not overridden, the default option used for CSV is auto_diag => 1 escape_null => 0 strict_eol => 1 The option that is always set and cannot be altered is binary => 1 As this function will likely be used in one-liners, it allows C to be abbreviated as C, and C to be abbreviated as C or C. Alternative invocations: my $aoa = Text::CSV::csv (in => "file.csv"); my $csv = Text::CSV->new (); my $aoa = $csv->csv (in => "file.csv"); In the latter case, the object attributes are used from the existing object and the attribute arguments in the function call are ignored: my $csv = Text::CSV->new ({ sep_char => ";" }); my $aoh = $csv->csv (in => "file.csv", bom => 1); will parse using C<;> as C, not C<,>. =head3 in Used to specify the source. C can be a file name (e.g. C<"file.csv">), which will be opened for reading and closed when finished, a file handle (e.g. C<$fh> or C), a reference to a glob (e.g. C<\*ARGV>), the glob itself (e.g. C<*STDIN>), or a reference to a scalar (e.g. C<\q{1,2,"csv"}>). When used with L, C should be a reference to a CSV structure (AoA or AoH) or a CODE-ref that returns an array-reference or a hash-reference. The code-ref will be invoked with no arguments. my $aoa = csv (in => "file.csv"); open my $fh, "<", "file.csv"; my $aoa = csv (in => $fh); my $csv = [ [qw( Foo Bar )], [ 1, 2 ], [ 2, 3 ]]; my $err = csv (in => $csv, out => "file.csv"); If called in void context without the L attribute, the resulting ref will be used as input to a subsequent call to csv: csv (in => "file.csv", filter => { 2 => sub { length > 2 }}) will be a shortcut to csv (in => csv (in => "file.csv", filter => { 2 => sub { length > 2 }})) where, in the absence of the C attribute, this is a shortcut to csv (in => csv (in => "file.csv", filter => { 2 => sub { length > 2 }}), out => *STDOUT) =head3 out csv (in => $aoa, out => "file.csv"); csv (in => $aoa, out => $fh); csv (in => $aoa, out => STDOUT); csv (in => $aoa, out => *STDOUT); csv (in => $aoa, out => \*STDOUT); csv (in => $aoa, out => \my $data); csv (in => $aoa, out => undef); csv (in => $aoa, out => \"skip"); csv (in => $fh, out => \@aoa); csv (in => $fh, out => \@aoh, bom => 1); csv (in => $fh, out => \%hsh, key => "key"); csv (in => $file, out => $file); csv (in => $file, out => $fh); csv (in => $fh, out => $file); csv (in => $fh, out => $fh); In output mode, the default CSV options when producing CSV are eol => "\r\n" The L attribute is ignored in output mode. C can be a file name (e.g. C<"file.csv">), which will be opened for writing and closed when finished, a file handle (e.g. C<$fh> or C), a reference to a glob (e.g. C<\*STDOUT>), the glob itself (e.g. C<*STDOUT>), or a reference to a scalar (e.g. C<\my $data>). csv (in => sub { $sth->fetch }, out => "dump.csv"); csv (in => sub { $sth->fetchrow_hashref }, out => "dump.csv", headers => $sth->{NAME_lc}); When a code-ref is used for C, the output is generated per invocation, so no buffering is involved. This implies that there is no size restriction on the number of records. The C function ends when the coderef returns a false value. If C is set to a reference of the literal string C<"skip">, the output will be suppressed completely, which might be useful in combination with a filter for side effects only. my %cache; csv (in => "dump.csv", out => \"skip", on_in => sub { $cache{$_[1][1]}++ }); Currently, setting C to any false value (C, C<"">, 0) will be equivalent to C<\"skip">. If the C argument point to something to parse, and the C is set to a reference to an C or a C, the output is appended to the data in the existing reference. The result of the parse should match what exists in the reference passed. This might come handy when you have to parse a set of files with similar content (like data stored per period) and you want to collect that into a single data structure: my %hash; csv (in => $_, out => \%hash, key => "id") for sort glob "foo-[0-9]*.csv"; my @list; # List of arrays csv (in => $_, out => \@list) for sort glob "foo-[0-9]*.csv"; my @list; # List of hashes csv (in => $_, out => \@list, bom => 1) for sort glob "foo-[0-9]*.csv"; =head4 Streaming If B C and C are files, file handles or globs, streaming is enforced by injecting an C callback that immediately uses the L|/say> method of the same instance to output the result and then rejects the record. If a C was already passed as attribute, that will be included in the injected call. If C was passed and C was not, it will be used instead. If both were passed, C is ignored. The EOL of the first record of the C source is consistently used as EOL for all records in the C destination. The C attribute is not available. All other attributes are shared for C and C, so you cannot define different encodings for C and C. You need to pass a C<$fh>, where C was used to apply the encoding layers. Note that this is work in progress and things might change. =head3 encoding If passed, it should be an encoding accepted by the C<:encoding()> option to C. There is no default value. This attribute does not work in perl 5.6.x. C can be abbreviated to C for ease of use in command line invocations. If C is set to the literal value C<"auto">, the method L
will be invoked on the opened stream to check if there is a BOM and set the encoding accordingly. This is equal to passing a true value in the option L|/detect_bom>. Encodings can be stacked, as supported by C: # Using PerlIO::via::gzip csv (in => \@csv, out => "test.csv:via.gz", encoding => ":via(gzip):encoding(utf-8)", ); $aoa = csv (in => "test.csv:via.gz", encoding => ":via(gzip)"); # Using PerlIO::gzip csv (in => \@csv, out => "test.csv:via.gz", encoding => ":gzip:encoding(utf-8)", ); $aoa = csv (in => "test.csv:gzip.gz", encoding => ":gzip"); =head3 detect_bom If C is given, the method L will be invoked on the opened stream to check if there is a BOM and set the encoding accordingly. C can be abbreviated to C. This is the same as setting L|/encoding> to C<"auto">. Note that as the method L is invoked, its default is to also set the headers. =head3 headers If this attribute is not given, the default behavior is to produce an array of arrays. If C is supplied, it should be an anonymous list of column names, an anonymous hashref, a coderef, or a literal flag: C, C, C, or C. =over 2 =item skip When C is used, the header will not be included in the output. my $aoa = csv (in => $fh, headers => "skip"); C is invalid/ignored in combinations with L|/detect_bom>. =item auto If C is used, the first line of the C source will be read as the list of field headers and used to produce an array of hashes. my $aoh = csv (in => $fh, headers => "auto"); =item lc If C is used, the first line of the C source will be read as the list of field headers mapped to lower case and used to produce an array of hashes. This is a variation of C. my $aoh = csv (in => $fh, headers => "lc"); =item uc If C is used, the first line of the C source will be read as the list of field headers mapped to upper case and used to produce an array of hashes. This is a variation of C. my $aoh = csv (in => $fh, headers => "uc"); =item CODE If a coderef is used, the first line of the C source will be read as the list of mangled field headers in which each field is passed as the only argument to the coderef. This list is used to produce an array of hashes. my $aoh = csv (in => $fh, headers => sub { lc ($_[0]) =~ s/kode/code/gr }); this example is a variation of using C where all occurrences of C are replaced with C. =item ARRAY If C is an anonymous list, the entries in the list will be used as field names. The first line is considered data instead of headers. my $aoh = csv (in => $fh, headers => [qw( Foo Bar )]); csv (in => $aoa, out => $fh, headers => [qw( code description price )]); =item HASH If C is a hash reference, this implies C, but header fields that exist as key in the hashref will be replaced by the value for that key. Given a CSV file like post-kode,city,name,id number,fubble 1234AA,Duckstad,Donald,13,"X313DF" using csv (headers => { "post-kode" => "pc", "id number" => "ID" }, ... will return an entry like { pc => "1234AA", city => "Duckstad", name => "Donald", ID => "13", fubble => "X313DF", } =back See also L|/munge_column_names> and L|/set_column_names>. =head3 munge_column_names If C is set, the method L is invoked on the opened stream with all matching arguments to detect and set the headers. C can be abbreviated to C. =head3 key If passed, will default L|/headers> to C<"auto"> and return a hashref instead of an array of hashes. Allowed values are simple scalars or array-references where the first element is the joiner and the rest are the fields to join to combine the key. my $ref = csv (in => "test.csv", key => "code"); my $ref = csv (in => "test.csv", key => [ ":" => "code", "color" ]); with test.csv like code,product,price,color 1,pc,850,gray 2,keyboard,12,white 3,mouse,5,black the first example will return { 1 => { code => 1, color => 'gray', price => 850, product => 'pc' }, 2 => { code => 2, color => 'white', price => 12, product => 'keyboard' }, 3 => { code => 3, color => 'black', price => 5, product => 'mouse' } } the second example will return { "1:gray" => { code => 1, color => 'gray', price => 850, product => 'pc' }, "2:white" => { code => 2, color => 'white', price => 12, product => 'keyboard' }, "3:black" => { code => 3, color => 'black', price => 5, product => 'mouse' } } The C attribute can be combined with L|/headers> for C date that has no header line, like my $ref = csv ( in => "foo.csv", headers => [qw( c_foo foo bar description stock )], key => "c_foo", ); =head3 value Used to create key-value hashes. Only allowed when C is valid. A C can be either a single column label or an anonymous list of column labels. In the first case, the value will be a simple scalar value, in the latter case, it will be a hashref. my $ref = csv (in => "test.csv", key => "code", value => "price"); my $ref = csv (in => "test.csv", key => "code", value => [ "product", "price" ]); my $ref = csv (in => "test.csv", key => [ ":" => "code", "color" ], value => "price"); my $ref = csv (in => "test.csv", key => [ ":" => "code", "color" ], value => [ "product", "price" ]); with test.csv like code,product,price,color 1,pc,850,gray 2,keyboard,12,white 3,mouse,5,black the first example will return { 1 => 850, 2 => 12, 3 => 5, } the second example will return { 1 => { price => 850, product => 'pc' }, 2 => { price => 12, product => 'keyboard' }, 3 => { price => 5, product => 'mouse' } } the third example will return { "1:gray" => 850, "2:white" => 12, "3:black" => 5, } the fourth example will return { "1:gray" => { price => 850, product => 'pc' }, "2:white" => { price => 12, product => 'keyboard' }, "3:black" => { price => 5, product => 'mouse' } } =head3 keep_headers When using hashes, keep the column names into the arrayref passed, so all headers are available after the call in the original order. my $aoh = csv (in => "file.csv", keep_headers => \my @hdr); This attribute can be abbreviated to C or passed as C. This attribute implies a default of C for the C attribute. The headers can also be kept internally to keep stable header order: csv (in => csv (in => "file.csv", kh => "internal"), out => "new.csv", kh => "internal"); where C can also be C<1>, C, or C. This is similar to my @h; csv (in => csv (in => "file.csv", kh => \@h), out => "new.csv", headers => \@h); =head3 fragment Only output the fragment as defined in the L method. This option is ignored when I C. See L. Combining all of them could give something like use Text::CSV qw( csv ); my $aoh = csv ( in => "test.txt", encoding => "utf-8", headers => "auto", sep_char => "|", fragment => "row=3;6-9;15-*", ); say $aoh->[15]{Foo}; =head3 sep_set If C is set, the method L is invoked on the opened stream to detect and set L|/sep_char> with the given set. C can be abbreviated to C. If neither C not C is given, but C is defined, C defaults to C<[ sep ]>. This is only supported for perl version 5.10 and up. Note that as the L method is invoked, its default is to also set the headers. =head3 set_column_names If C is passed, the method L is invoked on the opened stream with all arguments meant for L. If C is passed as a false value, the content of the first row is only preserved if the output is AoA: With an input-file like bAr,foo 1,2 3,4,5 This call my $aoa = csv (in => $file, set_column_names => 0); will result in [[ "bar", "foo" ], [ "1", "2" ], [ "3", "4", "5" ]] and my $aoa = csv (in => $file, set_column_names => 0, munge => "none"); will result in [[ "bAr", "foo" ], [ "1", "2" ], [ "3", "4", "5" ]] =head3 csv The I L can also be called as a method or with an existing Text::CSV object. This could help if the function is to be invoked a lot of times and the overhead of creating the object internally over and over again would be prevented by passing an existing instance. my $csv = Text::CSV->new ({ binary => 1, auto_diag => 1 }); my $aoa = $csv->csv (in => $fh); my $aoa = csv (in => $fh, csv => $csv); both act the same. Running this 20000 times on a 20 lines CSV file, showed a 53% speedup. =head2 Callbacks Callbacks enable actions triggered from the I of Text::CSV. While most of what this enables can easily be done in an unrolled loop as described in the L callbacks can be used to meet special demands or enhance the L function. =over 2 =item error $csv->callbacks (error => sub { $csv->SetDiag (0) }); the C callback is invoked when an error occurs, but I when L is set to a true value. A callback is invoked with the values returned by L: my ($c, $s); sub ignore3006 { my ($err, $msg, $pos, $recno, $fldno) = @_; if ($err == 3006) { # ignore this error ($c, $s) = (undef, undef); Text::CSV->SetDiag (0); } # Any other error return; } # ignore3006 $csv->callbacks (error => \&ignore3006); $csv->bind_columns (\$c, \$s); while ($csv->getline ($fh)) { # Error 3006 will not stop the loop } =item after_parse $csv->callbacks (after_parse => sub { push @{$_[1]}, "NEW" }); while (my $row = $csv->getline ($fh)) { $row->[-1] eq "NEW"; } This callback is invoked after parsing with L only if no error occurred. The callback is invoked with two arguments: the current C parser object and an array reference to the fields parsed. The return code of the callback is ignored unless it is a reference to the string "skip", in which case the record will be skipped in L. sub add_from_db { my ($csv, $row) = @_; $sth->execute ($row->[4]); push @$row, $sth->fetchrow_array; } # add_from_db my $aoa = csv (in => "file.csv", callbacks => { after_parse => \&add_from_db }); This hook can be used for validation: =over 2 =item FAIL Die if any of the records does not validate a rule: after_parse => sub { $_[1][4] =~ m/^[0-9]{4}\s?[A-Z]{2}$/ or die "5th field does not have a valid Dutch zipcode"; } =item DEFAULT Replace invalid fields with a default value: after_parse => sub { $_[1][2] =~ m/^\d+$/ or $_[1][2] = 0 } =item SKIP Skip records that have invalid fields (only applies to L): after_parse => sub { $_[1][0] =~ m/^\d+$/ or return \"skip"; } =back =item before_print my $idx = 1; $csv->callbacks (before_print => sub { $_[1][0] = $idx++ }); $csv->print (*STDOUT, [ 0, $_ ]) for @members; This callback is invoked before printing with L only if no error occurred. The callback is invoked with two arguments: the current C parser object and an array reference to the fields passed. The return code of the callback is ignored. sub max_4_fields { my ($csv, $row) = @_; @$row > 4 and splice @$row, 4; } # max_4_fields csv (in => csv (in => "file.csv"), out => *STDOUT, callbacks => { before_print => \&max_4_fields }); This callback is not active for L. =back =head3 Callbacks for csv () The L allows for some callbacks that do not integrate in XS internals but only feature the L function. csv (in => "file.csv", callbacks => { filter => { 6 => sub { $_ > 15 } }, # first after_parse => sub { say "AFTER PARSE"; }, # first after_in => sub { say "AFTER IN"; }, # second on_in => sub { say "ON IN"; }, # third }, ); csv (in => $aoh, out => "file.csv", callbacks => { on_in => sub { say "ON IN"; }, # first before_out => sub { say "BEFORE OUT"; }, # second before_print => sub { say "BEFORE PRINT"; }, # third }, ); =over 2 =item filter This callback can be used to filter records. It is called just after a new record has been scanned. The callback accepts a: =over 2 =item hashref The keys are the index to the row (the field name or field number, 1-based) and the values are subs to return a true or false value. csv (in => "file.csv", filter => { 3 => sub { m/a/ }, # third field should contain an "a" 5 => sub { length > 4 }, # length of the 5th field minimal 5 }); csv (in => "file.csv", filter => { foo => sub { $_ > 4 }}); If the keys to the filter hash contain any character that is not a digit it will also implicitly set L to C<"auto"> unless L was already passed as argument. When headers are active, returning an array of hashes, the filter is not applicable to the header itself. All sub results should match, as in AND. The context of the callback sets C<$_> localized to the field indicated by the filter. The two arguments are as with all other callbacks, so the other fields in the current row can be seen: filter => { 3 => sub { $_ > 100 ? $_[1][1] =~ m/A/ : $_[1][6] =~ m/B/ }} If the context is set to return a list of hashes (L is defined), the current record will also be available in the localized C<%_>: filter => { 3 => sub { $_ > 100 && $_{foo} =~ m/A/ && $_{bar} < 1000 }} If the filter is used to I the content by changing C<$_>, make sure that the sub returns true in order not to have that record skipped: filter => { 2 => sub { $_ = uc }} will upper-case the second field, and then skip it if the resulting content evaluates to false. To always accept, end with truth: filter => { 2 => sub { $_ = uc; 1 }} =item coderef csv (in => "file.csv", filter => sub { $n++; 0; }); If the argument to C is a coderef, it is an alias or shortcut to a filter on column 0: csv (filter => sub { $n++; 0 }); is equal to csv (filter => { 0 => sub { $n++; 0 }); =item filter-name csv (in => "file.csv", filter => "not_blank"); csv (in => "file.csv", filter => "not_empty"); csv (in => "file.csv", filter => "filled"); These are predefined filters Given a file like (line numbers prefixed for doc purpose only): 1:1,2,3 2: 3:, 4:"" 5:,, 6:, , 7:"", 8:" " 9:4,5,6 =over 2 =item not_blank Filter out the blank lines This filter is a shortcut for filter => { 0 => sub { @{$_[1]} > 1 or defined $_[1][0] && $_[1][0] ne "" } } Due to the implementation, it is currently impossible to also filter lines that consists only of a quoted empty field. These lines are also considered blank lines. With the given example, lines 2 and 4 will be skipped. =item not_empty Filter out lines where all the fields are empty. This filter is a shortcut for filter => { 0 => sub { grep { defined && $_ ne "" } @{$_[1]} } } A space is not regarded being empty, so given the example data, lines 2, 3, 4, 5, and 7 are skipped. =item filled Filter out lines that have no visible data This filter is a shortcut for filter => { 0 => sub { grep { defined && m/\S/ } @{$_[1]} } } This filter rejects all lines that I have at least one field that does not evaluate to the empty string. With the given example data, this filter would skip lines 2 through 8. =back =back One could also use modules like L: use Types::Standard -types; my $type = Tuple[Str, Str, Int, Bool, Optional[Num]]; my $check = $type->compiled_check; # filter with compiled check and warnings my $aoa = csv ( in => \$data, filter => { 0 => sub { my $ok = $check->($_[1]) or warn $type->get_message ($_[1]), "\n"; return $ok; }, }, ); =item after_in This callback is invoked for each record after all records have been parsed but before returning the reference to the caller. The hook is invoked with two arguments: the current C parser object and a reference to the record. The reference can be a reference to a HASH or a reference to an ARRAY as determined by the arguments. This callback can also be passed as an attribute without the C wrapper. =item before_out This callback is invoked for each record before the record is printed. The hook is invoked with two arguments: the current C parser object and a reference to the record. The reference can be a reference to a HASH or a reference to an ARRAY as determined by the arguments. This callback can also be passed as an attribute without the C wrapper. This callback makes the row available in C<%_> if the row is a hashref. In this case C<%_> is writable and will change the original row. =item on_in This callback acts exactly as the L or the L hooks. This callback can also be passed as an attribute without the C wrapper. This callback makes the row available in C<%_> if the row is a hashref. In this case C<%_> is writable and will change the original row. So e.g. with my $aoh = csv ( in => \"foo\n1\n2\n", headers => "auto", on_in => sub { $_{bar} = 2; }, ); C<$aoh> will be: [ { foo => 1, bar => 2, } { foo => 2, bar => 2, } ] =item on_error This callback acts exactly as the L hook. my @err; my $aoa = csv (in => $fh, on_error => sub { @err = @_ }); is identical to my $aoa = csv (in => $fh, callbacks => { error => sub { @err = @_ }, }); It can be used for ignoring errors as well as for just keeping the error in case of analysis after the C function has returned. my @err; my $aoa = csv (in => "bad.csv, on_error => sub { @err = @_ }); die Text::CSV->error_diag if @err or !$aoa; =back =head1 DIAGNOSTICS This section is also taken from Text::CSV_XS. Still under construction ... If an error occurs, C<< $csv->error_diag >> can be used to get information on the cause of the failure. Note that for speed reasons the internal value is never cleared on success, so using the value returned by L in normal cases - when no error occurred - may cause unexpected results. If the constructor failed, the cause can be found using L as a class method, like C<< Text::CSV->error_diag >>. The C<< $csv->error_diag >> method is automatically invoked upon error when the contractor was called with L|/auto_diag> set to C<1> or C<2>, or when L is in effect. When set to C<1>, this will cause a C with the error message, when set to C<2>, it will C. C<2012 - EOF> is excluded from L|/auto_diag> reports. Errors can be (individually) caught using the L callback. The errors as described below are available. I have tried to make the error itself explanatory enough, but more descriptions will be added. For most of these errors, the first three capitals describe the error category: =over 2 =item * INI Initialization error or option conflict. =item * ECR Carriage-Return related parse error. =item * EOF End-Of-File related parse error. =item * EIQ Parse error inside quotation. =item * EIF Parse error inside field. =item * ECB Combine error. =item * EHR HashRef parse related error. =back And below should be the complete list of error codes that can be returned: =over 2 =item * 1001 "INI - sep_char is equal to quote_char or escape_char" The L cannot be equal to L or to L, as this would invalidate all parsing rules. =item * 1002 "INI - allow_whitespace with escape_char or quote_char SP or TAB" Using the L|/allow_whitespace> attribute when either L|/quote_char> or L|/escape_char> is equal to C or C is too ambiguous to allow. =item * 1003 "INI - \r or \n in main attr not allowed" Using default L|/eol> characters in either L|/sep_char>, L|/quote_char>, or L|/escape_char> is not allowed. =item * 1004 "INI - callbacks should be undef or a hashref" The L|/Callbacks> attribute only allows one to be C or a hash reference. =item * 1005 "INI - EOL too long" The value passed for EOL is exceeding its maximum length (16). =item * 1006 "INI - SEP too long" The value passed for SEP is exceeding its maximum length (16). =item * 1007 "INI - QUOTE too long" The value passed for QUOTE is exceeding its maximum length (16). =item * 1008 "INI - SEP undefined" The value passed for SEP should be defined and not empty. =item * 1010 "INI - the header is empty" The header line parsed in the L is empty. =item * 1011 "INI - the header contains more than one valid separator" The header line parsed in the L contains more than one (unique) separator character out of the allowed set of separators. =item * 1012 "INI - the header contains an empty field" The header line parsed in the L contains an empty field. =item * 1013 "INI - the header contains nun-unique fields" The header line parsed in the L contains at least two identical fields. =item * 1014 "INI - header called on undefined stream" The header line cannot be parsed from an undefined source. =item * 1500 "PRM - Invalid/unsupported argument(s)" Function or method called with invalid argument(s) or parameter(s). =item * 1501 "PRM - The key attribute is passed as an unsupported type" The C attribute is of an unsupported type. =item * 1502 "PRM - The value attribute is passed without the key attribute" The C attribute is only allowed when a valid key is given. =item * 1503 "PRM - The value attribute is passed as an unsupported type" The C attribute is of an unsupported type. =item * 2010 "ECR - QUO char inside quotes followed by CR not part of EOL" When L|/eol> has been set to anything but the default, like C<"\r\t\n">, and the C<"\r"> is following the B (closing) L|/quote_char>, where the characters following the C<"\r"> do not make up the L|/eol> sequence, this is an error. =item * 2011 "ECR - Characters after end of quoted field" Sequences like C<1,foo,"bar"baz,22,1> are not allowed. C<"bar"> is a quoted field and after the closing double-quote, there should be either a new-line sequence or a separation character. =item * 2012 "EOF - End of data in parsing input stream" Self-explaining. End-of-file while inside parsing a stream. Can happen only when reading from streams with L, as using L is done on strings that are not required to have a trailing L|/eol>. =item * 2013 "INI - Specification error for fragments RFC7111" Invalid specification for URI L specification. =item * 2014 "ENF - Inconsistent number of fields" Inconsistent number of fields under strict parsing. =item * 2015 "ERW - Empty row" An empty row was not allowed. =item * 2016 "EOL - Inconsistent EOL" Inconsistent End-Of-Line detected under strict_eol parsing. =item * 2021 "EIQ - NL char inside quotes, binary off" Sequences like C<1,"foo\nbar",22,1> are allowed only when the binary option has been selected with the constructor. =item * 2022 "EIQ - CR char inside quotes, binary off" Sequences like C<1,"foo\rbar",22,1> are allowed only when the binary option has been selected with the constructor. =item * 2023 "EIQ - QUO character not allowed" Sequences like C<"foo "bar" baz",qu> and C<2023,",2008-04-05,"Foo, Bar",\n> will cause this error. =item * 2024 "EIQ - EOF cannot be escaped, not even inside quotes" The escape character is not allowed as last character in an input stream. =item * 2025 "EIQ - Loose unescaped escape" An escape character should escape only characters that need escaping. Allowing the escape for other characters is possible with the attribute L. =item * 2026 "EIQ - Binary character inside quoted field, binary off" Binary characters are not allowed by default. Exceptions are fields that contain valid UTF-8, that will automatically be upgraded if the content is valid UTF-8. Set L|/binary> to C<1> to accept binary data. =item * 2027 "EIQ - Quoted field not terminated" When parsing a field that started with a quotation character, the field is expected to be closed with a quotation character. When the parsed line is exhausted before the quote is found, that field is not terminated. =item * 2030 "EIF - NL char inside unquoted verbatim, binary off" =item * 2031 "EIF - CR char is first char of field, not part of EOL" =item * 2032 "EIF - CR char inside unquoted, not part of EOL" =item * 2034 "EIF - Loose unescaped quote" =item * 2035 "EIF - Escaped EOF in unquoted field" =item * 2036 "EIF - ESC error" =item * 2037 "EIF - Binary character in unquoted field, binary off" =item * 2110 "ECB - Binary character in Combine, binary off" =item * 2200 "EIO - print to IO failed. See errno" =item * 3001 "EHR - Unsupported syntax for column_names ()" =item * 3002 "EHR - getline_hr () called before column_names ()" =item * 3003 "EHR - bind_columns () and column_names () fields count mismatch" =item * 3004 "EHR - bind_columns () only accepts refs to scalars" =item * 3006 "EHR - bind_columns () did not pass enough refs for parsed fields" =item * 3007 "EHR - bind_columns needs refs to writable scalars" =item * 3008 "EHR - unexpected error in bound fields" =item * 3009 "EHR - print_hr () called before column_names ()" =item * 3010 "EHR - print_hr () called with invalid arguments" =back =head1 SEE ALSO L, L and L. =head1 AUTHORS and MAINTAINERS Alan Citterman Falan[at]mfgrtl.comE> wrote the original Perl module. Please don't send mail concerning Text::CSV to Alan, as he's not a present maintainer. Jochen Wiedmann Fjoe[at]ispsoft.deE> rewrote the encoding and decoding in C by implementing a simple finite-state machine and added the variable quote, escape and separator characters, the binary mode and the print and getline methods. See ChangeLog releases 0.10 through 0.23. H.Merijn Brand Fh.m.brand[at]xs4all.nlE> cleaned up the code, added the field flags methods, wrote the major part of the test suite, completed the documentation, fixed some RT bugs. See ChangeLog releases 0.25 and on. Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE wrote Text::CSV_PP which is the pure-Perl version of Text::CSV_XS. New Text::CSV (since 0.99) is maintained by Makamaka, and Kenichi Ishigaki since 1.91. =head1 COPYRIGHT AND LICENSE Text::CSV Copyright (C) 1997 Alan Citterman. All rights reserved. Copyright (C) 2007-2015 Makamaka Hannyaharamitu. Copyright (C) 2017- Kenichi Ishigaki A large portion of the doc is taken from Text::CSV_XS. See below. Text::CSV_PP: Copyright (C) 2005-2015 Makamaka Hannyaharamitu. Copyright (C) 2017- Kenichi Ishigaki A large portion of the code/doc are also taken from Text::CSV_XS. See below. Text:CSV_XS: Copyright (C) 2007-2016 H.Merijn Brand for PROCURA B.V. Copyright (C) 1998-2001 Jochen Wiedmann. All rights reserved. Portions Copyright (C) 1997 Alan Citterman. All rights reserved. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Text-CSV-2.06/META.yml0000664000175100017510000000153514761120517014445 0ustar ishigakiishigaki--- abstract: 'comma-separated values manipulator (using XS or PurePerl)' author: - 'Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Text-CSV no_index: directory: - t - inc recommends: Text::CSV_XS: '1.60' requires: IO::Handle: '0' Test::Harness: '0' Test::More: '0.92' perl: '5.006001' resources: bugtracker: https://github.com/makamaka/Text-CSV/issues license: http://dev.perl.org/licenses/ repository: https://github.com/makamaka/Text-CSV version: '2.06' x_serialization_backend: 'CPAN::Meta::YAML version 0.018'