├── files ├── utf8.csv └── macosx.csv ├── t ├── 70_rt.t ├── 20_file.t ├── 55_combi.t ├── 22_scalario.t ├── 21_lexicalio.t ├── 00_pod.t ├── 01_is_pp.t ├── 81_subclass.t ├── 60_samples.t ├── csv_method.t ├── rt99774.t ├── 30_types.t ├── 68_header.t ├── 40_misc.t ├── 77_getall.t ├── 41_null.t ├── 16_import.t ├── fields_containing_0.t ├── 76_magic.t ├── 92_stream.t ├── 47_comment.t ├── 78_fragment.t ├── 10_base.t ├── 50_utf8.t ├── 67_emptrow.t ├── 79_callbacks.t ├── util.pl ├── 66_formula.t ├── 75_hashref.t ├── 46_eol_si.t ├── 71_strict.t ├── 51_utf8.t ├── 91_csv_cb.t ├── 71_pp.t ├── 12_acc.t ├── 80_diag.t ├── 15_flags.t ├── 85_util.t └── 65_allow.t ├── .gitignore ├── MANIFEST.SKIP ├── .perltidyrc ├── .github └── workflows │ ├── build_mac.yml │ ├── build_windows.yml │ └── build.yml ├── MANIFEST ├── README.md ├── author └── bin │ ├── sync_doc.pl │ └── sync_tests.pl ├── Makefile.PL └── Changes /files/utf8.csv: -------------------------------------------------------------------------------- 1 | "Øl/Vin",0 2 | -------------------------------------------------------------------------------- /t/70_rt.t: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/makamaka/Text-CSV/HEAD/t/70_rt.t -------------------------------------------------------------------------------- /t/20_file.t: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/makamaka/Text-CSV/HEAD/t/20_file.t -------------------------------------------------------------------------------- /t/55_combi.t: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/makamaka/Text-CSV/HEAD/t/55_combi.t -------------------------------------------------------------------------------- /t/22_scalario.t: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/makamaka/Text-CSV/HEAD/t/22_scalario.t -------------------------------------------------------------------------------- /t/21_lexicalio.t: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/makamaka/Text-CSV/HEAD/t/21_lexicalio.t -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | blib 2 | inc 3 | cover_db 4 | Makefile 5 | META.yml 6 | pm_to_blib 7 | *.tar.gz 8 | *.tgz 9 | *.old 10 | Text-CSV* 11 | pod2htm* 12 | nytprof* 13 | tmp/* 14 | *.bak 15 | *.swp 16 | ex/* 17 | diff_* 18 | .shipit 19 | t_xs/* 20 | MYMETA.* 21 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | \.[oc]$ 2 | \.bs$ 3 | \.tgz$ 4 | \.tar\.gz$ 5 | \.git 6 | \.bak$ 7 | \.old$ 8 | \.shipit$ 9 | blib/ 10 | Makefile$ 11 | MANIFEST\.SKIP 12 | pm_to_blib 13 | tmp/ 14 | META.yml 15 | ex/ 16 | t_xs/ 17 | ^MYMETA\. 18 | ^author/ 19 | ^xt/ 20 | ^_ 21 | ^\. 22 | -------------------------------------------------------------------------------- /t/00_pod.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More; 7 | 8 | print STDERR "# PERL_TEXT_CSV: ", (defined $ENV{TEST_PERL_TEXT_CSV} ? "$ENV{TEST_PERL_TEXT_CSV}" : "undef"), "\n"; 9 | 10 | eval "use Test::Pod 1.00"; 11 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; 12 | all_pod_files_ok (); 13 | -------------------------------------------------------------------------------- /.perltidyrc: -------------------------------------------------------------------------------- 1 | --freeze-newlines 2 | -b 3 | -bbt=0 4 | -bext=/ 5 | -blbs=0 6 | -boa 7 | -boc 8 | -bok 9 | -bol 10 | -bot 11 | -bt=2 12 | -cab=3 13 | -ci=4 14 | -mci 15 | -xci 16 | -cti=0 17 | -i=4 18 | -kis 19 | -l=0 20 | -nbbc 21 | -nicb 22 | -nicp 23 | -nsfs 24 | -nsts 25 | -ohbr 26 | -opr 27 | -osbr 28 | -otr 29 | -pt=2 30 | -sbt=2 31 | -sct 32 | -sot 33 | -wn 34 | -msc=1 35 | -isbc 36 | -nhsc 37 | -------------------------------------------------------------------------------- /.github/workflows/build_mac.yml: -------------------------------------------------------------------------------- 1 | name: build_mac 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | tags-ignore: 8 | - '*' 9 | pull_request: 10 | 11 | jobs: 12 | perl: 13 | runs-on: macOS-latest 14 | 15 | steps: 16 | - uses: actions/checkout@master 17 | - name: perl -V 18 | run: perl -V 19 | - name: Install dependencies with develop 20 | run: curl -sL https://cpanmin.us | perl - --installdeps . 21 | - name: Run Makefile.PL 22 | run: perl Makefile.PL 23 | - name: Run tests 24 | run: make && make test 25 | -------------------------------------------------------------------------------- /t/01_is_pp.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; # use warnings core since 5.6 5 | 6 | use Test::More tests => 4; 7 | 8 | BEGIN { 9 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 10 | use_ok "Text::CSV"; 11 | plan skip_all => "Cannot load Text::CSV" if $@; 12 | } 13 | 14 | if (!$ENV{PERL_TEXT_CSV} or $ENV{PERL_TEXT_CSV} eq 'Text::CSV_PP' or !eval { require Text::CSV_XS; 1 }) { 15 | ok my $csv = Text::CSV->new; 16 | ok $csv->is_pp; 17 | is $csv->module => 'Text::CSV_PP'; 18 | } else { 19 | ok my $csv = Text::CSV->new; 20 | ok $csv->is_xs; 21 | is $csv->module => 'Text::CSV_XS'; 22 | } 23 | -------------------------------------------------------------------------------- /.github/workflows/build_windows.yml: -------------------------------------------------------------------------------- 1 | name: build_windows 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | tags-ignore: 8 | - '*' 9 | pull_request: 10 | 11 | jobs: 12 | perl: 13 | runs-on: windows-latest 14 | 15 | steps: 16 | - uses: actions/checkout@master 17 | # - name: Set up Perl 18 | # run: | 19 | # choco install strawberryperl 20 | # echo "##[add-path]C:\strawberry\c\bin;C:\strawberry\perl\site\bin;C:\strawberry\perl\bin" 21 | - name: perl -V 22 | run: perl -V 23 | - name: Install dependencies with develop 24 | run: cpanm --installdeps . -v 25 | - name: Run Makefile.PL 26 | run: perl Makefile.PL 27 | - name: Run tests 28 | run: gmake test 29 | -------------------------------------------------------------------------------- /t/81_subclass.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | package Text::CSV::Subclass; 4 | 5 | BEGIN { 6 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 7 | } 8 | 9 | BEGIN { require Text::CSV; } # needed for perl5.005 10 | 11 | use strict; 12 | $^W = 1; 13 | 14 | use base "Text::CSV"; 15 | 16 | use Test::More tests => 6; 17 | 18 | ok (1, "Subclassed"); 19 | 20 | my $csvs = Text::CSV::Subclass->new (); 21 | is ($csvs->error_diag (), "", "Last failure for new () - OK"); 22 | 23 | my $sc_csv; 24 | eval { $sc_csv = Text::CSV::Subclass->new ({ ecs_char => ":" }); }; 25 | is ($sc_csv, undef, "Unsupported option"); 26 | is ($@, "", "error"); 27 | 28 | is (Text::CSV::Subclass->error_diag (), 29 | "INI - Unknown attribute 'ecs_char'", "Last failure for new () - FAIL"); 30 | 31 | is (Text::CSV::Subclass->new ({ fail_me => "now" }), undef, "bad new ()"); 32 | 33 | 1; 34 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | Changes 2 | files/macosx.csv 3 | files/utf8.csv 4 | lib/Text/CSV.pm 5 | lib/Text/CSV_PP.pm 6 | Makefile.PL 7 | MANIFEST This list of files 8 | README.md 9 | t/00_pod.t 10 | t/01_is_pp.t 11 | t/10_base.t 12 | t/12_acc.t 13 | t/15_flags.t 14 | t/16_import.t 15 | t/20_file.t 16 | t/21_lexicalio.t 17 | t/22_scalario.t 18 | t/30_types.t 19 | t/40_misc.t 20 | t/41_null.t 21 | t/45_eol.t 22 | t/46_eol_si.t 23 | t/47_comment.t 24 | t/50_utf8.t 25 | t/51_utf8.t 26 | t/55_combi.t 27 | t/60_samples.t 28 | t/65_allow.t 29 | t/66_formula.t 30 | t/67_emptrow.t 31 | t/68_header.t 32 | t/70_rt.t 33 | t/71_pp.t 34 | t/71_strict.t 35 | t/75_hashref.t 36 | t/76_magic.t 37 | t/77_getall.t 38 | t/78_fragment.t 39 | t/79_callbacks.t 40 | t/80_diag.t 41 | t/81_subclass.t 42 | t/85_util.t 43 | t/90_csv.t 44 | t/91_csv_cb.t 45 | t/92_stream.t 46 | t/csv_method.t 47 | t/fields_containing_0.t 48 | t/rt99774.t 49 | t/util.pl 50 | -------------------------------------------------------------------------------- /files/macosx.csv: -------------------------------------------------------------------------------- 1 | "'\'\\'\\\'""\""\\""\\\""",,,,,,,,,,,,,, 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, -------------------------------------------------------------------------------- /t/60_samples.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More tests => 8; 7 | 8 | BEGIN { 9 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 10 | use_ok "Text::CSV", (); 11 | plan skip_all => "Cannot load Text::CSV" if $@; 12 | } 13 | 14 | # Some assorted examples from the modules history 15 | 16 | # "Pavel Kotala" 17 | { 18 | my $csv = Text::CSV->new ({ 19 | quote_char => '"', 20 | escape_char => '\\', 21 | sep_char => ';', 22 | binary => 1, 23 | }); 24 | ok ($csv, "new (\", \\\\, ;, 1)"); 25 | 26 | my @list = ("c:\\winnt", "text"); 27 | ok ($csv->combine (@list), "combine ()"); 28 | my $line = $csv->string; 29 | ok ($line, "string ()"); 30 | ok ($csv->parse ($line), "parse ()"); 31 | my @olist = $csv->fields; 32 | is (scalar @list, scalar @olist, "field count"); 33 | is ($list[0], $olist[0], "field 1"); 34 | is ($list[1], $olist[1], "field 2"); 35 | } 36 | -------------------------------------------------------------------------------- /t/csv_method.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use File::Spec; 4 | use Test::More tests => 5; 5 | 6 | BEGIN { 7 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 8 | require_ok "Text::CSV"; 9 | plan skip_all => "Cannot load Text::CSV" if $@; 10 | } 11 | 12 | { 13 | my $file = prepare('1,2,3'); 14 | my $csv = Text::CSV->new (); 15 | ok my $aoa = eval { $csv->csv (in => $file) }; 16 | is_deeply($aoa, [[1,2,3]]) or note explain $aoa; 17 | unlink $file; 18 | } 19 | 20 | { 21 | my $file = prepare('col1;col2;col3','1;2;3'); 22 | my $csv = Text::CSV->new ({ sep_char => ";" }); 23 | ok my $aoh = eval { $csv->csv (in => $file, bom => 1) }; 24 | is_deeply($aoh, [{col1 => 1, col2 => 2, col3 => 3}]) or note explain $aoh; 25 | unlink $file; 26 | } 27 | 28 | sub prepare { 29 | my @lines = @_; 30 | my $file = File::Spec->catfile(File::Spec->tmpdir, "file.csv"); 31 | open my $fh, '>', $file; 32 | print $fh "$_\n" for @lines; 33 | close $fh; 34 | $file; 35 | } 36 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | tags-ignore: 8 | - '*' 9 | pull_request: 10 | 11 | jobs: 12 | perl: 13 | runs-on: ubuntu-latest 14 | 15 | strategy: 16 | matrix: 17 | perl-version: 18 | - '5.8-buster' 19 | - '5.10-buster' 20 | - '5.18-buster' 21 | - '5.20-buster' 22 | - '5.26' 23 | - 'latest' 24 | 25 | container: 26 | image: perl:${{ matrix.perl-version }} 27 | 28 | steps: 29 | - uses: actions/checkout@v1 30 | - name: perl -V 31 | run: perl -V 32 | - name: Install dependencies 33 | run: curl -sL https://cpanmin.us | perl - --installdeps . 34 | - name: Run tests 35 | run: perl Makefile.PL && make && make test 36 | - name: Install XS 37 | run: curl -sL https://cpanmin.us | perl - Text::CSV_XS@1.60 38 | - name: Run XS tests 39 | run: perl Makefile.PL && make && TEST_PERL_TEXT_CSV=2 make test 40 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Text::CSV version 1.33 2 | ---------------------- 3 | 4 | Text::CSV provides facilities for the composition and decomposition of 5 | comma-separated values. An instance of the Text::CSV class can combine 6 | fields into a CSV string and parse a CSV string into fields. 7 | 8 | The module accepts either strings or files as input and can utilize any 9 | user-specified characters as delimiters, separators, and escapes so it is 10 | perhaps better called ASV (anything separated values) rather than just CSV. 11 | 12 | Please refer to the [complete documentation of Text::CSV](https://metacpan.org/pod/Text::CSV) 13 | for more information. 14 | 15 | 16 | #### Installation #### 17 | 18 | cpanm Text::CSV 19 | 20 | Or manually: 21 | 22 | perl Makefile.PL 23 | make 24 | make test 25 | make install 26 | 27 | 28 | #### Copyright and License #### 29 | 30 | Copyright (C) 1997 Alan Citterman. All rights reserved. 31 | Copyright (C) 2007-2015 Makamaka Hannyaharamitu. All rights reserved. 32 | 33 | This library is free software; you can redistribute it and/or modify 34 | it under the same terms as Perl itself. 35 | -------------------------------------------------------------------------------- /t/rt99774.t: -------------------------------------------------------------------------------- 1 | 2 | $^W = 1; 3 | use strict; 4 | 5 | use Test::More tests => 8; 6 | 7 | 8 | BEGIN { 9 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 10 | require_ok "Text::CSV"; 11 | plan skip_all => "Cannot load Text::CSV" if $@; 12 | require "./t/util.pl"; 13 | } 14 | 15 | my $csv = Text::CSV->new ( { binary => 1, sep_char => ';', allow_whitespace => 1, quote_char => '"' } ); 16 | 17 | # https://rt.cpan.org/Public/Bug/Display.html?id=99774 18 | 19 | while ( my $line = ) { 20 | my $text = $line; 21 | chomp($text); $text =~ s/"//g; 22 | my $expect = [ split/;/, $text ]; 23 | 24 | $csv->parse($line); 25 | is_deeply( [$csv->fields], $expect, $line ); 26 | } 27 | 28 | # https://rt.cpan.org/Public/Bug/Display.html?id=92509 29 | 30 | for my $allow_whitespace ( 0, 1 ) { 31 | $csv = Text::CSV->new ( { allow_whitespace => $allow_whitespace } ); 32 | $csv->parse(q{"value1","0","value3"}); 33 | is_deeply( [$csv->fields], ["value1","0","value3"], 'allow_whitespace:' . $allow_whitespace ); 34 | } 35 | 36 | 37 | __DATA__ 38 | "data_quality_id";"language_version_id";"name" 39 | "0";"2";"0%" 40 | "10";"2";"33%" 41 | "20";"2";"66%" 42 | "30";"2";"100%" 43 | -------------------------------------------------------------------------------- /t/30_types.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More tests => 25; 7 | 8 | BEGIN { 9 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 10 | use_ok "Text::CSV", (); 11 | plan skip_all => "Cannot load Text::CSV" if $@; 12 | } 13 | 14 | $| = 1; 15 | 16 | my $csv = Text::CSV->new ({ 17 | types => [ 18 | Text::CSV::IV (), 19 | Text::CSV::PV (), 20 | Text::CSV::NV (), 21 | ], 22 | }); 23 | 24 | ok ($csv, "CSV_XS->new ()"); 25 | 26 | is (@{$csv->{types}}, 3, "->{types} as hash"); 27 | is ($csv->{types}[0], Text::CSV::IV (), "type IV"); 28 | is ($csv->{types}[1], Text::CSV::PV (), "type PV"); 29 | is ($csv->{types}[2], Text::CSV::NV (), "type NV"); 30 | 31 | is (ref ($csv->types), "ARRAY", "->types () as method"); 32 | is ($csv->types ()->[0], Text::CSV::IV (), "type IV"); 33 | is ($csv->types ()->[1], Text::CSV::PV (), "type PV"); 34 | is ($csv->types ()->[2], Text::CSV::NV (), "type NV"); 35 | 36 | is (length $csv->{_types}, 3, "->{_types}"); 37 | my $inp = join "", map { chr $_ } 38 | Text::CSV::IV (), Text::CSV::PV (), Text::CSV::NV (); 39 | # should be "\001\000\002" 40 | is ($csv->{_types}, $inp, "IV PV NV"); 41 | 42 | ok ($csv->parse ("2.55,CSFDATVM01,3.75"), "parse ()"); 43 | my @fields = $csv->fields (); 44 | is ($fields[0], "2", "Field 1"); 45 | is ($fields[1], "CSFDATVM01", "Field 2"); 46 | is ($fields[2], "3.75", "Field 3"); 47 | 48 | ok ($csv->combine ("", "", "1.00"), "combine ()"); 49 | is ($csv->string, ',,1.00', "string"); 50 | 51 | my $warning; 52 | $SIG{__WARN__} = sub { $warning = shift }; 53 | 54 | ok ($csv->parse ($csv->string ()), "parse (combine ())"); 55 | like ($warning, qr/numeric/, "numeric warning"); 56 | 57 | @fields = $csv->fields (); 58 | is ($fields[0], "0", "Field 1"); 59 | is ($fields[1], "", "Field 2"); 60 | is ($fields[2], "1", "Field 3"); 61 | 62 | is ($csv->types (0), undef, "delete types"); 63 | is ($csv->types, undef, "types gone"); 64 | -------------------------------------------------------------------------------- /t/68_header.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More; 7 | 8 | BEGIN { 9 | if ($] < 5.008001) { 10 | plan skip_all => "This test unit requires perl-5.8.1 or higher"; 11 | } 12 | else { 13 | plan tests => 32; 14 | } 15 | 16 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 17 | 18 | use_ok "Text::CSV", "csv"; 19 | require "./t/util.pl"; 20 | } 21 | 22 | my $tfn = "_68test.csv"; END { unlink $tfn, "_$tfn"; } 23 | 24 | my @dta = ( 25 | [qw( foo bar zap )], 26 | [qw( mars venus pluto )], 27 | [qw( 1 2 3 )], 28 | ); 29 | my @dth = ( 30 | { foo => "mars", bar => "venus", zap => "pluto" }, 31 | { foo => 1, bar => 2, zap => 3 }, 32 | ); 33 | 34 | { open my $fh, ">", $tfn or die "$tfn: $!\n"; 35 | local $" = ","; 36 | print $fh "@$_\n" for @dta; 37 | close $fh; 38 | } 39 | 40 | is_deeply (csv (in => $tfn), \@dta, "csv ()"); 41 | is_deeply (csv (in => $tfn, bom => 1), \@dth, "csv (bom)"); 42 | is_deeply (csv (in => $tfn, headers => "auto"), \@dth, "csv (headers)"); 43 | is_deeply (csv (in => $tfn, bom => 1, headers => "auto"), \@dth, "csv (bom, headers)"); 44 | 45 | foreach my $arg ("", "bom", "auto", "bom, auto") { 46 | open my $fh, "<", $tfn or die "$tfn: $!\n"; 47 | my %attr; 48 | $arg =~ m/bom/ and $attr{bom} = 1; 49 | $arg =~ m/auto/ and $attr{headers} = "auto"; 50 | ok (my $csv = Text::CSV->new (), "New ($arg)"); 51 | is ($csv->record_number, 0, "start"); 52 | if ($arg) { 53 | is_deeply ([ $csv->header ($fh, \%attr) ], $dta[0], "Header") if $arg; 54 | is ($csv->record_number, 1, "first data-record"); 55 | is_deeply ($csv->getline_hr ($fh), $dth[$_], "getline $_") for 0..$#dth; 56 | } 57 | else { 58 | is_deeply ($csv->getline ($fh), $dta[$_], "getline $_") for 0..$#dta; 59 | } 60 | is ($csv->record_number, 3, "done"); 61 | close $fh; 62 | } 63 | 64 | 65 | -------------------------------------------------------------------------------- /t/40_misc.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More tests => 24; 7 | 8 | BEGIN { 9 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 10 | require_ok "Text::CSV"; 11 | plan skip_all => "Cannot load Text::CSV" if $@; 12 | require "./t/util.pl"; 13 | } 14 | 15 | $| = 1; 16 | 17 | my @binField = ("abc\0def\n\rghi", "ab\"ce,\031\"'", "\266"); 18 | 19 | my $csv = Text::CSV->new ({ binary => 1 }); 20 | ok ($csv->combine (@binField), "combine ()"); 21 | 22 | my $string; 23 | is_binary ($string = $csv->string, 24 | qq("abc"0def\n\rghi","ab""ce,\031""'",\266), "string ()"); 25 | 26 | ok ($csv->parse ($string), "parse ()"); 27 | is ($csv->fields, scalar @binField, "field count"); 28 | 29 | my @field = $csv->fields (); 30 | for (0 .. $#binField) { 31 | is ($field[$_], $binField[$_], "Field $_"); 32 | } 33 | 34 | ok (1, "eol \\r\\n"); 35 | $csv->eol ("\r\n"); 36 | ok ($csv->combine (@binField), "combine ()"); 37 | is_binary ($csv->string, 38 | qq("abc"0def\n\rghi","ab""ce,\031""'",\266\r\n), "string ()"); 39 | 40 | ok (1, "eol \\n"); 41 | $csv->eol ("\n"); 42 | ok ($csv->combine (@binField), "combine ()"); 43 | is_binary ($csv->string, 44 | qq("abc"0def\n\rghi","ab""ce,\031""'",\266\n), "string ()"); 45 | 46 | ok (1, "eol ,xxxxxxx\\n"); 47 | $csv->eol (",xxxxxxx\n"); 48 | ok ($csv->combine (@binField), "combine ()"); 49 | is_binary ($csv->string, 50 | qq("abc"0def\n\rghi","ab""ce,\031""'",\266,xxxxxxx\n), "string ()"); 51 | 52 | $csv->eol ("\n"); 53 | ok (1, "quote_char undef"); 54 | $csv->quote_char (undef); 55 | ok ($csv->combine ("abc","def","ghi"), "combine"); 56 | is ($csv->string, "abc,def,ghi\n", "string ()"); 57 | 58 | # Ken's test 59 | ok (1, "always_quote"); 60 | my $csv2 = Text::CSV->new ({ always_quote => 1 }); 61 | ok ($csv2, "new ()"); 62 | ok ($csv2->combine ("abc","def","ghi"), "combine ()"); 63 | is ($csv2->string, '"abc","def","ghi"', "string ()"); 64 | -------------------------------------------------------------------------------- /author/bin/sync_doc.pl: -------------------------------------------------------------------------------- 1 | # This script is to sync tests for Text::CSV with the ones for Text::CSV_XS 2 | 3 | use strict; 4 | use warnings; 5 | use FindBin; 6 | use lib "$FindBin::Bin/../../lib"; 7 | use Path::Tiny; 8 | 9 | my $root = path("$FindBin::Bin/../.."); 10 | my $xs_root = $root->parent->child('Text-CSV_XS'); 11 | 12 | die "Text::CSV_XS directory not found" unless -d $xs_root; 13 | 14 | my $xs_doc = $xs_root->child('CSV_XS.pm'); 15 | 16 | my %xs_sections; 17 | { 18 | my $title; 19 | for my $line ( split /\n/, $xs_doc->slurp ) { 20 | if ($line =~ /^=head1 (.+)/) { 21 | $title = $1; 22 | $xs_sections{$title} = ''; 23 | next; 24 | } 25 | next unless $title; 26 | $xs_sections{$title} .= $line . "\n"; 27 | } 28 | } 29 | 30 | for my $pm_name (qw/CSV CSV_PP/) { 31 | my $pm_file = $root->child("lib/Text/$pm_name.pm"); 32 | my $doc = ''; 33 | my $skip = 0; 34 | my $title = ''; 35 | my $first_notice = 1; 36 | for my $line ( split /\n/, $pm_file->slurp ) { 37 | if ($line =~ /^=head1 (.+)/) { 38 | $title = $1; 39 | $skip = 0; 40 | if ($title =~ /^(SYNOPSIS|METHODS|FUNCTIONS|DIAGNOSTICS|NOTES)$/) { 41 | my $notice = "This section is also taken from Text::CSV_XS."; 42 | if ($first_notice) { 43 | $notice =~ s/also //; 44 | $first_notice = 0; 45 | } 46 | $doc .= $line . "\n\n" . $notice . "\n"; 47 | my $section = $xs_sections{$title}; 48 | if ($title eq 'NOTES') { 49 | $section = $xs_sections{DESCRIPTION}; 50 | $section =~ s/^.+?=head2/\n=head2/s; 51 | } 52 | $section =~ s/CSV_[XC]S/$pm_name/g; 53 | $section =~ s/^X<[^>]+>$//gm; 54 | $section =~ s!^See also L$!!gm; 55 | $section =~ s!\s+\(Poor\s+creatures\s+who\s+are\s+better\s+to\s+use\s+Text::CSV(_PP)?\.\s+:\)!!s; 56 | $section =~ s/\n\n\n+/\n\n/gs; 57 | $doc .= $section; 58 | $skip = 1; 59 | } 60 | } 61 | next if $skip; 62 | $doc .= $line . "\n"; 63 | } 64 | $pm_file->spew($doc); 65 | } 66 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.006001; 2 | use ExtUtils::MakeMaker; 3 | 4 | use lib qw( ./lib ); 5 | 6 | $ENV{PERL_TEXT_CSV} = 'Text::CSV_PP'; 7 | eval q| require Text::CSV |; 8 | 9 | if ($@) { 10 | print "Loading lib/Text/CSV.pm failed. No B module?\n"; 11 | print "perl says : $@"; 12 | print "Set the environmental variable 'PERL_DL_NONLAZY' with 0.\n"; 13 | print "No Makefile created.\n"; 14 | exit 0; 15 | } 16 | 17 | my $version = Text::CSV->VERSION; 18 | my $req_xs_ver = Text::CSV->require_xs_version; 19 | my $has_xs = 0; 20 | my $message; 21 | 22 | eval q| require Text::CSV_XS |; 23 | 24 | $has_xs = 1 unless ($@); 25 | 26 | my %xs_prereq; 27 | if ($has_xs) { 28 | my $xs_version = Text::CSV_XS->VERSION; 29 | if ($xs_version >= $req_xs_ver) { 30 | $message = "You have Text::CSV_XS (v.$xs_version), so Text::CSV can work very fast!!"; 31 | } 32 | else { 33 | %xs_prereq = ('Text::CSV_XS' => $req_xs_ver); 34 | $message = "Your Text::CSV_XS version is $xs_version. If you install v.$req_xs_ver,\n" 35 | . "Text::CSV will work faster."; 36 | } 37 | } 38 | else { 39 | $message = "If you install Text::CSV_XS v.$req_xs_ver, it makes Text::CSV faster."; 40 | } 41 | print < 'Text::CSV', 52 | 'MIN_PERL_VERSION' => '5.006001', 53 | 'VERSION_FROM' => 'lib/Text/CSV.pm', # finds $VERSION 54 | 'ABSTRACT_FROM' => 'lib/Text/CSV.pm', # retrieve abstract from module 55 | 'AUTHOR' => 'Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE', 56 | 'PREREQ_PM' => { 57 | "IO::Handle" => 0, 58 | "Test::More" => '0.92', 59 | "Test::Harness" => 0, 60 | %xs_prereq, 61 | }, 62 | ( $ExtUtils::MakeMaker::VERSION >= 6.3002 ? ('LICENSE' => 'perl', ) : () ), 63 | 64 | ( $ExtUtils::MakeMaker::VERSION >= 6.46 ? ( 65 | 'META_MERGE' => { 66 | recommends => { 67 | 'Text::CSV_XS' => Text::CSV->require_xs_version, 68 | }, 69 | resources => { 70 | repository => 'https://github.com/makamaka/Text-CSV', 71 | bugtracker => 'https://github.com/makamaka/Text-CSV/issues', 72 | license => 'http://dev.perl.org/licenses/', 73 | }, 74 | } ) : () 75 | ), 76 | 77 | ); 78 | 79 | -------------------------------------------------------------------------------- /t/77_getall.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More tests => 81; 7 | 8 | BEGIN { 9 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 10 | require_ok "Text::CSV"; 11 | plan skip_all => "Cannot load Text::CSV" if $@; 12 | require "./t/util.pl"; 13 | } 14 | 15 | $| = 1; 16 | 17 | my $tfn = "_77test.csv"; END { -f $tfn and unlink $tfn; } 18 | my @testlist = ( 19 | [ 1, "a", "\x01", "A" ], 20 | [ 2, "b", "\x02", "B" ], 21 | [ 3, "c", "\x03", "C" ], 22 | [ 4, "d", "\x04", "D" ], 23 | ); 24 | 25 | my @list; 26 | sub do_tests { 27 | my $sub = shift; 28 | 29 | $sub->(\@list); 30 | $sub->(\@list, 0); 31 | $sub->([@list[2,3]], 2); 32 | $sub->([], 0, 0); 33 | $sub->(\@list, 0, 10); 34 | $sub->([@list[0,1]], 0, 2); 35 | $sub->([@list[1,2]], 1, 2); 36 | $sub->([@list[1,2]], 1e0, 2); 37 | $sub->([@list[1,2]], "1", 2); 38 | $sub->([@list[1..3]], -3); 39 | $sub->([@list[1,2]], -3, 2); 40 | $sub->([@list[1..3]], -3, 3); 41 | 42 | $sub->([$list[0]], 0, 1); 43 | $sub->([$list[0]], 0, 1e0); 44 | $sub->([$list[0]], 0, "1"); 45 | } # do_tests 46 | 47 | foreach my $eol ("\n", "\r") { 48 | 49 | @list = @testlist; 50 | 51 | { ok (my $csv = Text::CSV->new ({ binary => 1, eol => $eol }), "csv out EOL "._readable ($eol)); 52 | open my $fh, ">", $tfn or die "$tfn: $!"; 53 | ok ($csv->print ($fh, $_), "write $_->[0]") for @list; 54 | close $fh; 55 | } 56 | 57 | { ok (my $csv = Text::CSV->new ({ binary => 1 }), "csv in"); 58 | 59 | do_tests (sub { 60 | my ($expect, @args) = @_; 61 | open my $fh, "<", $tfn or die "$tfn: $!"; 62 | my $s_args = join ", " => @args; 63 | is_deeply ($csv->getline_all ($fh, @args), $expect, "getline_all ($s_args)"); 64 | close $fh; 65 | }); 66 | } 67 | 68 | { ok (my $csv = Text::CSV->new ({ binary => 1 }), "csv in"); 69 | ok ($csv->column_names (my @cn = qw( foo bar bin baz )), "Set column names"); 70 | @list = map { my %h; @h{@cn} = @$_; \%h } @list; 71 | 72 | do_tests (sub { 73 | my ($expect, @args) = @_; 74 | open my $fh, "<", $tfn or die "$tfn: $!"; 75 | my $s_args = join ", " => @args; 76 | is_deeply ($csv->getline_hr_all ($fh, @args), $expect, "getline_hr_all ($s_args)"); 77 | close $fh; 78 | }); 79 | } 80 | 81 | { ok (my $csv = Text::CSV->new ({ binary => 1 }), "csv in"); 82 | open my $fh, "<", $tfn or die "$tfn: $!"; 83 | eval { my $row = $csv->getline_hr_all ($fh); }; 84 | is ($csv->error_diag () + 0, 3002, "Use _hr before colnames ()"); 85 | } 86 | } 87 | -------------------------------------------------------------------------------- /t/41_null.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More tests => 128; 7 | BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; } 8 | use Text::CSV; 9 | 10 | my @pat = ( 11 | "00", 12 | "\00", 13 | "0\0", 14 | "\0\0", 15 | 16 | "0\n0", 17 | "\0\n0", 18 | "0\n\0", 19 | "\0\n\0", 20 | 21 | "\"0\n0", 22 | "\"\0\n0", 23 | "\"0\n\0", 24 | "\"\0\n\0", 25 | 26 | "\"0\n\"0", 27 | "\"\0\n\"0", 28 | "\"0\n\"\0", 29 | "\"\0\n\"\0", 30 | 31 | "0\n0", 32 | "\0\n0", 33 | "0\n\0", 34 | "\0\n\0", 35 | ); 36 | my %exp = map { 37 | my $x = $_; 38 | $x =~ s/\0/\\0/g; 39 | $x =~ s/\n/\\n/g; 40 | ($_ => $x); 41 | } @pat; 42 | my $line = ["", undef, "0\n", "", "\0\0\n0"]; 43 | my $tfn = "_41test.csv"; END { -f $tfn and unlink $tfn; } 44 | 45 | my $csv = Text::CSV->new ({ 46 | eol => "\n", 47 | binary => 1, 48 | auto_diag => 1, 49 | blank_is_undef => 1, 50 | }); 51 | 52 | ok ($csv->combine (@$line), "combine [ ... ]"); 53 | is ($csv->string, qq{,,"0\n",,""0"0\n0"\n}, "string"); 54 | 55 | open my $fh, ">", $tfn or die "$tfn: $!\n"; 56 | binmode $fh; 57 | 58 | ok ($csv->print ($fh, [ $_ ]), "print $exp{$_}") for @pat; 59 | 60 | $csv->always_quote (1); 61 | 62 | ok ($csv->print ($fh, $line), "print [ ... ]"); 63 | 64 | close $fh; 65 | 66 | open $fh, "<", $tfn or die "$tfn: $!\n"; 67 | binmode $fh; 68 | 69 | foreach my $pat (@pat) { 70 | ok (my $row = $csv->getline ($fh), "getline $exp{$pat}"); 71 | is ($row->[0], $pat, "data $exp{$pat}"); 72 | } 73 | 74 | is_deeply ($csv->getline ($fh), $line, "read [ ... ]"); 75 | 76 | close $fh; 77 | unlink $tfn; 78 | 79 | $csv = Text::CSV->new ({ 80 | eol => "\n", 81 | binary => 1, 82 | auto_diag => 1, 83 | blank_is_undef => 1, 84 | quote_null => 0, 85 | }); 86 | 87 | ok ($csv->combine (@$line), "combine [ ... ]"); 88 | is ($csv->string, qq{,,"0\n",,"\0\0\n0"\n}, "string"); 89 | 90 | open $fh, ">", $tfn or die "$tfn: $!\n"; 91 | binmode $fh; 92 | 93 | for (@pat) { 94 | ok ($csv->print ($fh, [ $_ ]), "print $exp{$_}"); 95 | } 96 | 97 | $csv->always_quote (1); 98 | 99 | ok ($csv->print ($fh, $line), "print [ ... ]"); 100 | 101 | close $fh; 102 | 103 | open $fh, "<", $tfn or die "$tfn: $!\n"; 104 | binmode $fh; 105 | 106 | foreach my $pat (@pat) { 107 | ok (my $row = $csv->getline ($fh), "getline $exp{$pat}"); 108 | is ($row->[0], $pat, "data $exp{$pat}"); 109 | } 110 | 111 | is_deeply ($csv->getline ($fh), $line, "read [ ... ]"); 112 | 113 | close $fh; 114 | -------------------------------------------------------------------------------- /t/16_import.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More tests => 41; 7 | 8 | BEGIN { 9 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 10 | use_ok "Text::CSV", qw( :CONSTANTS PV IV NV ); 11 | plan skip_all => "Cannot load Text::CSV" if $@; 12 | } 13 | 14 | is ( PV, 0, "Type PV"); 15 | is ( IV, 1, "Type IV"); 16 | is ( NV, 2, "Type NV"); 17 | 18 | is ( PV (), 0, "Type PV f"); 19 | is ( IV (), 1, "Type IV f"); 20 | is ( NV (), 2, "Type NV f"); 21 | 22 | is (Text::CSV::PV, 0, "Type T:C:PV"); 23 | is (Text::CSV::IV, 1, "Type T:C:IV"); 24 | is (Text::CSV::NV, 2, "Type T:C:NV"); 25 | 26 | is (Text::CSV::PV (), 0, "Type T:C:PV f"); 27 | is (Text::CSV::IV (), 1, "Type T:C:IV f"); 28 | is (Text::CSV::NV (), 2, "Type T:C:NV f"); 29 | 30 | is ( CSV_TYPE_PV, 0, "Type CT_PV"); 31 | is ( CSV_TYPE_IV, 1, "Type CT_IV"); 32 | is ( CSV_TYPE_NV, 2, "Type CT_NV"); 33 | 34 | is ( CSV_TYPE_PV (), 0, "Type CT_PV f"); 35 | is ( CSV_TYPE_IV (), 1, "Type CT_IV f"); 36 | is ( CSV_TYPE_NV (), 2, "Type CT_NV f"); 37 | 38 | is (Text::CSV::CSV_TYPE_PV, 0, "Type T:C:CT_PV"); 39 | is (Text::CSV::CSV_TYPE_IV, 1, "Type T:C:CT_IV"); 40 | is (Text::CSV::CSV_TYPE_NV, 2, "Type T:C:CT_NV"); 41 | 42 | is (Text::CSV::CSV_TYPE_PV (), 0, "Type T:C:CT_PV f"); 43 | is (Text::CSV::CSV_TYPE_IV (), 1, "Type T:C:CT_IV f"); 44 | is (Text::CSV::CSV_TYPE_NV (), 2, "Type T:C:CT_NV f"); 45 | 46 | is ( CSV_FLAGS_IS_QUOTED, 1, "is_Q"); 47 | is ( CSV_FLAGS_IS_BINARY, 2, "is_B"); 48 | is ( CSV_FLAGS_ERROR_IN_FIELD, 4, "is_E"); 49 | is ( CSV_FLAGS_IS_MISSING, 16, "is_M"); 50 | 51 | is ( CSV_FLAGS_IS_QUOTED (), 1, "is_Q f"); 52 | is ( CSV_FLAGS_IS_BINARY (), 2, "is_B f"); 53 | is ( CSV_FLAGS_ERROR_IN_FIELD (), 4, "is_E f"); 54 | is ( CSV_FLAGS_IS_MISSING (), 16, "is_M f"); 55 | 56 | is (Text::CSV::CSV_FLAGS_IS_QUOTED, 1, "is_Q"); 57 | is (Text::CSV::CSV_FLAGS_IS_BINARY, 2, "is_B"); 58 | is (Text::CSV::CSV_FLAGS_ERROR_IN_FIELD, 4, "is_E"); 59 | is (Text::CSV::CSV_FLAGS_IS_MISSING, 16, "is_M"); 60 | 61 | is (Text::CSV::CSV_FLAGS_IS_QUOTED (), 1, "T:C:is_Q f"); 62 | is (Text::CSV::CSV_FLAGS_IS_BINARY (), 2, "T:C:is_B f"); 63 | is (Text::CSV::CSV_FLAGS_ERROR_IN_FIELD (), 4, "T:C:is_E f"); 64 | is (Text::CSV::CSV_FLAGS_IS_MISSING (), 16, "T:C:is_M f"); 65 | -------------------------------------------------------------------------------- /t/fields_containing_0.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | =head1 DESCRIPTION 4 | 5 | This is a test program that succeeds with Text::CSV_PP and fails with 6 | Text::CSV_XS. The Text::CSV_XS behaviour is the correct one. 7 | 8 | =head1 CREDITS AND LICENSE 9 | 10 | The sample data (now anonymised) and a test program were contributed by 11 | blue_sky on Freenode’s 12 | #perl channel as part of a problem report with Text::CSV_PP based on the 13 | Text::CSV documentation. License is open source and compatible with the license 14 | of Text::CSV. 15 | 16 | Converted into a test program by Shlomi Fish ( L ) 17 | , while disclaiming all explicit or implicit copyright ownership on the 18 | modifications. 19 | 20 | ==head1 MODIFICATION 21 | 22 | modified by makamaka for old perl. 23 | 24 | =cut 25 | 26 | #use warnings; 27 | $^W = 1; 28 | use strict; 29 | 30 | use Test::More tests => 4; 31 | 32 | my $FALSE = 0; 33 | # my $USE_XS = $ENV{'USE_TEXT_CSV_XS'}; 34 | my $USE_XS = $FALSE; 35 | 36 | use Text::CSV_PP; 37 | use Data::Dumper qw(Dumper); 38 | 39 | END { unlink '_fc0_test.csv'; } 40 | 41 | if ($USE_XS) 42 | { 43 | require Text::CSV_XS; 44 | } 45 | 46 | { 47 | my $csv_text = <<'EOF'; 48 | "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" 49 | "1", "UK", "Lambda", "Gambda Noo", "Foo", "Quad", "Rectum", "", "Eingoon", "Land", "Simplex", "", "", "099 999", "", 0.00 50 | EOF 51 | 52 | # open my $IF, "<", \$csv_text; 53 | my $IF; 54 | open $IF, ">_fc0_test.csv" or die "_fc0_test.csv: $!"; 55 | print $IF $csv_text; 56 | close $IF; 57 | 58 | open $IF, "<_fc0_test.csv" or die "_fc0_test.csv: $!"; 59 | 60 | my $csv = ($USE_XS ? "Text::CSV_XS" : "Text::CSV_PP")->new({ 61 | allow_whitespace => 1, 62 | allow_loose_escapes => 1, 63 | }) or die "Cannot use CSV: ".Text::CSV->error_diag(); 64 | 65 | $csv->column_names( $csv->getline($IF) ); 66 | 67 | { 68 | my $first_line = $csv->getline_hr($IF); 69 | 70 | # TEST 71 | is ($first_line->{'POST CODE'}, 'Simplex', 72 | "First line POST CODE" 73 | ); 74 | 75 | # TEST 76 | is ($first_line->{'COUNTRY'}, '', 77 | "First line COUNTRY", 78 | ); 79 | 80 | # TEST 81 | is ($first_line->{'GRID REF'}, '', 82 | "First line GRID REF", 83 | ); 84 | 85 | # TEST 86 | is ($first_line->{'TELEPHONE'}, '099 999', 87 | "First line TELEPHONE", 88 | ); 89 | } 90 | close($IF); 91 | } 92 | -------------------------------------------------------------------------------- /t/76_magic.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | #use Test::More "no_plan"; 7 | use Test::More tests => 44; 8 | 9 | BEGIN { 10 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 11 | use_ok "Text::CSV", (); 12 | plan skip_all => "Cannot load Text::CSV" if $@; 13 | } 14 | 15 | my $tfn = "_76test.csv"; END { -f $tfn and unlink $tfn; } 16 | my $csv = Text::CSV->new ({ binary => 1, eol => "\n" }); 17 | 18 | my $fh; 19 | my $foo; 20 | my $bar; 21 | my @foo = ("#", 1..3); 22 | 23 | tie $foo, "Foo"; 24 | ok ($csv->combine (@$foo), "combine () from magic"); 25 | untie $foo; 26 | is_deeply ([$csv->fields], \@foo, "column_names ()"); 27 | 28 | tie $bar, "Bar"; 29 | $bar = "#"; 30 | ok ($csv->combine ($bar, @{$foo}[1..3]),"combine () from magic"); 31 | untie $bar; 32 | is_deeply ([$csv->fields], \@foo, "column_names ()"); 33 | 34 | tie $foo, "Foo"; 35 | open $fh, ">", $tfn or die "$tfn: $!\n"; 36 | ok ($csv->print ($fh, $foo), "print with unused magic scalar"); 37 | close $fh; 38 | untie $foo; 39 | 40 | open $fh, "<", $tfn or die "$tfn: $!\n"; 41 | is_deeply ($csv->getline ($fh), \@foo, "Content read-back"); 42 | close $fh; 43 | 44 | tie $foo, "Foo"; 45 | ok ($csv->column_names ($foo), "column_names () from magic"); 46 | untie $foo; 47 | is_deeply ([$csv->column_names], \@foo, "column_names ()"); 48 | 49 | open $fh, "<", $tfn or die "$tfn: $!\n"; 50 | tie $bar, "Bar"; 51 | ok ($csv->bind_columns (\$bar, \my ($f0, $f1, $f2)), "bind"); 52 | ok ($csv->getline ($fh), "fetch with magic"); 53 | is_deeply ([$bar,$f0,$f1,$f2], \@foo, "columns fetched on magic"); 54 | # free any refs 55 | is ($csv->bind_columns (undef), undef, "bind column clear"); 56 | untie $bar; 57 | close $fh; 58 | 59 | $csv->eol (undef); 60 | ok ($csv->combine ("us", undef, 3), "Combine with undef"); 61 | is ($csv->string, "us,,3", "Default"); 62 | foreach my $us ("\\N", 1, ",,,", "", "\xe2\x80\xa2", "\x{2205}") { 63 | ok (defined ($csv->undef_str ($us)),"Set undef_str with method"); 64 | ok ($csv->combine ("us", undef, 3), "Combine with undef"); 65 | is ($csv->string, "us,$us,3", "String after method"); 66 | } 67 | 68 | tie my $us, "Bar"; 69 | $us = "NULL"; 70 | ok ($csv->undef_str ($us), "Set undef_str from tied scalar"); 71 | ok ($csv->combine ("us", undef, 3), "Combine with undef"); 72 | is ($csv->string, "us,NULL,3", "String after method"); 73 | $us = "\\N"; 74 | ok ($csv->undef_str ($us), "Set undef_str from tied scalar"); 75 | ok ($csv->combine ("us", undef, 3), "Combine with undef"); 76 | is ($csv->string, "us,\\N,3", "String after method"); 77 | $us = undef; 78 | is ($csv->undef_str ($us), undef, "Set undef_str from tied scalar"); 79 | ok ($csv->combine ("us", undef, 3), "Combine with undef"); 80 | is ($csv->string, "us,,3", "String after method"); 81 | untie $us; 82 | 83 | $csv = Text::CSV->new ({ undef_str => "\\N" }); 84 | ok ($csv->combine ("us", undef, 3), "Combine with undef"); 85 | is ($csv->string, "us,\\N,3", "String after undef_str from constructor"); 86 | 87 | { package Foo; 88 | use strict; 89 | use warnings; 90 | 91 | require Tie::Scalar; 92 | use vars qw( @ISA ); 93 | @ISA = qw(Tie::Scalar); 94 | 95 | sub FETCH { 96 | [ "#", 1 .. 3 ]; 97 | } # FETCH 98 | 99 | sub TIESCALAR { 100 | bless [], "Foo"; 101 | } # TIESCALAR 102 | 103 | 1; 104 | } 105 | 106 | { package Bar; 107 | 108 | use strict; 109 | use warnings; 110 | 111 | require Tie::Scalar; 112 | use vars qw( @ISA ); 113 | @ISA = qw(Tie::Scalar); 114 | 115 | sub FETCH { 116 | return ${$_[0]}; 117 | } # FETCH 118 | 119 | sub STORE { 120 | ${$_[0]} = $_[1]; 121 | } # STORE 122 | 123 | sub TIESCALAR { 124 | my $bar; 125 | bless \$bar, "Bar"; 126 | } # TIESCALAR 127 | 128 | 1; 129 | } 130 | -------------------------------------------------------------------------------- /t/92_stream.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | #use Test::More "no_plan"; 7 | use Test::More tests => 21; 8 | 9 | BEGIN { 10 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 11 | use_ok "Text::CSV", ("csv"); 12 | plan skip_all => "Cannot load Text::CSV" if $@; 13 | require "./t/util.pl"; 14 | } 15 | 16 | my $tfni = "_92test-i.csv"; END { -f $tfni and unlink $tfni } # CRNL 17 | my $tfnn = "_92test-n.csv"; END { -f $tfnn and unlink $tfnn } # CRNL + NL 18 | my $tfno = "_92test-o.csv"; END { -f $tfno and unlink $tfno } # out 19 | 20 | my $data = 21 | "foo,bar,baz,quux\r\n". 22 | "1,2,3,25\r\n". 23 | "2,a b,,14\r\n"; 24 | open my $fhi, ">", $tfni or die "$tfni: $!"; 25 | print $fhi $data; 26 | close $fhi; 27 | open my $fhn, ">", $tfnn or die "$tfnn: $!"; 28 | { my $d = $data; 29 | $d =~ s/5\r\n/5\n/; 30 | print $fhn $d; 31 | } 32 | close $fhn; 33 | ok (my $aoa = csv (in => $tfni), "Read default data");; 34 | 35 | { my ($I, $O, @W); 36 | ok (my $co = Text::CSV->new ({ 37 | eol => "\n", 38 | auto_diag => 1, 39 | callbacks => { 40 | before_print => sub { 41 | warn ++$O, "\n"; 42 | $_[1][3] =~ s/x$/y/ or $_[1][3] *= 4; 43 | }, 44 | }, 45 | }), "Create external CSV object"); 46 | open my $fho, ">", $tfno or die "$tfno: $!\n"; 47 | { local $SIG{__WARN__} = sub { push @W => @_ }; 48 | csv ( 49 | in => $tfni, 50 | out => undef, 51 | callbacks => { 52 | after_parse => sub { 53 | warn ++$I, "\n"; 54 | $co->print ($fho, $_[1]); 55 | }, 56 | }, 57 | ); 58 | } 59 | close $tfno; 60 | chomp @W; 61 | is ("@W", "1 1 2 2 3 3", "Old-fashioned streaming"); 62 | } 63 | 64 | # Basic straight-forward streaming, no filters/modifiers 65 | unlink $tfno if -e $tfno; 66 | csv (in => $tfni, out => $tfno, quote_space => 0); 67 | ok (-s $tfno, "FILE -> FILE"); 68 | is_deeply (csv (in => $tfno), $aoa, "Data is equal"); 69 | 70 | unlink $tfno if -e $tfno; 71 | open my $fho, ">", $tfno; 72 | csv (in => $tfni, out => $fho, quote_space => 0); 73 | close $fho; 74 | ok (-s $tfno, "FILE -> FH"); 75 | is_deeply (csv (in => $tfno), $aoa, "Data is equal"); 76 | 77 | unlink $tfno if -e $tfno; 78 | open $fhi, "<", $tfni; 79 | csv (in => $fhi, out => $tfno, quote_space => 0); 80 | close $fhi; 81 | ok (-s $tfno, "FH -> FILE"); 82 | is_deeply (csv (in => $tfno), $aoa, "Data is equal"); 83 | 84 | unlink $tfno if -e $tfno; 85 | open $fhi, "<", $tfni; 86 | open $fho, ">", $tfno; 87 | csv (in => $fhi, out => $fho, quote_space => 0); 88 | close $fho; 89 | close $fhi; 90 | ok (-s $tfno, "FH -> FH"); 91 | is_deeply (csv (in => $tfno), $aoa, "Data is equal"); 92 | 93 | unlink $tfno if -e $tfno; 94 | my @W; 95 | eval { 96 | local $SIG{__WARN__} = sub { push @W => @_ }; 97 | csv (in => $tfnn, out => $tfno, quote_space => 0); 98 | }; 99 | like ($W[0], qr{\b2016 - EOL\b}, "Inconsistent use of EOL"); 100 | ok (-s $tfno, "FH -> FILE (NL => CRNL)"); 101 | is_deeply (csv (in => $tfno), $aoa, "Data is equal"); 102 | is (do { local (@ARGV, $/) = ($tfno); <> }, $data, "Consistent CRNL"); 103 | 104 | unlink $tfno if -e $tfno; 105 | csv ( 106 | in => $tfni, 107 | out => $tfno, 108 | quote_space => 0, 109 | after_parse => sub { $_[1][1] .= "X" }, 110 | ); 111 | ok (-s $tfno, "With after_parse"); 112 | my @new = map { my @x = @$_; $x[1] .= "X"; \@x } @$aoa; 113 | is_deeply (csv (in => $tfno), \@new, "Data is equal"); 114 | 115 | # Prove streaming behavior 116 | my $io = ""; 117 | unlink $tfno if -e $tfno; 118 | csv ( 119 | in => $tfni, 120 | out => $tfno, 121 | on_in => sub { $io .= "I" }, 122 | callbacks => { before_print => sub { $io .= "O" }}, 123 | ); 124 | ok (-s $tfno, "FILE -> FILE"); 125 | is_deeply (csv (in => $tfno), $aoa, "Data is equal"); 126 | like ($io, qr{^(?:IO)+\z}, "IOIOIO..."); 127 | -------------------------------------------------------------------------------- /t/47_comment.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More; 7 | BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; } 8 | use Text::CSV qw(csv); 9 | 10 | BEGIN { 11 | if ($] < 5.008002) { 12 | plan skip_all => "These tests require Encode and Unicode support"; 13 | } 14 | else { 15 | require Encode; 16 | plan tests => 71; 17 | } 18 | require "./t/util.pl"; 19 | } 20 | 21 | $| = 1; 22 | 23 | my $tfn = "_47cmnt.csv"; END { -f $tfn and unlink $tfn; } 24 | 25 | foreach my $cstr ("#", "//", "Comment", "\xe2\x98\x83") { 26 | foreach my $rest ("", " 1,2", "a,b") { 27 | 28 | my $csv = Text::CSV->new ({ binary => 1 }); 29 | $csv->comment_str ($cstr); 30 | 31 | my $fh; 32 | open $fh, ">", $tfn or die "$tfn: $!\n"; 33 | print $fh qq{$cstr$rest\n}; 34 | print $fh qq{c,$cstr\n}; 35 | print $fh qq{ $cstr\n}; 36 | print $fh qq{e,$cstr,$rest\n}; 37 | print $fh qq{$cstr\n}; 38 | print $fh qq{g,i$cstr\n}; 39 | print $fh qq{j,"k\n${cstr}k"\n}; 40 | print $fh qq{$cstr\n}; 41 | close $fh; 42 | 43 | open $fh, "<", $tfn or die "$tfn: $!\n"; 44 | 45 | my $cuni = Encode::decode ("utf-8", $cstr); 46 | my @rest = split m/,/ => $rest, -1; @rest or push @rest => ""; 47 | 48 | is_deeply ($csv->getline ($fh), [ "c", $cuni ], "$cstr , $rest"); 49 | is_deeply ($csv->getline ($fh), [ " $cuni" ], "leading space"); 50 | is_deeply ($csv->getline ($fh), [ "e", $cuni, @rest ], "not start of line"); 51 | is_deeply ($csv->getline ($fh), [ "g", "i$cuni" ], "not start of field"); 52 | is_deeply ($csv->getline ($fh), [ "j", "k\n${cuni}k" ], "in quoted field after NL"); 53 | 54 | close $fh; 55 | 56 | unlink $tfn; 57 | } 58 | } 59 | 60 | my $data = <<"EOC"; 61 | id | name 62 | # 63 | 42 | foo 64 | # 65 | EOC 66 | 67 | is_deeply (csv ( 68 | in => \$data, 69 | sep_char => "|", 70 | headers => "auto", 71 | allow_whitespace => 1, 72 | comment_str => "#", 73 | strict => 0, 74 | ), [{ id => 42, name => "foo" }], "Last record is comment"); 75 | is_deeply (csv ( 76 | in => \$data, 77 | sep_char => "|", 78 | headers => "auto", 79 | allow_whitespace => 1, 80 | comment_str => "#", 81 | strict => 1, 82 | ), [{ id => 42, name => "foo" }], "Last record is comment, under strict"); 83 | 84 | $data .= "3\n"; 85 | is_deeply (csv ( 86 | in => \$data, 87 | sep_char => "|", 88 | headers => "auto", 89 | allow_whitespace => 1, 90 | comment_str => "#", 91 | strict => 0, 92 | ), [{ id => 42, name => "foo" }, 93 | { id => 3, name => undef }, 94 | ], "Valid record past comment"); 95 | is_deeply (csv ( 96 | in => \$data, 97 | sep_char => "|", 98 | headers => "auto", 99 | allow_whitespace => 1, 100 | comment_str => "#", 101 | strict => 1, 102 | auto_diag => 0, # Suppress error 2014 103 | ), [{ id => 42, name => "foo" }], "Invalid record past comment, under strict"); 104 | is_deeply (csv ( 105 | in => \"# comment\n42 | foo\n53 | bar\n", 106 | sep_char => "|", 107 | allow_whitespace => 1, 108 | comment_str => "#", 109 | strict => 1, 110 | auto_diag => 1, 111 | ), [[ 42, "foo" ], [ 53, "bar" ]], "Comment on first line, under strict"); 112 | 113 | foreach my $io (1, 0) { 114 | my $csv = Text::CSV->new ({ 115 | strict => 1, 116 | comment_str => "#", 117 | sep_char => "|", 118 | auto_diag => 2, 119 | diag_verbose => 1, 120 | }); 121 | 122 | # Data line is required to set field count for strict 123 | if ($io) { 124 | is_deeply ($csv->getline (*DATA), [ "a", "b" ], "Comment on last line IO data"); 125 | is_deeply ($csv->getline (*DATA), undef, "Comment on last line IO comment"); 126 | } 127 | else { 128 | ok ($csv->parse ("a|b"), "Parse data line"); 129 | is_deeply ([ $csv->fields ], [ "a", "b" ], "Data in parse"); 130 | ok ($csv->parse ("# some comment"), "Parse comment"); 131 | is_deeply ([ $csv->fields ], [ ], "Comment in parse"); 132 | } 133 | } 134 | 135 | 1; 136 | __END__ 137 | a|b 138 | # some comment 139 | -------------------------------------------------------------------------------- /t/78_fragment.t: -------------------------------------------------------------------------------- 1 | #!/pro/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | $| = 1; 6 | 7 | use Config; 8 | use Test::More; 9 | 10 | BEGIN { 11 | unless (exists $Config{useperlio} && 12 | defined $Config{useperlio} && 13 | $] >= 5.008 && # perlio was experimental in 5.6.2, but not reliable 14 | $Config{useperlio} eq "define") { 15 | plan skip_all => "No reliable perlIO available"; 16 | } 17 | else { 18 | plan tests => 38; 19 | } 20 | } 21 | 22 | BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; } 23 | use Text::CSV; 24 | my $csv = Text::CSV->new (); 25 | 26 | my @test = ( 27 | "row=1" => [[ 11,12,13,14,15,16,17,18,19 ]], 28 | "row=2-3" => [[ 21,22,23,24,25,26,27,28,29 ], 29 | [ 31,32,33,34,35,36,37,38,39 ]], 30 | "row=2;4;6" => [[ 21,22,23,24,25,26,27,28,29 ], 31 | [ 41,42,43,44,45,46,47,48,49 ], 32 | [ 61,62,63,64,65,66,67,68,69 ]], 33 | "row=1-2;4;6-*" => [[ 11,12,13,14,15,16,17,18,19 ], 34 | [ 21,22,23,24,25,26,27,28,29 ], 35 | [ 41,42,43,44,45,46,47,48,49 ], 36 | [ 61,62,63,64,65,66,67,68,69 ], 37 | [ 71,72,73,74,75,76,77,78,79 ], 38 | [ 81,82,83,84,85,86,87,88,89 ], 39 | [ 91,92,93,94,95,96,97,98,99 ]], 40 | "col=1" => [[11],[21],[31],[41],[51],[61],[71],[81],[91]], 41 | "col=2-3" => [[12,13],[22,23],[32,33],[42,43],[52,53], 42 | [62,63],[72,73],[82,83],[92,93]], 43 | "col=2;4;6" => [[12,14,16],[22,24,26],[32,34,36],[42,44,46],[52,54,56], 44 | [62,64,66],[72,74,76],[82,84,86],[92,94,96]], 45 | "col=1-2;4;6-*" => [[11,12,14,16,17,18,19], [21,22,24,26,27,28,29], 46 | [31,32,34,36,37,38,39], [41,42,44,46,47,48,49], 47 | [51,52,54,56,57,58,59], [61,62,64,66,67,68,69], 48 | [71,72,74,76,77,78,79], [81,82,84,86,87,88,89], 49 | [91,92,94,96,97,98,99]], 50 | #cell=R,C 51 | "cell=7,7" => [[ 77 ]], 52 | "cell=7,7-8,8" => [[ 77,78 ], [ 87,88 ]], 53 | "cell=7,7-*,8" => [[ 77,78 ], [ 87,88 ], [ 97,98 ]], 54 | "cell=7,7-8,*" => [[ 77,78,79 ], [ 87,88,89 ]], 55 | "cell=7,7-*,*" => [[ 77,78,79 ], [ 87,88,89 ], [ 97,98,99 ]], 56 | 57 | "cell=7,7;7,8;8,7;8,8" => [[ 77,78 ], [ 87,88 ]], 58 | "cell=8,8;8,7;7,8;7,7" => [[ 77,78 ], [ 87,88 ]], 59 | 60 | "cell=1,1-2,2;3,3-4,4" => [ 61 | [11,12], 62 | [21,22], 63 | [33,34], 64 | [43,44]], 65 | "cell=1,1-3,3;2,3-4,4" => [ 66 | [11,12,13], 67 | [21,22,23,24], 68 | [31,32,33,34], 69 | [43,44]], 70 | "cell=1,1-3,3;2,2-4,4;2,3;4,2" => [ 71 | [11,12,13], 72 | [21,22,23,24], 73 | [31,32,33,34], 74 | [42,43,44]], 75 | "cell=1,1-2,2;3,3-4,4;1,4;4,1" => [ 76 | [11,12, 14], 77 | [21,22], 78 | [33,34], 79 | [41, 43,44]], 80 | ); 81 | my $todo = ""; 82 | my $data = join "" => ; 83 | while (my ($spec, $expect) = splice @test, 0, 2) { 84 | open my $io, "<", \$data or die "IO: $!\n"; 85 | my $aoa = $csv->fragment ($io, $spec); 86 | is_deeply ($aoa, $expect, "${todo}Fragment $spec"); 87 | } 88 | 89 | { $csv->column_names ("c3", "c4"); 90 | open my $io, "<", \$data or die "IO: $!\n"; 91 | is_deeply ($csv->fragment ($io, "cell=3,2-4,3"), 92 | [ { c3 => 32, c4 => 33 }, { c3 => 42, c4 => 43 }], "Fragment to AoH"); 93 | } 94 | { $csv->column_names ("C1", "C2"); 95 | open my $io, "<", \$data or die "IO: $!\n"; 96 | is_deeply ($csv->fragment ($io, "row=3"), 97 | [ { C1 => 31, C2 => 32 }], "Fragment row with headers to AoH"); 98 | } 99 | { $csv->column_names ("C1"); 100 | open my $io, "<", \$data or die "IO: $!\n"; 101 | is_deeply ($csv->fragment ($io, "col=2"), 102 | [ map +{ C1 => $_.2 } => 1 .. 9 ], "Fragment col with headers to AoH"); 103 | } 104 | 105 | $csv->column_names (undef); 106 | foreach my $spec ("col=1;3=2", "col=1,3-2", "col=-3", "col=0", "col=2--5", 107 | "col=0-2", "col=2-0", "col=2;;3") { 108 | open my $io, "<", \$data or die "IO: $!\n"; 109 | my $ref = eval { $csv->fragment ($io, "col=2;3=2"); }; 110 | is ($ref, undef, "Bad fragment spec"); 111 | is (0 + $csv->error_diag, 2013, "Error in spec"); 112 | } 113 | 114 | #$csv->eol ("\n"); 115 | #foreach my $r (1..9){$csv->print(*STDOUT,[map{$r.$_}1..9])} 116 | __END__ 117 | 11,12,13,14,15,16,17,18,19 118 | 21,22,23,24,25,26,27,28,29 119 | 31,32,33,34,35,36,37,38,39 120 | 41,42,43,44,45,46,47,48,49 121 | 51,52,53,54,55,56,57,58,59 122 | 61,62,63,64,65,66,67,68,69 123 | 71,72,73,74,75,76,77,78,79 124 | 81,82,83,84,85,86,87,88,89 125 | 91,92,93,94,95,96,97,98,99 126 | -------------------------------------------------------------------------------- /t/10_base.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; # use warnings core since 5.6 5 | 6 | use Test::More tests => 64; 7 | 8 | BEGIN { 9 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 10 | use_ok "Text::CSV"; 11 | plan skip_all => "Cannot load Text::CSV" if $@; 12 | } 13 | 14 | # empty subclass test 15 | # 16 | package Empty_Subclass; 17 | 18 | @Empty_Subclass::ISA = qw( Text::CSV ); 19 | 20 | package main; 21 | 22 | ok (new Text::CSV, "Indirect object notation"); 23 | 24 | # Important: Do not modify these tests unless you have a good 25 | # reason. This file ought to guarantee compatibility to Text::CSV. 26 | # 27 | my $empty = Empty_Subclass->new (); 28 | is (ref $empty, "Empty_Subclass", "Empty Subclass"); 29 | is ($empty->version (), Text::CSV->version (), "Version"); 30 | ok ($empty->parse (""), "Subclass parse ()"); 31 | ok ($empty->combine (""), "Subclass combine ()"); 32 | 33 | ok ($empty->new, "new () based on object"); 34 | 35 | my $csv; 36 | ok ($csv = Text::CSV->new, "new ()"); 37 | is ($csv->fields, undef, "fields () before parse ()"); 38 | is ($csv->string, undef, "string () undef before combine"); 39 | 40 | # Important: Do not modify these tests unless you have a good 41 | # reason. This file ought to guarantee compatibility to Text::CSV. 42 | # 43 | ok (1, "combine () & string () tests"); 44 | ok (!$csv->combine (), "Missing arguments"); 45 | ok (!$csv->combine ("abc", "def\n", "ghi"), "Bad character"); 46 | is ( $csv->error_input, "def\n", "Error_input ()"); 47 | ok ( $csv->combine (""), "Empty string - combine ()"); 48 | is ( $csv->string, '', "Empty string - string ()"); 49 | ok ( $csv->combine ("", " "), "Two fields, one space - combine ()"); 50 | is ( $csv->string, '," "', "Two fields, one space - string ()"); 51 | ok ( $csv->combine ("", 'I said, "Hi!"', ""), "Hi! - combine ()"); 52 | is ( $csv->string, ',"I said, ""Hi!""",', "Hi! - string ()"); 53 | ok ( $csv->combine ('"', "abc"), "abc - combine ()"); 54 | is ( $csv->string, '"""",abc', "abc - string ()"); 55 | ok ( $csv->combine (","), "comma - combine ()"); 56 | is ( $csv->string, '","', "comma - string ()"); 57 | ok ( $csv->combine ("abc", '"'), "abc + \" - combine ()"); 58 | is ( $csv->string, 'abc,""""', "abc + \" - string ()"); 59 | ok ( $csv->combine ("abc", "def", "ghi", "j,k"), "abc .. j,k - combine ()"); 60 | is ( $csv->string, 'abc,def,ghi,"j,k"', "abc .. j,k - string ()"); 61 | ok ( $csv->combine ("abc\tdef", "ghi"), "abc + TAB - combine ()"); 62 | is ( $csv->string, qq("abc\tdef",ghi), "abc + TAB - string ()"); 63 | 64 | ok (1, "parse () tests"); 65 | ok (!$csv->parse (), "Missing arguments"); 66 | ok ( $csv->parse ("\n"), "Single newline"); 67 | ok (!$csv->parse ('"abc'), "Missing closing \""); 68 | ok (!$csv->parse ('ab"c'), "\" outside of \"'s"); 69 | ok (!$csv->parse ('"ab"c"'), "Bad character sequence"); 70 | ok (!$csv->parse (qq("abc\nc")), "Bad character (NL)"); 71 | ok (!$csv->status (), "Wrong status ()"); 72 | ok ( $csv->parse ('","'), "comma - parse ()"); 73 | is ( scalar $csv->fields (), 1, "comma - fields () - count"); 74 | is (($csv->fields ())[0], ",", "comma - fields () - content"); 75 | ok ( $csv->parse (qq("","I said,\t""Hi!""","")), "Hi! - parse ()"); 76 | is ( scalar $csv->fields (), 3, "Hi! - fields () - count"); 77 | 78 | is (($csv->fields ())[0], "", "Hi! - fields () - field 1"); 79 | is (($csv->fields ())[1], qq(I said,\t"Hi!"), "Hi! - fields () - field 2"); 80 | is (($csv->fields ())[2], "", "Hi! - fields () - field 3"); 81 | ok ( $csv->status (), "status ()"); 82 | 83 | ok ( $csv->parse (""), "Empty line"); 84 | is ( scalar $csv->fields (), 1, "Empty - count"); 85 | is (($csv->fields ())[0], "", "One empty field"); 86 | 87 | # Are Integers and Reals quoted? 88 | # 89 | # Important: Do not modify these tests unless you have a good 90 | # reason. This file ought to guarantee compatibility to Text::CSV. 91 | # 92 | ok (1, "Integers and Reals"); 93 | ok ( $csv->combine ("", 2, 3.25, "a", "a b"), "Mixed - combine ()"); 94 | is ( $csv->string, ',2,3.25,a,"a b"', "Mixed - string ()"); 95 | 96 | # New from object 97 | ok ($csv->new (), "\$csv->new ()"); 98 | 99 | my $state; 100 | for ( [ 0, 0 ], 101 | [ 0, "foo" ], 102 | [ 0, {} ], 103 | [ 0, \0 ], 104 | [ 0, *STDOUT ], 105 | ) { 106 | eval { $state = $csv->print (@$_) }; 107 | ok (!$state, "print needs (IO, ARRAY_REF)"); 108 | ok ($@ =~ m/^Expected fields to be an array ref/, "Error msg"); 109 | } 110 | 111 | 1; 112 | -------------------------------------------------------------------------------- /t/50_utf8.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More; 7 | use charnames ":full"; 8 | 9 | BEGIN { 10 | if ($] < 5.008001) { 11 | plan skip_all => "UTF8 tests useless in this ancient perl version"; 12 | } 13 | else { 14 | plan tests => 93; 15 | } 16 | } 17 | 18 | BEGIN { 19 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 20 | require_ok "Text::CSV"; 21 | plan skip_all => "Cannot load Text::CSV" if $@; 22 | require "./t/util.pl"; 23 | } 24 | 25 | my $tfn = "_50test.csv"; END { -f $tfn and unlink $tfn; } 26 | # No binary => 1, as UTF8 is supposed to be allowed without it 27 | my $csv = Text::CSV->new ({ 28 | always_quote => 1, 29 | keep_meta_info => 1, 30 | }); 31 | 32 | # Special characters to check: 33 | # 0A = \n 2C = , 20 = 22 = " 34 | # 0D = \r 3B = ; 35 | foreach my $test ( 36 | # Space-like characters 37 | [ "\x{0000A0}", "U+0000A0 NO-BREAK SPACE" ], 38 | [ "\x{00200B}", "U+00200B ZERO WIDTH SPACE" ], 39 | # Some characters with possible problems in the code point 40 | [ "\x{000122}", "U+000122 LATIN CAPITAL LETTER G WITH CEDILLA" ], 41 | [ "\x{002C22}", "U+002C22 GLAGOLITIC CAPITAL LETTER SPIDERY HA" ], 42 | [ "\x{000A2C}", "U+000A2C GURMUKHI LETTER BA" ], 43 | [ "\x{000E2C}", "U+000E2C THAI CHARACTER LO CHULA" ], 44 | [ "\x{010A2C}", "U+010A2C KHAROSHTHI LETTER VA" ], 45 | # Characters with possible problems in the encoded representation 46 | # Should not be possible. ASCII is coded in 000..127, all other 47 | # characters in 128..255 48 | ) { 49 | my ($u, $msg) = @$test; 50 | ($u = "$u\x{0123}") =~ s/.$//; # Make sure it's marked UTF8 51 | my @in = ("", " ", $u, ""); 52 | my $exp = join ",", map { qq{"$_"} } @in; 53 | 54 | ok ($csv->combine (@in), "combine $msg"); 55 | 56 | my $str = $csv->string; 57 | is_binary ($str, $exp, "string $msg"); 58 | 59 | ok ($csv->parse ($str), "parse $msg"); 60 | my @out = $csv->fields; 61 | # Cannot use is_deeply (), because of the binary content 62 | is (scalar @in, scalar @out, "fields $msg"); 63 | is_binary ($in[$_], $out[$_], "field $_ $msg") for 0 .. $#in; 64 | } 65 | 66 | # Test if the UTF8 part is accepted, but the \n is not 67 | is ($csv->parse (qq{"\x{0123}\n\x{20ac}"}), 0, "\\n still needs binary"); 68 | is ($csv->binary, 0, "bin flag still unset"); 69 | is ($csv->error_diag + 0, 2021, "Error 2021"); 70 | 71 | open my $fh, ">:encoding(utf-8)", $tfn or die "$tfn: $!\n"; 72 | print $fh qq{"\N{LATIN CAPITAL LETTER O WITH STROKE}l/Vin",0\n}; 73 | close $fh; 74 | SKIP: { 75 | open my $fh, "<:encoding(utf-8)", $tfn or 76 | skip "Cannot open UTF-8 test file", 6; 77 | 78 | my $row; 79 | ok ($row = $csv->getline ($fh), "read/parse"); 80 | 81 | is ($csv->is_quoted (0), 1, "First field is quoted"); 82 | is ($csv->is_quoted (1), 0, "Second field is not quoted"); 83 | is ($csv->is_binary (0), 1, "First field is binary"); 84 | is ($csv->is_binary (1), 0, "Second field is not binary"); 85 | 86 | ok (utf8::valid ($row->[0]), "First field is valid utf8"); 87 | 88 | $csv->combine (@$row); 89 | ok (utf8::valid ($csv->string), "Combined string is valid utf8"); 90 | } 91 | 92 | # Test quote_binary 93 | $csv->always_quote (0); 94 | $csv->quote_space (0); 95 | $csv->quote_binary (0); 96 | ok ($csv->combine (" ", 1, "\x{20ac} "), "Combine"); 97 | is ($csv->string, qq{ ,1,\x{20ac} }, "String 0-0"); 98 | $csv->quote_binary (1); 99 | ok ($csv->combine (" ", 1, "\x{20ac} "), "Combine"); 100 | is ($csv->string, qq{ ,1,"\x{20ac} "}, "String 0-1"); 101 | 102 | $csv->quote_space (1); 103 | $csv->quote_binary (0); 104 | ok ($csv->combine (" ", 1, "\x{20ac} "), "Combine"); 105 | is ($csv->string, qq{" ",1,"\x{20ac} "}, "String 1-0"); 106 | ok ($csv->quote_binary (1), "quote binary on"); 107 | ok ($csv->combine (" ", 1, "\x{20ac} "), "Combine"); 108 | is ($csv->string, qq{" ",1,"\x{20ac} "}, "String 1-1"); 109 | 110 | ok ($csv->parse (qq{,1,"f\x{014d}o, 3""56",,bar,\r\n}), "example from XS"); 111 | is_deeply ([$csv->fields], [ 112 | "", 1, qq{f\x{014d}o, 3"56}, "", "bar", "" ], "content"); 113 | 114 | open $fh, ">:encoding(utf-8)", $tfn or die "$tfn: $!\n"; 115 | print $fh "euro\n\x{20ac}\neuro\n"; 116 | close $fh; 117 | open $fh, "<:encoding(utf-8)", $tfn or die "$tfn: $!\n"; 118 | 119 | SKIP: { 120 | my $out = ""; 121 | my $isutf8 = $] < 5.008001 ? 122 | sub { !$_[0]; } : # utf8::is_utf8 () not available in 5.8.0 123 | sub { utf8::is_utf8 ($out); }; 124 | ok ($csv->auto_diag (1), "auto diag"); 125 | ok ($csv->binary (1), "set binary"); 126 | ok ($csv->bind_columns (\$out), "bind"); 127 | ok ($csv->getline ($fh), "parse"); 128 | is ($csv->is_binary (0), 0, "not binary"); 129 | is ($out, "euro", "euro"); 130 | ok (!$isutf8->(1), "not utf8"); 131 | ok ($csv->getline ($fh), "parse"); 132 | is ($csv->is_binary (0), 1, "is binary"); 133 | is ($out, "\x{20ac}", "euro"); 134 | ok ($isutf8->(0), "is utf8"); 135 | ok ($csv->getline ($fh), "parse"); 136 | is ($csv->is_binary (0), 0, "not binary"); 137 | is ($out, "euro", "euro"); 138 | ok (!$isutf8->(1), "not utf8"); 139 | close $fh; 140 | } 141 | -------------------------------------------------------------------------------- /t/67_emptrow.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More; 7 | 8 | BEGIN { 9 | if ($] < 5.008001) { 10 | plan skip_all => "This test unit requires perl-5.8.1 or higher"; 11 | } 12 | else { 13 | plan tests => 56; 14 | } 15 | 16 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 17 | 18 | use_ok "Text::CSV", ("csv"); 19 | plan skip_all => "Cannot load Text::CSV" if $@; 20 | } 21 | my $tfn = "_67test.csv"; END { -f $tfn and unlink $tfn; } 22 | 23 | ok (my $csv = Text::CSV->new, "new"); 24 | 25 | is ($csv->skip_empty_rows, 0, "default"); 26 | is ($csv->skip_empty_rows (1), 1, "+1"); 27 | is ($csv->skip_empty_rows ("skip"), 1, "skip"); 28 | is ($csv->skip_empty_rows ("SKIP"), 1, "SKIP"); 29 | is ($csv->skip_empty_rows (2), "eof", "+2"); 30 | is ($csv->skip_empty_rows ("eof"), "eof", "eof"); 31 | is ($csv->skip_empty_rows ("EOF"), "eof", "EOF"); 32 | is ($csv->skip_empty_rows ("stop"), "eof", "stop"); 33 | is ($csv->skip_empty_rows ("STOP"), "eof", "STOP"); 34 | is ($csv->skip_empty_rows (3), "die", "+3"); 35 | is ($csv->skip_empty_rows ("die"), "die", "die"); 36 | is ($csv->skip_empty_rows ("DIE"), "die", "DIE"); 37 | is ($csv->skip_empty_rows (4), "croak", "+4"); 38 | is ($csv->skip_empty_rows ("croak"), "croak", "croak"); 39 | is ($csv->skip_empty_rows ("CROAK"), "croak", "CROAK"); 40 | is ($csv->skip_empty_rows (5), "error", "+5"); 41 | is ($csv->skip_empty_rows ("error"), "error", "error"); 42 | is ($csv->skip_empty_rows ("ERROR"), "error", "ERROR"); 43 | 44 | sub cba { [ 3, 42, undef, 3 ] } 45 | sub cbh { { a => 3, b => 42, c => undef, d => 3 } } 46 | 47 | is ($csv->skip_empty_rows (\&cba), \&cba, "callback"); 48 | 49 | is ($csv->skip_empty_rows (0), 0, "+0"); 50 | is ($csv->skip_empty_rows (undef), 0, "undef"); 51 | 52 | open my $fh, ">", $tfn or BAIL_OUT "$tfn: $!\n"; 53 | print $fh "a,b,c,d\n"; 54 | print $fh "1,2,0,4\n"; 55 | print $fh "4,0,9,1\n"; 56 | print $fh "\n"; 57 | print $fh "8,2,7,1\n"; 58 | print $fh "\n"; 59 | print $fh "\n"; 60 | print $fh "5,7,9,3\n"; 61 | print $fh "\n"; 62 | close $fh; 63 | 64 | my @parg = (auto_diag => 0, in => $tfn); 65 | my @head = ([qw( a b c d )], [1,2,0,4], [4,0,9,1]); 66 | my @repl = (1..4); 67 | my $ea = \@repl; 68 | 69 | # Array behavior 70 | is_deeply (csv (@parg, skip_empty_rows => 0), [ @head, 71 | [""],[8,2,7,1],[""],[""],[5,7,9,3],[""]], "A Default"); 72 | 73 | is_deeply (csv (@parg, skip_empty_rows => 1), [ @head, 74 | [8,2,7,1],[5,7,9,3]], "A Skip"); 75 | 76 | is_deeply (csv (@parg, skip_empty_rows => 2), \@head, "A EOF"); 77 | 78 | is (eval { csv (@parg, skip_empty_rows => 3); }, undef, "A die"); 79 | like ($@, qr{^Empty row}, "A msg"); 80 | 81 | is (eval { csv (@parg, skip_empty_rows => 4); }, undef, "A croak"); 82 | like ($@, qr{^Empty row}, "A msg"); 83 | 84 | $@ = ""; 85 | $csv = Text::CSV->new ({ skip_empty_rows => 5 }); 86 | is_deeply ($csv->csv (@parg), \@head, "A error"); 87 | is ($@, "", "A msg"); 88 | is (0 + $csv->error_diag, 2015, "A code"); 89 | 90 | is_deeply (csv (@parg, skip_empty_rows => sub {\@repl}), [ @head, 91 | $ea,[8,2,7,1],$ea,$ea,[5,7,9,3],$ea], "A Callback"); 92 | is_deeply (csv (@parg, skip_empty_rows => sub {0}), \@head, "A Callback 0"); 93 | 94 | # Array behavior (line by line) 95 | open $fh, "<", $tfn; 96 | $csv = Text::CSV->new ({ skip_empty_rows => 1 }); 97 | while (my $row = $csv->getline ($fh)) { 98 | ok (@$row, "Row has columns"); 99 | } 100 | close $fh; 101 | 102 | # Hash behavior 103 | push @parg => bom => 1; 104 | my $eh = { a => "", b => undef, c => undef, d => undef }, 105 | @head = ({ a => 1, b => 2, c => 0, d => 4 }, 106 | { a => 4, b => 0, c => 9, d => 1 }); 107 | is_deeply (csv (@parg, skip_empty_rows => 0), [ @head, $eh, 108 | { a => 8, b => 2, c => 7, d => 1 },$eh,$eh, 109 | { a => 5, b => 7, c => 9, d => 3 },$eh], "H Default"); 110 | 111 | is_deeply (csv (@parg, skip_empty_rows => 1), [ @head, 112 | { a => 8, b => 2, c => 7, d => 1 }, 113 | { a => 5, b => 7, c => 9, d => 3 }], "H Skip"); 114 | 115 | is_deeply (csv (@parg, skip_empty_rows => 2), \@head, "H EOF"); 116 | 117 | is (eval { csv (@parg, skip_empty_rows => 3); }, undef, "H die"); 118 | like ($@, qr{^Empty row}, "H msg"); 119 | 120 | is (eval { csv (@parg, skip_empty_rows => 4); }, undef, "H croak"); 121 | like ($@, qr{^Empty row}, "H msg"); 122 | 123 | $@ = ""; 124 | $csv = Text::CSV->new ({ skip_empty_rows => 5 }); 125 | is_deeply ($csv->csv (@parg), \@head, "H error"); 126 | is ($@, "", "H msg"); 127 | is (0 + $csv->error_diag, 2015, "H code"); 128 | 129 | $eh = { a => 1, b => 2, c => 3, d => 4 }; 130 | is_deeply (csv (@parg, skip_empty_rows => sub {\@repl}), [ @head, $eh, 131 | { a => 8, b => 2, c => 7, d => 1 },$eh,$eh, 132 | { a => 5, b => 7, c => 9, d => 3 },$eh], "H Callback"); 133 | 134 | is_deeply (csv (@parg, skip_empty_rows => sub {0}), \@head, "H Callback 0"); 135 | 136 | # Hash behavior (line by line) 137 | open $fh, "<", $tfn; 138 | $csv = Text::CSV->new ({ skip_empty_rows => 1 }); 139 | my $cols = $csv->getline ($fh); 140 | $csv->column_names (@$cols); 141 | while (my $row = $csv->getline_hr ($fh)) { 142 | isnt ($row->{a}, undef, "Column 'a' is defined"); 143 | } 144 | close $fh; 145 | -------------------------------------------------------------------------------- /author/bin/sync_tests.pl: -------------------------------------------------------------------------------- 1 | # This script is to sync tests for Text::CSV with the ones for Text::CSV_XS 2 | 3 | use strict; 4 | use warnings; 5 | use FindBin; 6 | use lib "$FindBin::Bin/../../lib"; 7 | use Path::Tiny; 8 | 9 | my $root = path("$FindBin::Bin/../.."); 10 | my $xs_root = $root->parent->child('Text-CSV_XS'); 11 | my $test_dir = $root->child('t'); 12 | 13 | die "Text::CSV_XS directory not found" unless -d $xs_root; 14 | 15 | for my $xs_test ($xs_root->child('t')->children) { 16 | my $basename = $xs_test->basename; 17 | my $pp_test = $test_dir->child($basename); 18 | if ($basename =~ /\.t$/) { 19 | next if $basename =~ /01_pod/; 20 | my $content = $xs_test->slurp; 21 | 22 | # general stuff ------------------------------------------- 23 | 24 | # $content =~ s|^#!/(usr|pro)/bin/perl\n+||s; 25 | $content =~ s!^(\s+)(use|require)_ok!$1\$ENV{PERL_TEXT_CSV} = \$ENV{TEST_PERL_TEXT_CSV} || 0;\n$1$2_ok!m; 26 | $content =~ s/Text::CSV_XS(::|\->|;| |\.|["',]|$)/Text::CSV$1/mg; 27 | 28 | # warnings ------------------------------------------------- 29 | 30 | $content =~ s|use warnings;|\$^W = 1;|; 31 | if ($basename =~ /10_base|12_acc|15_flags/) { 32 | $content =~ s|\$\^W = 1;|\$^W = 1; # use warnings core since 5.6|; 33 | } 34 | if ($basename =~ /20_file|21_lexicalio|22_scalario/) { 35 | $content =~ s|\$\^W = 1;|\$^W = 1; # use warnings;|; 36 | } 37 | 38 | # skip_all ------------------------------------------------- 39 | 40 | if ($basename =~ /21_lexicalio/) { 41 | $content =~ s|use Test::More tests => (\d+);|use Test::More;\n\nBEGIN {\n if (\$] < 5.006) {\n plan skip_all => "No lexical file handles in in this ancient perl version";\n }\n else {\n plan tests => $1;\n }\n}|; 42 | } 43 | 44 | # specific ------------------------------------------------- 45 | 46 | if ($basename =~ /00_pod/) { 47 | $content = qq{print STDERR "# PERL_TEXT_CSV: ", (defined \$ENV{PERL_TEXT_CSV} ? "\$ENV{PERL_TEXT_CSV}" : "undef"), "\\n";\n}.$content; 48 | } 49 | 50 | if ($basename =~ /12_acc/) { 51 | $content =~ s/(my \$csv;)/my \$Backend = Text::CSV->backend;\n\n$1/; 52 | $content =~ s/(usage: my \\\$csv =) Text::CSV/${1} \$Backend/; 53 | } 54 | 55 | if ($basename =~ /15_flags/) { 56 | $content =~ s/tests => 225/tests => 229/; 57 | $content =~ s/my \$bintxt = chr \(0x20ac\)/my \$bintxt = chr (\$] < 5.006 ? 0xbf : 0x20ac)/; 58 | 59 | $content .= <<'EOT'; 60 | # https://rt.cpan.org/Public/Bug/Display.html?id=109097 61 | ok (1, "Testing quote_char as undef"); 62 | { my $csv = Text::CSV->new ({ quote_char => undef }); 63 | is ($csv->escape_char, '"', "Escape Char defaults to double quotes"); 64 | ok ($csv->combine ('space here', '"quoted"', '"quoted and spaces"'), "Combine"); 65 | is ($csv->string, q{space here,""quoted"",""quoted and spaces""}, "String"); 66 | } 67 | EOT 68 | } 69 | 70 | if ($basename =~ /(?:41_null|47_comment|78_fragment)/) { 71 | $content =~ s/(use Text::CSV)/BEGIN { \$ENV{PERL_TEXT_CSV} = \$ENV{TEST_PERL_TEXT_CSV} || 0; }\n$1/; 72 | } 73 | 74 | if ($basename =~ /(?:68_header)/) { 75 | $content =~ s/done_testing;//; 76 | } 77 | 78 | if ($basename =~ /(?:71_strict)/) { 79 | $content =~ s!"CSV_XS.xs" or die "Cannot read error messages from XS!"lib/Text/CSV_PP.pm" or die "Cannot read error messages from PP!; 80 | $content =~ s!\Qm/^ \{ ([0-9]{4}), "([^"]+)"\s+\}/!m/^ ([0-9]{4}) => "([^"]+)",/!; 81 | } 82 | 83 | if ($basename =~ /80_diag/) { 84 | $content =~ s!open my \$fh, "<", "CSV_XS.xs"!open my \$fh, "<", "lib/Text/CSV_PP.pm"!; 85 | $content =~ s!Cannot read error messages from XS!Cannot read error messages from PP!; 86 | $content =~ s!^\tm/\^ \\\{ \(\[0\-9\]\{4\}\), "\(\[\^"\]\+\)"\\s\+\\\}/! m/^\\s+([0-9]{4}) => "([^"]+)"/!m; 87 | $content =~ s!CSV_XS ERROR!CSV_(?:PP|XS) ERROR!g; 88 | } 89 | 90 | if ($basename =~ /81_subclass/) { 91 | $content =~ s/(package Text::CSV::Subclass;)/$1\n\nBEGIN {\n \$ENV{PERL_TEXT_CSV} = \$ENV{TEST_PERL_TEXT_CSV} || 0;\n}\n\nBEGIN { require Text::CSV; }\t# needed for perl5.005/; 92 | } 93 | 94 | die "Need to modify $basename to include PERL_TEXT_ENV check" unless $content =~ /\$ENV\{PERL_TEXT_CSV\} =/; 95 | $pp_test->spew($content); 96 | print STDERR "copied $xs_test to $pp_test\n"; 97 | next; 98 | } 99 | if ($basename =~ /\.pl$/) { 100 | $xs_test->copy($pp_test); 101 | print STDERR "copied $xs_test to $pp_test\n"; 102 | } 103 | print STDERR "Skipped $xs_test\n"; 104 | } 105 | 106 | sub _todo { 107 | my ($content, @line_nos) = @_; 108 | my @lines = split /\n/, $content; 109 | for my $line_no (@line_nos) { 110 | $lines[$line_no - 1] = "#TODO: $lines[$line_no - 1]"; 111 | } 112 | join "\n", @lines, ""; 113 | } 114 | 115 | sub _skip { 116 | my ($content, @line_nos) = @_; 117 | my @lines = split /\n/, $content; 118 | for my $line_no (@line_nos) { 119 | if (!ref $line_no) { 120 | $lines[$line_no - 1] = "TODO:{local \$TODO = 'failing'; $lines[$line_no - 1]}"; 121 | } else { 122 | my ($start, $end) = @$line_no; 123 | $lines[$start - 1] = "TODO:{local \$TODO = 1; $lines[$start - 1]"; 124 | $lines[$end - 1] = "$lines[$end - 1]}"; 125 | } 126 | } 127 | join "\n", @lines, ""; 128 | } 129 | 130 | sub _comment_out { 131 | my ($content, $key, @line_nos) = @_; 132 | my @lines = split /\n/, $content; 133 | for my $line_no (@line_nos) { 134 | $lines[$line_no - 1] = "#$key: $lines[$line_no - 1]"; 135 | } 136 | join "\n", @lines; 137 | } 138 | -------------------------------------------------------------------------------- /t/79_callbacks.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More tests => 111; 7 | #use Test::More "no_plan"; 8 | 9 | BEGIN { 10 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 11 | require_ok "Text::CSV"; 12 | plan skip_all => "Cannot load Text::CSV" if $@; 13 | require "./t/util.pl"; 14 | } 15 | 16 | $| = 1; 17 | 18 | my $csv; 19 | my $tfn = "_79test.csv"; END { -f $tfn and unlink $tfn; } 20 | 21 | # These tests are for the constructor 22 | { my $warn; 23 | local $SIG{__WARN__} = sub { $warn = shift; }; 24 | ok ($csv = Text::CSV->new ({ callbacks => undef }), "new"); 25 | is ($warn, undef, "no warn for undef"); 26 | is ($csv->callbacks, $warn = undef, "no callbacks for undef"); 27 | ok ($csv = Text::CSV->new ({ callbacks => 0 }), "new"); 28 | like ($warn, qr{: ignored\n}, "warn for 0"); 29 | is ($csv->callbacks, $warn = undef, "no callbacks for 0"); 30 | ok ($csv = Text::CSV->new ({ callbacks => 1 }), "new"); 31 | like ($warn, qr{: ignored\n}, "warn for 1"); 32 | is ($csv->callbacks, $warn = undef, "no callbacks for 1"); 33 | ok ($csv = Text::CSV->new ({ callbacks => \1 }), "new"); 34 | like ($warn, qr{: ignored\n}, "warn for \\1"); 35 | is ($csv->callbacks, $warn = undef, "no callbacks for \\1"); 36 | ok ($csv = Text::CSV->new ({ callbacks => "" }), "new"); 37 | like ($warn, qr{: ignored\n}, "warn for ''"); 38 | is ($csv->callbacks, $warn = undef, "no callbacks for ''"); 39 | ok ($csv = Text::CSV->new ({ callbacks => [] }), "new"); 40 | like ($warn, qr{: ignored\n}, "warn for []"); 41 | is ($csv->callbacks, $warn = undef, "no callbacks for []"); 42 | ok ($csv = Text::CSV->new ({ callbacks => sub {} }), "new"); 43 | like ($warn, qr{: ignored\n}, "warn for sub {}"); 44 | is ($csv->callbacks, $warn = undef, "no callbacks for sub {}"); 45 | } 46 | 47 | ok ($csv = Text::CSV->new (), "new"); 48 | is ($csv->callbacks, undef, "no callbacks"); 49 | ok ($csv->bind_columns (\my ($c, $s)), "bind"); 50 | ok ($csv->getline (*DATA), "parse ok"); 51 | is ($c, 1, "key"); 52 | is ($s, "foo", "value"); 53 | $s = "untouched"; 54 | ok ($csv->getline (*DATA), "parse bad"); 55 | is ($c, 1, "key"); 56 | is ($s, "untouched", "untouched"); 57 | ok ($csv->getline (*DATA), "parse bad"); 58 | is ($c, "foo", "key"); 59 | is ($s, "untouched", "untouched"); 60 | ok ($csv->getline (*DATA), "parse good"); 61 | is ($c, 2, "key"); 62 | is ($s, "bar", "value"); 63 | eval { is ($csv->getline (*DATA), undef,"parse bad"); }; 64 | my @diag = $csv->error_diag; 65 | is ($diag[0], 3006, "too many values"); 66 | 67 | # These tests are for the method 68 | foreach my $args ([""], [1], [[]], [sub{}], [1,2], [1,2,3], 69 | [undef,"error"], ["error",undef], 70 | ["%23bad",sub {}], ["error",sub{0;},undef,1], 71 | ["error",[]], ["error","error"], ["",sub{0;}], 72 | [sub{0;},0], [[],""]) { 73 | eval { $csv->callbacks (@$args); }; 74 | my @diag = $csv->error_diag; 75 | is ($diag[0], 1004, "invalid callbacks"); 76 | is ($csv->callbacks, undef, "not set"); 77 | } 78 | 79 | # These tests are for invalid arguments *inside* the hash 80 | foreach my $arg (undef, 0, 1, \1, "", [], $csv) { 81 | eval { $csv->callbacks ({ error => $arg }); }; 82 | my @diag = $csv->error_diag; 83 | is ($diag[0], 1004, "invalid callbacks"); 84 | is ($csv->callbacks, undef, "not set"); 85 | } 86 | ok ($csv->callbacks (bogus => sub { 0; }), "useless callback"); 87 | 88 | my $error = 3006; 89 | sub ignore { 90 | is ($_[0], $error, "Caught error $error"); 91 | $csv->SetDiag (0); # Ignore this error 92 | } # ignore 93 | 94 | my $idx = 1; 95 | ok ($csv->auto_diag (1), "set auto_diag"); 96 | my $callbacks = { 97 | error => \&ignore, 98 | after_parse => sub { 99 | my ($c, $av) = @_; 100 | # Just add a field 101 | push @$av, "NEW"; 102 | }, 103 | before_print => sub { 104 | my ($c, $av) = @_; 105 | # First field set to line number 106 | $av->[0] = $idx++; 107 | # Maximum 2 fields 108 | @{$av} > 2 and splice @{$av}, 2; 109 | # Minimum 2 fields 110 | @{$av} < 2 and push @{$av}, ""; 111 | }, 112 | }; 113 | is (ref $csv->callbacks ($callbacks), "HASH", "callbacks set"); 114 | ok ($csv->getline (*DATA), "parse ok"); 115 | is ($c, 1, "key"); 116 | is ($s, "foo", "value"); 117 | ok ($csv->getline (*DATA), "parse bad, skip 3006"); 118 | ok ($csv->getline (*DATA), "parse good"); 119 | is ($c, 2, "key"); 120 | is ($s, "bar", "value"); 121 | 122 | $csv->bind_columns (undef); 123 | ok (my $row = $csv->getline (*DATA), "get row"); 124 | is_deeply ($row, [ 1, 2, 3, "NEW" ], "fetch + value from hook"); 125 | 126 | $error = 2012; # EOF 127 | ok ($csv->getline (*DATA), "parse past eof"); 128 | 129 | ok ($csv->eol ("\n"), "eol for output"); 130 | open my $fh, ">", $tfn or die "$tfn: $!"; 131 | ok ($csv->print ($fh, [ 0, "foo" ]), "print OK"); 132 | ok ($csv->print ($fh, [ 0, "bar", 3 ]), "print too many"); 133 | ok ($csv->print ($fh, [ 0 ]), "print too few"); 134 | close $fh; 135 | 136 | open $fh, "<", $tfn or die "$tfn: $!"; 137 | is (do { local $/; <$fh> }, "1,foo\n2,bar\n3,\n", "Modified output"); 138 | close $fh; 139 | 140 | # Test the non-IO interface 141 | ok ($csv->parse ("10,blah,33\n"), "parse"); 142 | is_deeply ([ $csv->fields ], [ 10, "blah", 33, "NEW" ], "fields"); 143 | 144 | ok ($csv->combine (11, "fri", 22, 18), "combine - no hook"); 145 | is ($csv->string, qq{11,fri,22,18\n}, "string"); 146 | 147 | is ($csv->callbacks (undef), undef, "clear callbacks"); 148 | 149 | is_deeply (Text::CSV::csv (in => $tfn, callbacks => $callbacks), 150 | [[1,"foo","NEW"],[2,"bar","NEW"],[3,"","NEW"]], "using getline_all"); 151 | 152 | open $fh, ">", $tfn or die "$tfn: $!\n"; 153 | print $fh <<"EOC"; 154 | 1,foo 155 | 2,bar 156 | 3,baz 157 | 4,zoo 158 | EOC 159 | close $fh; 160 | 161 | open $fh, "<", $tfn or die "$tfn: $!\n"; 162 | $csv->callbacks (after_parse => sub { $_[1][0] eq 3 and return \"skip" }); 163 | is_deeply ($csv->getline_all ($fh), [[1,"foo"],[2,"bar"],[4,"zoo"]], "skip"); 164 | close $fh; 165 | 166 | __END__ 167 | 1,foo 168 | 1 169 | foo 170 | 2,bar 171 | 3,baz,2 172 | 1,foo 173 | 3,baz,2 174 | 2,bar 175 | 1,2,3 176 | -------------------------------------------------------------------------------- /t/util.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | 3 | my %special = ( 9 => "\\t", 10 => "\\n", 13 => "\\r" ); 4 | my $ebcdic = ord ("A") == 0xc1; 5 | my @ebcdic = (# Convert EBCDIC 2 ASCII 6 | 0x00, 0x01, 0x02, 0x03, 0x9c, 0x09, 0x86, 0x7f, 0x97, 0x8d, 0x8e, 0x0b, 7 | 0x0c, 0x0d, 0x0e, 0x0f, 0x10, 0x11, 0x12, 0x13, 0x9d, 0x0a, 0x08, 0x87, 8 | 0x18, 0x19, 0x92, 0x8f, 0x1c, 0x1d, 0x1e, 0x1f, 0x80, 0x81, 0x82, 0x83, 9 | 0x84, 0x85, 0x17, 0x1b, 0x88, 0x89, 0x8a, 0x8b, 0x8c, 0x05, 0x06, 0x07, 10 | 0x90, 0x91, 0x16, 0x93, 0x94, 0x95, 0x96, 0x04, 0x98, 0x99, 0x9a, 0x9b, 11 | 0x14, 0x15, 0x9e, 0x1a, 0x20, 0xa0, 0xe2, 0xe4, 0xe0, 0xe1, 0xe3, 0xe5, 12 | 0xe7, 0xf1, 0xa2, 0x2e, 0x3c, 0x28, 0x2b, 0x7c, 0x26, 0xe9, 0xea, 0xeb, 13 | 0xe8, 0xed, 0xee, 0xef, 0xec, 0xdf, 0x21, 0x24, 0x2a, 0x29, 0x3b, 0x5e, 14 | 0x2d, 0x2f, 0xc2, 0xc4, 0xc0, 0xc1, 0xc3, 0xc5, 0xc7, 0xd1, 0xa6, 0x2c, 15 | 0x25, 0x5f, 0x3e, 0x3f, 0xf8, 0xc9, 0xca, 0xcb, 0xc8, 0xcd, 0xce, 0xcf, 16 | 0xcc, 0x60, 0x3a, 0x23, 0x40, 0x27, 0x3d, 0x22, 0xd8, 0x61, 0x62, 0x63, 17 | 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0xab, 0xbb, 0xf0, 0xfd, 0xfe, 0xb1, 18 | 0xb0, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, 0x70, 0x71, 0x72, 0xaa, 0xba, 19 | 0xe6, 0xb8, 0xc6, 0xa4, 0xb5, 0x7e, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 20 | 0x79, 0x7a, 0xa1, 0xbf, 0xd0, 0x5b, 0xde, 0xae, 0xac, 0xa3, 0xa5, 0xb7, 21 | 0xa9, 0xa7, 0xb6, 0xbc, 0xbd, 0xbe, 0xdd, 0xa8, 0xaf, 0x5d, 0xb4, 0xd7, 22 | 0x7b, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0xad, 0xf4, 23 | 0xf6, 0xf2, 0xf3, 0xf5, 0x7d, 0x4a, 0x4b, 0x4c, 0x4d, 0x4e, 0x4f, 0x50, 24 | 0x51, 0x52, 0xb9, 0xfb, 0xfc, 0xf9, 0xfa, 0xff, 0x5c, 0xf7, 0x53, 0x54, 25 | 0x55, 0x56, 0x57, 0x58, 0x59, 0x5a, 0xb2, 0xd4, 0xd6, 0xd2, 0xd3, 0xd5, 26 | 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0xb3, 0xdb, 27 | 0xdc, 0xd9, 0xda, 0x9f ); 28 | 29 | sub _readable { 30 | defined $_[0] or return "--undef--"; 31 | join "", map { 32 | my $cp = ord $_; 33 | $ebcdic and $cp = $ebcdic[$cp]; 34 | $cp >= 0x20 && $cp <= 0x7e 35 | ? $_ 36 | : $special{$cp} || sprintf "\\x{%02x}", $cp 37 | } split m//, $_[0]; 38 | } # _readable 39 | 40 | sub is_binary { 41 | my ($str, $exp, $tst) = @_; 42 | if ($str eq $exp) { 43 | ok (1, $tst); 44 | } 45 | else { 46 | my ($hs, $he) = map { _readable $_ } $str, $exp; 47 | is ($hs, $he, $tst); 48 | } 49 | } # is_binary 50 | 51 | # The rest is a modified copy of CORE's t/charset_tools.pl 52 | my @utf8_skip = $ebcdic ? ( 53 | # This translates a utf-8-encoded byte into how many 54 | # bytes the full utf8 character occupies. 55 | 56 | # 0 1 2 3 4 5 6 7 8 9 A B C D E F 57 | 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 0 58 | 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 1 59 | 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 2 60 | 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 3 61 | 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 4 62 | 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 5 63 | 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 6 64 | 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, # 7 65 | -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, # 8 66 | -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, # 9 67 | -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, # A 68 | -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1, # B 69 | -1,-1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, # C 70 | 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, # D 71 | 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, # E 72 | 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 6, 6, 7,13, # F 73 | ) : (); 74 | 75 | # Used for BOM testing 76 | *byte_utf8a_to_utf8n = $ebcdic ? sub { 77 | # Convert a UTF-8 byte sequence into the platform's native UTF-8 78 | # equivalent, currently only UTF-8 and UTF-EBCDIC. 79 | 80 | my $string = shift; 81 | utf8::is_utf8 ($string) and return $string; 82 | 83 | my $length = length $string; 84 | #diag ($string); 85 | #diag ($length); 86 | my $out = ""; 87 | for (my $i = 0; $i < $length; $i++) { 88 | my $byte = ord substr $string, $i, 1; 89 | my $byte_count = $utf8_skip[$byte]; 90 | #diag ($byte); 91 | #diag ($byte_count); 92 | 93 | $byte_count < 0 and die "Illegal start byte"; 94 | ($i + $byte_count) > $length and 95 | die "Attempt to read " . ($i + $byte_count - $length) . " beyond end-of-string"; 96 | 97 | # Just translate UTF-8 invariants directly. 98 | if ($byte_count == 1) { 99 | $out .= chr utf8::unicode_to_native ($byte); 100 | next; 101 | } 102 | 103 | # Otherwise calculate the code point ordinal represented by the 104 | # sequence beginning with this byte, using the algorithm adapted from 105 | # utf8.c. We absorb each byte in the sequence as we go along 106 | my $ord = $byte & (0x1F >> ($byte_count - 2)); 107 | my $bytes_remaining = $byte_count - 1; 108 | while ($bytes_remaining > 0) { 109 | $byte = ord substr $string, ++$i, 1; 110 | ($byte & 0xC0) == 0x80 or 111 | die sprintf "byte '%X' is not a valid continuation", $byte; 112 | $ord = $ord << 6 | ($byte & 0x3f); 113 | $bytes_remaining--; 114 | } 115 | #diag ($byte); 116 | #diag ($ord); 117 | 118 | my $expected_bytes = 119 | $ord < 0x00000080 ? 1 : 120 | $ord < 0x00000800 ? 2 : 121 | $ord < 0x00010000 ? 3 : 122 | $ord < 0x00200000 ? 4 : 123 | $ord < 0x04000000 ? 5 : 124 | $ord < 0x80000000 ? 6 : 7; #: (uv) < UTF8_QUAD_MAX ? 7 : 13 ) 125 | 126 | # Make sure is not an overlong sequence 127 | $byte_count == $expected_bytes or 128 | die sprintf "character U+%X should occupy %d bytes, not %d", 129 | $ord, $expected_bytes, $byte_count; 130 | 131 | # Now that we have found the code point the original UTF-8 meant, we 132 | # use the native chr function to get its native string equivalent. 133 | $out .= chr utf8::unicode_to_native ($ord); 134 | } 135 | 136 | utf8::encode ($out); # Turn off utf8 flag. 137 | #diag ($out); 138 | return $out; 139 | } : sub { return shift }; 140 | 141 | 1; 142 | -------------------------------------------------------------------------------- /t/66_formula.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More tests => 119; 7 | 8 | BEGIN { 9 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 10 | use_ok "Text::CSV", (); 11 | plan skip_all => "Cannot load Text::CSV" if $@; 12 | } 13 | my $tfn = "_66test.csv"; END { -f $tfn and unlink $tfn; } 14 | 15 | ok (my $csv = Text::CSV->new, "new"); 16 | 17 | is ($csv->formula, "none", "default"); 18 | is ($csv->formula (1), "die", "die"); 19 | is ($csv->formula ("die"), "die", "die"); 20 | is ($csv->formula (2), "croak", "croak"); 21 | is ($csv->formula ("croak"), "croak", "croak"); 22 | is ($csv->formula (3), "diag", "diag"); 23 | is ($csv->formula ("diag"), "diag", "diag"); 24 | is ($csv->formula (4), "empty", "empty"); 25 | is ($csv->formula ("empty"), "empty", "empty"); 26 | is ($csv->formula (""), "empty", "explicit empty"); 27 | is ($csv->formula (5), "undef", "undef"); 28 | is ($csv->formula ("undef"), "undef", "undef"); 29 | is ($csv->formula (undef), "undef", "explicit undef"); 30 | is ($csv->formula (sub { }), "cb", "callback"); 31 | is ($csv->formula (0), "none", "none"); 32 | is ($csv->formula ("none"), "none", "none"); 33 | 34 | is ($csv->formula_handling, "none", "default"); 35 | is ($csv->formula_handling ("DIE"), "die", "die"); 36 | is ($csv->formula_handling ("CROAK"), "croak", "croak"); 37 | is ($csv->formula_handling ("DIAG"), "diag", "diag"); 38 | is ($csv->formula_handling ("EMPTY"), "empty", "empty"); 39 | is ($csv->formula_handling ("UNDEF"), "undef", "undef"); 40 | is ($csv->formula_handling ("NONE"), "none", "none"); 41 | 42 | foreach my $f (-1, 9, "xxx", "DIAX", [], {}) { 43 | eval { $csv->formula ($f); }; 44 | like ($@, qr/\bformula-handling '\Q$f\E' is not supported/, "$f in invalid"); 45 | } 46 | 47 | my %f = qw( 48 | 0 none none none 49 | 1 die die die 50 | 2 croak croak croak 51 | 3 diag diag diag 52 | 4 empty empty empty 53 | 5 undef undef undef 54 | ); 55 | foreach my $f (sort keys %f) { 56 | ok (my $p = Text::CSV->new ({ formula => $f }), "new with $f"); 57 | is ($p->formula, $f{$f}, "Set to $f{$f}"); 58 | } 59 | eval { Text::CSV->new ({ formula => "xxx" }); }; 60 | like ($@, qr/\bformula-handling 'xxx' is not supported/, "xxx is invalid"); 61 | 62 | # TODO : $csv->formula (sub { 42; }); 63 | 64 | # Parser 65 | 66 | my @data = split m/\n/ => <<"EOC"; 67 | a,b,c 68 | 1,2,3 69 | =1+2,3,4 70 | 1,=2+3,4 71 | 1,2,=3+4 72 | EOC 73 | 74 | sub parse { 75 | my $f = shift; 76 | my @d; 77 | ok (my $csv = Text::CSV->new ({ formula => $f }), "new $f"); 78 | #diag ("Formula: ". $csv->formula); 79 | for (@data) { 80 | $csv->parse ($_); 81 | push @d, [ $csv->fields ]; 82 | } 83 | \@d; 84 | } # parse 85 | 86 | is_deeply (parse (0), [ 87 | [ "a", "b", "c", ], 88 | [ "1", "2", "3", ], 89 | [ "=1+2", "3", "4", ], 90 | [ "1", "=2+3", "4", ], 91 | [ "1", "2", "=3+4", ], 92 | ], "Default"); 93 | 94 | my $r = eval { parse (1) }; 95 | is ($r, undef, "Die on formulas"); 96 | is ($@, "Formulas are forbidden\n", "Message"); 97 | $@ = undef; 98 | 99 | $r = eval { parse (2) }; 100 | is ($r, undef, "Croak on formulas"); 101 | is ($@, "Formulas are forbidden\n", "Message"); 102 | $@ = undef; 103 | 104 | my @m; 105 | local $SIG{__WARN__} = sub { push @m, @_ }; 106 | 107 | is_deeply (parse (3), [ 108 | [ "a", "b", "c", ], 109 | [ "1", "2", "3", ], 110 | [ "=1+2", "3", "4", ], 111 | [ "1", "=2+3", "4", ], 112 | [ "1", "2", "=3+4", ], 113 | ], "Default"); 114 | is ($@, undef, "Legal with warnings"); 115 | is_deeply (\@m, [ 116 | "Field 1 in record 3 contains formula '=1+2'\n", 117 | "Field 2 in record 4 contains formula '=2+3'\n", 118 | "Field 3 in record 5 contains formula '=3+4'\n", 119 | ], "Warnings"); 120 | @m = (); 121 | 122 | is_deeply (parse (4), [ 123 | [ "a", "b", "c", ], 124 | [ "1", "2", "3", ], 125 | [ "", "3", "4", ], 126 | [ "1", "", "4", ], 127 | [ "1", "2", "", ], 128 | ], "Empty"); 129 | 130 | is_deeply (parse (5), [ 131 | [ "a", "b", "c", ], 132 | [ "1", "2", "3", ], 133 | [ undef, "3", "4", ], 134 | [ "1", undef, "4", ], 135 | [ "1", "2", undef, ], 136 | ], "Undef"); 137 | 138 | for ([ "Callback return", sub { 42; } ], 139 | [ "Callback assign", sub { $_ = 42; } ], 140 | [ "Callback subst", sub { s/.*/42/; $_ } ], # s///r requires 5.13.2 141 | ) { 142 | my ($msg, $cb) = @$_; 143 | is_deeply (parse ($cb), [ 144 | [ "a", "b", "c", ], 145 | [ "1", "2", "3", ], 146 | [ "42", "3", "4", ], 147 | [ "1", "42", "4", ], 148 | [ "1", "2", "42", ], 149 | ], $msg); 150 | } 151 | is_deeply (parse (sub { eval { s{^=([-+*/0-9()]+)$}{$1}ee }; $_ }), [ 152 | [ "a", "b", "c", ], 153 | [ "1", "2", "3", ], 154 | [ "3", "3", "4", ], 155 | [ "1", "5", "4", ], 156 | [ "1", "2", "7", ], 157 | ], "Callback calculations"); 158 | 159 | { @m = (); 160 | ok (my $csv = Text::CSV->new ({ formula => 3 }), "new 3 hr"); 161 | ok ($csv->column_names ("code", "value", "desc"), "Set column names"); 162 | ok ($csv->parse ("1,=2+3,4"), "Parse"); 163 | is_deeply (\@m, 164 | [ qq{Field 2 (column: 'value') contains formula '=2+3'\n} ], 165 | "Warning for HR"); 166 | } 167 | 168 | # Writer 169 | 170 | sub writer { 171 | my $f = shift; 172 | ok (my $csv = Text::CSV->new ({ 173 | formula_handling => $f, quote_empty => 1 }), "new $f"); 174 | ok ($csv->combine ("1", "=2+3", "4"), "combine $f"); 175 | $csv->string; 176 | } # writer 177 | 178 | @m = (); 179 | is ( writer (0), q{1,=2+3,4}, "Out 0"); 180 | is (eval { writer (1) }, undef, "Out 1"); 181 | is (eval { writer (2) }, undef, "Out 2"); 182 | is ( writer (3), q{1,=2+3,4}, "Out 3"); 183 | is ( writer (4), q{1,"",4}, "Out 4"); 184 | is ( writer (5), q{1,,4}, "Out 5"); 185 | is_deeply (\@m, [ "Field 1 contains formula '=2+3'\n" ], "Warning 3"); 186 | 187 | @m = (); 188 | is ( writer ("none"), q{1,=2+3,4}, "Out none"); 189 | is (eval { writer ("die") }, undef, "Out die"); 190 | is (eval { writer ("croak") }, undef, "Out croak"); 191 | is ( writer ("diag"), q{1,=2+3,4}, "Out diag"); 192 | is ( writer ("empty"), q{1,"",4}, "Out empty"); 193 | is ( writer ("undef"), q{1,,4}, "Out undef"); 194 | is_deeply (\@m, [ "Field 1 contains formula '=2+3'\n" ], "Warning diag"); 195 | 196 | open my $fh, ">", $tfn; 197 | printf $fh <<"EOC"; 198 | 1,2,3 199 | =1+2,3,4 200 | 1,=12-6,5 201 | 1,2,=4+(9-1)/2 202 | EOC 203 | close $fh; 204 | 205 | is_deeply (Text::CSV::csv (in => $tfn, 206 | formula => sub { eval { s{^=([-+*/0-9()]+)$}{$1}ee }; $_ }), 207 | [[1,2,3],[3,3,4],[1,6,5],[1,2,8]], "Formula calc from csv function"); 208 | -------------------------------------------------------------------------------- /t/75_hashref.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | #use Test::More "no_plan"; 7 | use Test::More tests => 102; 8 | 9 | BEGIN { 10 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 11 | use_ok "Text::CSV", (); 12 | plan skip_all => "Cannot load Text::CSV" if $@; 13 | } 14 | 15 | my $tfn = "_75hashref.csv"; END { -f $tfn and unlink $tfn; } 16 | 17 | open my $fh, ">", $tfn or die "$tfn: $!\n"; 18 | print $fh <new (), "new"); 28 | is ($csv->column_names, undef, "No headers yet"); 29 | 30 | foreach my $args ([\1], ["foo", \1], [{ 1 => 2 }]) { 31 | eval { $csv->column_names (@$args) }; 32 | like ($@, qr/^EHR/, "croak"); 33 | is ($csv->error_diag () + 0, 3001, "Bad args to column_names"); 34 | } 35 | 36 | ok ($csv->column_names ("name"), "One single name"); 37 | is ($csv->column_names (undef), undef, "reset column_names"); 38 | eval { $csv->column_names (\undef) }; 39 | is ($csv->error_diag () + 0, 3001, "No hash please"); 40 | eval { $csv->column_names ({ 1 => 2 }) }; 41 | is ($csv->error_diag () + 0, 3001, "No hash please"); 42 | 43 | my $hr; 44 | eval { $hr = $csv->getline_hr ($fh) }; 45 | is ($hr, undef, "getline_hr before column_names"); 46 | like ($@, qr/^EHR/, "croak"); 47 | is ($csv->error_diag () + 0, 3002, "error code"); 48 | 49 | ok ($csv->column_names ("name", "code"), "column_names (list)"); 50 | is_deeply ([ $csv->column_names ], [ "name", "code" ], "well set"); 51 | 52 | open $fh, "<", $tfn or die "$tfn: $!\n"; 53 | my $row; 54 | ok ($row = $csv->getline ($fh), "getline headers"); 55 | is ($row->[0], "code", "Header line"); 56 | ok ($csv->column_names ($row), "column_names from array_ref"); 57 | is_deeply ([ $csv->column_names ], [ @$row ], "Keys set"); 58 | while (my $hr = $csv->getline_hr ($fh)) { 59 | ok (exists $hr->{code}, "Line has a code field"); 60 | like ($hr->{code}, qr/^[0-9]+$/, "Code is numeric"); 61 | ok (exists $hr->{name}, "Line has a name field"); 62 | like ($hr->{name}, qr/^[A-Z][a-z]+$/, "Name"); 63 | } 64 | close $fh; 65 | 66 | my ($code, $name, $price, $desc) = (1..4); 67 | is ($csv->bind_columns (), undef, "No bound columns yet"); 68 | eval { $csv->bind_columns (\$code) }; 69 | is ($csv->error_diag () + 0, 3003, "Arg cound mismatch"); 70 | eval { $csv->bind_columns ({}, {}, {}, {}) }; 71 | is ($csv->error_diag () + 0, 3004, "bad arg types"); 72 | is ($csv->column_names (undef), undef, "reset column_names"); 73 | ok ($csv->bind_columns (\($code, $name, $price)), "Bind columns"); 74 | 75 | eval { $csv->column_names ("foo") }; 76 | is ($csv->error_diag () + 0, 3003, "Arg cound mismatch"); 77 | $csv->bind_columns (undef); 78 | eval { $csv->bind_columns ([undef]) }; 79 | is ($csv->error_diag () + 0, 3004, "legal header defenition"); 80 | 81 | my @bcr = \($code, $name, $price, $desc); 82 | open $fh, "<", $tfn or die "$tfn: $!\n"; 83 | ok ($row = $csv->getline ($fh), "getline headers"); 84 | ok ($csv->bind_columns (@bcr), "Bind columns"); 85 | ok ($csv->column_names ($row), "column_names from array_ref"); 86 | is_deeply ([ $csv->column_names ], [ @$row ], "Keys set"); 87 | 88 | $row = $csv->getline ($fh); 89 | is_deeply ([ $csv->bind_columns ], [ @bcr ], "check refs"); 90 | is_deeply ($row, [], "return from getline with bind_columns"); 91 | 92 | is ($csv->column_names (undef), undef, "reset column headers"); 93 | is ($csv->bind_columns (undef), undef, "reset bound columns"); 94 | 95 | my $foo; 96 | ok ($csv->bind_columns (@bcr, \$foo), "bind too many columns"); 97 | ($code, $name, $price, $desc, $foo) = (101 .. 105); 98 | ok ($csv->getline ($fh), "fetch less than expected"); 99 | is_deeply ([ $code, $name, $price, $desc, $foo ], 100 | [ 2, "Drinks", "82.78", "Drinks", 105 ], "unfetched not reset"); 101 | 102 | my @foo = (0) x 0x012345; 103 | ok ($csv->bind_columns (\(@foo)), "bind a lot of columns"); 104 | 105 | ok ($csv->bind_columns (\1, \2, \3, \""), "bind too constant columns"); 106 | is ($csv->getline ($fh), undef, "fetch to read-only ref"); 107 | is ($csv->error_diag () + 0, 3008, "Read-only"); 108 | 109 | ok ($csv->bind_columns (\$code), "bind not enough columns"); 110 | eval { $row = $csv->getline ($fh) }; 111 | is ($csv->error_diag () + 0, 3006, "cannot read all fields"); 112 | 113 | close $fh; 114 | 115 | open $fh, "<", $tfn or die "$tfn: $!\n"; 116 | 117 | is ($csv->column_names (undef), undef, "reset column headers"); 118 | is ($csv->bind_columns (undef), undef, "reset bound columns"); 119 | is_deeply ([ $csv->column_names (undef, "", "name", "name") ], 120 | [ "\cAUNDEF\cA", "", "name", "name" ], "undefined column header"); 121 | ok ($hr = $csv->getline_hr ($fh), "getline_hr ()"); 122 | is (ref $hr, "HASH", "returned a hashref"); 123 | is_deeply ($hr, { "\cAUNDEF\cA" => "code", "" => "name", "name" => "description" }, 124 | "Discarded 3rd field"); 125 | 126 | close $fh; 127 | 128 | open $fh, ">", $tfn or die "$tfn: $!\n"; 129 | $hr = { c_foo => 1, foo => "poison", zebra => "Of course" }; 130 | is ($csv->column_names (undef), undef, "reset column headers"); 131 | ok ($csv->column_names (sort keys %$hr), "set column names"); 132 | ok ($csv->eol ("\n"), "set eol for output"); 133 | ok ($csv->print ($fh, [ $csv->column_names ]), "print header"); 134 | ok ($csv->print_hr ($fh, $hr), "print_hr"); 135 | ok ($csv->print ($fh, []), "empty print"); 136 | close $fh; 137 | ok ($csv->keep_meta_info (1), "keep meta info"); 138 | open $fh, "<", $tfn or die "$tfn: $!\n"; 139 | ok ($csv->column_names ($csv->getline ($fh)), "get column names"); 140 | is_deeply ($csv->getline_hr ($fh), $hr, "compare to written hr"); 141 | 142 | is_deeply ($csv->getline_hr ($fh), 143 | { c_foo => "", foo => undef, zebra => undef }, "compare to written hr"); 144 | is ($csv->is_missing (1), 1, "No col 1"); 145 | close $fh; 146 | 147 | open $fh, ">", $tfn or die "$tfn: $!\n"; 148 | print $fh <<"EOC"; 149 | a,b 150 | 151 | 2 152 | EOC 153 | close $fh; 154 | 155 | ok ($csv = Text::CSV->new (), "new"); 156 | 157 | open $fh, "<", $tfn or die "$tfn: $!\n"; 158 | ok ($csv->column_names ("code", "foo"), "set column names"); 159 | ok ($hr = $csv->getline_hr ($fh), "get header line"); 160 | is ($csv->is_missing (0), undef, "not is_missing () - no meta"); 161 | is ($csv->is_missing (1), undef, "not is_missing () - no meta"); 162 | ok ($hr = $csv->getline_hr ($fh), "get empty line"); 163 | is ($csv->is_missing (0), undef, "not is_missing () - no meta"); 164 | is ($csv->is_missing (1), undef, "not is_missing () - no meta"); 165 | ok ($hr = $csv->getline_hr ($fh), "get partial data line"); 166 | is (int $hr->{code}, 2, "code == 2"); 167 | is ($csv->is_missing (0), undef, "not is_missing () - no meta"); 168 | is ($csv->is_missing (1), undef, "not is_missing () - no meta"); 169 | close $fh; 170 | 171 | open $fh, "<", $tfn or die "$tfn: $!\n"; 172 | $csv->keep_meta_info (1); 173 | ok ($csv->column_names ("code", "foo"), "set column names"); 174 | ok ($hr = $csv->getline_hr ($fh), "get header line"); 175 | is ($csv->is_missing (0), 0, "not is_missing () - with meta"); 176 | is ($csv->is_missing (1), 0, "not is_missing () - with meta"); 177 | ok ($hr = $csv->getline_hr ($fh), "get empty line"); 178 | is ($csv->is_missing (0), 1, "not is_missing () - with meta"); 179 | is ($csv->is_missing (1), 1, "not is_missing () - with meta"); 180 | ok ($hr = $csv->getline_hr ($fh), "get partial data line"); 181 | is (int $hr->{code}, 2, "code == 2"); 182 | is ($csv->is_missing (0), 0, "not is_missing () - with meta"); 183 | is ($csv->is_missing (1), 1, "not is_missing () - with meta"); 184 | close $fh; 185 | -------------------------------------------------------------------------------- /t/46_eol_si.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Config; 7 | use Test::More; 8 | 9 | BEGIN { 10 | unless (exists $Config{useperlio} && 11 | defined $Config{useperlio} && 12 | $] >= 5.008 && # perlio was experimental in 5.6.2, but not reliable 13 | $Config{useperlio} eq "define") { 14 | plan skip_all => "No reliable perlIO available"; 15 | } 16 | else { 17 | plan tests => 562; 18 | } 19 | } 20 | 21 | BEGIN { 22 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 23 | require_ok "Text::CSV"; 24 | plan skip_all => "Cannot load Text::CSV" if $@; 25 | require "./t/util.pl"; 26 | } 27 | 28 | $| = 1; 29 | 30 | # Embedded newline tests 31 | 32 | my $file = ""; 33 | 34 | my $def_rs = $/; 35 | 36 | foreach my $rs ("\n", "\r\n", "\r") { 37 | for $\ (undef, $rs) { 38 | 39 | my $csv = Text::CSV->new ({ binary => 1 }); 40 | $csv->eol ($/ = $rs) unless defined $\; 41 | 42 | my $fh; 43 | foreach my $pass (0, 1) { 44 | if ($pass == 0) { 45 | $file = ""; 46 | open $fh, ">", \$file or die "IO: $!\n"; 47 | } 48 | else { 49 | open $fh, "<", \$file or die "IO: $!\n"; 50 | } 51 | 52 | foreach my $eol ("", "\r", "\n", "\r\n", "\n\r") { 53 | my $s_eol = join " - ", map { defined $_ ? $_ : "" } $\, $rs, $eol; 54 | $s_eol =~ s/\r/\\r/g; 55 | $s_eol =~ s/\n/\\n/g; 56 | 57 | my @p; 58 | my @f = ("", 1, 59 | $eol, " $eol", "$eol ", " $eol ", "'$eol'", 60 | "\"$eol\"", " \" $eol \"\n ", "EOL"); 61 | 62 | if ($pass == 0) { 63 | ok ($csv->combine (@f), "combine |$s_eol|"); 64 | ok (my $str = $csv->string, "string |$s_eol|"); 65 | my $state = $csv->parse ($str); 66 | ok ($state, "parse |$s_eol|"); 67 | if ($state) { 68 | ok (@p = $csv->fields, "fields |$s_eol|"); 69 | } 70 | else{ 71 | is ($csv->error_input, $str, "error |$s_eol|"); 72 | } 73 | 74 | print $fh $str; 75 | } 76 | else { 77 | ok (my $row = $csv->getline ($fh), "getline |$s_eol|"); 78 | is (ref $row, "ARRAY", "row |$s_eol|"); 79 | @p = @$row; 80 | } 81 | 82 | local $, = "|"; 83 | is_binary ("@p", "@f", "result |$s_eol|"); 84 | } 85 | 86 | close $fh; 87 | } 88 | 89 | } 90 | } 91 | $/ = $def_rs; 92 | 93 | { my $csv = Text::CSV->new ({ escape_char => undef }); 94 | 95 | ok ($csv->parse (qq{"x"\r\n}), "Trailing \\r\\n with no escape char"); 96 | 97 | is ($csv->eol ("\r"), "\r", "eol set to \\r"); 98 | ok ($csv->parse (qq{"x"\r}), "Trailing \\r with no escape char"); 99 | 100 | ok ($csv->allow_whitespace (1), "Allow whitespace"); 101 | ok ($csv->parse (qq{"x" \r}), "Trailing \\r with no escape char"); 102 | } 103 | 104 | SKIP: { 105 | $] < 5.008 and skip "\$\\ tests don't work in perl 5.6.x and older", 2; 106 | { local $\ = "#\r\n"; 107 | my $csv = Text::CSV->new (); 108 | $file = ""; 109 | open my $fh, ">", \$file or die "IO: $!\n"; 110 | $csv->print ($fh, [ "a", 1 ]); 111 | close $fh; 112 | open $fh, "<", \$file or die "IO: $!\n"; 113 | local $/; 114 | is (<$fh>, "a,1#\r\n", "Strange \$\\"); 115 | close $fh; 116 | } 117 | { local $\ = "#\r\n"; 118 | my $csv = Text::CSV->new ({ eol => $\ }); 119 | $file = ""; 120 | open my $fh, ">", \$file or die "IO: $!\n"; 121 | $csv->print ($fh, [ "a", 1 ]); 122 | close $fh; 123 | open $fh, "<", \$file or die "IO: $!\n"; 124 | local $/; 125 | is (<$fh>, "a,1#\r\n", "Strange \$\\ + eol"); 126 | close $fh; 127 | } 128 | } 129 | $/ = $def_rs; 130 | 131 | ok (1, "Auto-detecting \\r"); 132 | { my @row = qw( a b c ); local $" = ","; 133 | for (["\n", "\\n"], ["\r\n", "\\r\\n"], ["\r", "\\r"]) { 134 | my ($eol, $s_eol) = @$_; 135 | $file = ""; 136 | open my $fh, ">", \$file or die "IO: $!\n"; 137 | print $fh qq{@row$eol@row$eol@row$eol\x91}; 138 | close $fh; 139 | open $fh, "<", \$file or die "IO: $!\n"; 140 | my $c = Text::CSV->new ({ binary => 1, auto_diag => 1 }); 141 | is ($c->eol (), "", "default EOL"); 142 | is_deeply ($c->getline ($fh), [ @row ], "EOL 1 $s_eol"); 143 | is ($c->eol (), $eol eq "\r" ? "\r" : "", "EOL"); 144 | is_deeply ($c->getline ($fh), [ @row ], "EOL 2 $s_eol"); 145 | is_deeply ($c->getline ($fh), [ @row ], "EOL 3 $s_eol"); 146 | close $fh; 147 | } 148 | } 149 | 150 | ok (1, "Specific \\r test from tfrayner"); 151 | { $/ = "\r"; 152 | $file = ""; 153 | open my $fh, ">", \$file or die "IO: $!\n"; 154 | print $fh qq{a,b,c$/}, qq{"d","e","f"$/}; 155 | close $fh; 156 | open $fh, "<", \$file or die "IO: $!\n"; 157 | my $c = Text::CSV->new ({ eol => $/ }); 158 | 159 | my $row; 160 | local $" = " "; 161 | ok ($row = $c->getline ($fh), "getline 1"); 162 | is (scalar @$row, 3, "# fields"); 163 | is ("@$row", "a b c", "fields 1"); 164 | ok ($row = $c->getline ($fh), "getline 2"); 165 | is (scalar @$row, 3, "# fields"); 166 | is ("@$row", "d e f", "fields 2"); 167 | close $fh; 168 | } 169 | $/ = $def_rs; 170 | 171 | ok (1, "EOL undef"); 172 | { $/ = "\r"; 173 | ok (my $csv = Text::CSV->new ({ eol => undef }), "new csv with eol => undef"); 174 | $file = ""; 175 | open my $fh, ">", \$file or die "IO: $!\n"; 176 | ok ($csv->print ($fh, [1, 2, 3]), "print"); 177 | ok ($csv->print ($fh, [4, 5, 6]), "print"); 178 | close $fh; 179 | 180 | open $fh, "<", \$file or die "IO: $!\n"; 181 | ok (my $row = $csv->getline ($fh), "getline 1"); 182 | is (scalar @$row, 5, "# fields"); 183 | is_deeply ($row, [ 1, 2, 34, 5, 6], "fields 1"); 184 | close $fh; 185 | } 186 | $/ = $def_rs; 187 | 188 | foreach my $eol ("!", "!!", "!\n", "!\n!") { 189 | (my $s_eol = $eol) =~ s/\n/\\n/g; 190 | ok (1, "EOL $s_eol"); 191 | ok (my $csv = Text::CSV->new ({ eol => $eol }), "new csv with eol => $s_eol"); 192 | $file = ""; 193 | open my $fh, ">", \$file or die "IO: $!\n"; 194 | ok ($csv->print ($fh, [1, 2, 3]), "print"); 195 | ok ($csv->print ($fh, [4, 5, 6]), "print"); 196 | close $fh; 197 | 198 | foreach my $rs (undef, "", "\n", $eol, "!", "!\n", "\n!", "!\n!", "\n!\n") { 199 | local $/ = $rs; 200 | (my $s_rs = defined $rs ? $rs : "-- undef --") =~ s/\n/\\n/g; 201 | ok (1, "with RS $s_rs"); 202 | open $fh, "<", \$file or die "IO: $!\n"; 203 | ok (my $row = $csv->getline ($fh), "getline 1"); 204 | is (scalar @$row, 3, "# fields"); 205 | is_deeply ($row, [ 1, 2, 3], "fields 1"); 206 | ok ( $row = $csv->getline ($fh), "getline 2"); 207 | is (scalar @$row, 3, "# fields"); 208 | is_deeply ($row, [ 4, 5, 6], "fields 2"); 209 | close $fh; 210 | } 211 | } 212 | $/ = $def_rs; 213 | 214 | { ok (my $csv = Text::CSV->new, "new for say"); 215 | my $foo; 216 | open my $fh, ">", \$foo or die "IO: $!\n"; 217 | ok ($csv->say ($fh, [ 1, 2 ]), "say"); 218 | close $fh; 219 | is ($foo, "1,2$/", "content with eol \$/"); 220 | $foo = ""; 221 | $csv->eol (undef); 222 | open $fh, ">", \$foo or die "IO: $!\n"; 223 | ok ($csv->say ($fh, [ 1, 2 ]), "say"); 224 | close $fh; 225 | $foo = ""; 226 | $csv->eol (""); 227 | open $fh, ">", \$foo or die "IO: $!\n"; 228 | ok ($csv->say ($fh, [ 1, 2 ]), "say"); 229 | close $fh; 230 | is ($foo, "1,2$/", "content with eol \$/"); 231 | $foo = ""; 232 | $csv->eol ("#"); 233 | open $fh, ">", \$foo or die "IO: $!\n"; 234 | ok ($csv->say ($fh, [ 1, 2 ]), "say"); 235 | close $fh; 236 | is ($foo, "1,2#", "content with eol #"); 237 | $foo = ""; 238 | $csv->eol ("0"); 239 | open $fh, ">", \$foo or die "IO: $!\n"; 240 | ok ($csv->say ($fh, [ 1, 2 ]), "say"); 241 | close $fh; 242 | is ($foo, "1,20", "content with eol 0"); 243 | } 244 | 245 | { ok (my $csv = Text::CSV->new, "new for say"); 246 | my $foo; 247 | my $dta = "x"; 248 | ok ($csv->bind_columns (\$dta), "bind columns"); 249 | 250 | local $\ = undef; 251 | local $/ = "\n"; 252 | 253 | open my $fh, ">", \$foo or die "IO: $!\n"; 254 | ok ($csv->print ($fh, undef), "print"); 255 | close $fh; 256 | is ($foo, "x", "print, no newline"); 257 | 258 | $foo = ""; 259 | open $fh, ">", \$foo or die "IO: $!\n"; 260 | ok ($csv->say ($fh, undef), "say"); 261 | close $fh; 262 | is ($foo, "x\n", "say, with newline"); 263 | } 264 | 265 | 1; 266 | -------------------------------------------------------------------------------- /t/71_strict.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More tests => 75; 7 | #use Test::More "no_plan"; 8 | 9 | my %err; 10 | 11 | BEGIN { 12 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 13 | require_ok "Text::CSV"; 14 | plan skip_all => "Cannot load Text::CSV" if $@; 15 | require "./t/util.pl"; 16 | 17 | open my $fh, "<", "lib/Text/CSV_PP.pm" or die "Cannot read error messages from PP\n"; 18 | while (<$fh>) { 19 | m/^ ([0-9]{4}) => "([^"]+)",/ and $err{$1} = $2; 20 | } 21 | close $fh; 22 | } 23 | 24 | my $tfn = "_80test.csv"; END { -f $tfn and unlink $tfn; } 25 | $| = 1; 26 | 27 | my $csv = Text::CSV->new (); 28 | 29 | { my $csv = Text::CSV->new ({ strict => 1 }); 30 | ok ($csv->parse ("1,2,3"), "Set strict to 3 columns"); 31 | ok ($csv->parse ("a,b,c"), "3 columns should be correct"); 32 | is ($csv->parse ("3,4"), 0, "Not enough columns"); 33 | is (0 + $csv->error_diag, 2014, "Error set correctly"); 34 | } 35 | { my $csv = Text::CSV->new ({ strict => 1 }); 36 | ok ($csv->parse ("1,2,3"), "Set strict to 3 columns"); 37 | is ($csv->parse ("3,4,5,6"), 0, "Too many columns"); 38 | is (0 + $csv->error_diag, 2014, "Error set correctly"); 39 | } 40 | { my $csv = Text::CSV->new ({ strict => 1 }); 41 | open my $fh, ">", $tfn or die "$tfn: $!\n"; 42 | ok ($csv->say ($fh, [ 1, 2, 3 ]), "Write line 1"); 43 | ok ($csv->say ($fh, [ 1, 2, 3 ]), "Write line 2"); 44 | close $fh; 45 | open $fh, "<", $tfn or die "$tfn: $!\n"; 46 | ok ((my $r = $csv->getline ($fh)), "Get line 1 under strict"); 47 | ok (( $r = $csv->getline ($fh)), "Get line 2 under strict"); 48 | is ($csv->getline ($fh), undef, "EOF under strict"); 49 | is (0 + $csv->error_diag, 2012, "Error is 2012 instead of 2014"); 50 | ok ($csv->eof, "EOF is set"); 51 | close $fh; 52 | } 53 | { my $csv = Text::CSV->new ({ strict => 1 }); 54 | open my $fh, ">", $tfn or die "$tfn: $!\n"; 55 | ok ($csv->say ($fh, [ 1, 2, 3 ]), "Write line 1"); 56 | ok ($csv->print ($fh, [ 1, 2, 3 ]), "Write line 2 no newline"); 57 | close $fh; 58 | open $fh, "<", $tfn or die "$tfn: $!\n"; 59 | ok ((my $r = $csv->getline ($fh)), "Get line 1 under strict"); 60 | ok (( $r = $csv->getline ($fh)), "Get line 2 under strict no newline"); 61 | is ($csv->getline ($fh), undef, "EOF under strict"); 62 | is (0 + $csv->error_diag, 2012, "Error is 2012 instead of 2014"); 63 | ok ($csv->eof, "EOF is set"); 64 | close $fh; 65 | } 66 | { my $csv = Text::CSV->new (); 67 | open my $fh, ">", $tfn or die "$tfn: $!\n"; 68 | ok ($csv->say ($fh, [ 1 .. 3 ]), "Write line 1 (headers)"); 69 | ok ($csv->say ($fh, [ 1 .. 4 ]), "Write line 2 (data)"); 70 | close $fh; 71 | my $aoh = Text::CSV::csv (in => $tfn, headers => "auto"); 72 | is_deeply ($aoh, [{ 1 => 1, 2 => 2, 3 => 3 }], "Column dropped"); 73 | my @e; 74 | eval { 75 | local $SIG{__WARN__} = sub { push @e => @_ }; 76 | $aoh = Text::CSV::csv (in => $tfn, headers => "auto", strict => 1); 77 | }; 78 | is_deeply ($aoh, [], "Fail under strict"); 79 | is (scalar @e, 1, "Got error"); 80 | like ($e[0], qr{ 2014 }, "Error 2014"); 81 | 82 | open $fh, ">", $tfn or die "$tfn: $!\n"; 83 | ok ($csv->say ($fh, [ 1 .. 4 ]), "Write line 1 (headers)"); 84 | ok ($csv->say ($fh, [ 1 .. 3 ]), "Write line 2 (data)"); 85 | close $fh; 86 | $aoh = Text::CSV::csv (in => $tfn, headers => "auto"); 87 | is_deeply ($aoh, [{ 1 => 1, 2 => 2, 3 => 3, 4 => undef }], "Column added"); 88 | @e = (); 89 | eval { 90 | local $SIG{__WARN__} = sub { push @e => @_ }; 91 | $aoh = Text::CSV::csv (in => $tfn, headers => "auto", strict => 1); 92 | }; 93 | is_deeply ($aoh, [], "Fail under strict"); 94 | is (scalar @e, 1, "Got error"); 95 | like ($e[0], qr{ 2014 }, "Error 2014"); 96 | } 97 | 98 | foreach my $strict (0, 1) { 99 | my $csv = Text::CSV->new ({ 100 | binary => 1, 101 | comment_str => "#", 102 | eol => "\n", 103 | escape_char => '"', 104 | quote_char => '"', 105 | sep_char => "|", 106 | strict => $strict, 107 | }); 108 | 109 | my $status = $csv->parse ('a|b|"d"'); 110 | is (0 + $csv->error_diag, 0, "No fail under strict = $strict"); 111 | $status = $csv->parse ('a|b|c"d"e'); # Loose unescaped quote 112 | is (0 + $csv->error_diag, 2034, "Previous error still actual"); 113 | } 114 | 115 | open my $fh, ">", $tfn or die "$tfn: $!\n"; 116 | print $fh <<"EOC"; 117 | 1,foo 118 | 2,bar,fail 119 | 3,baz 120 | 4 121 | 5,eox 122 | EOC 123 | close $fh; 124 | 125 | open $fh, "<", $tfn or die "$tfn: $!\n"; 126 | my @rpt; 127 | $csv = Text::CSV->new ({ strict => 1, auto_diag => 1 }); 128 | $csv->callbacks (error => sub { 129 | my ($err, $msg, $pos, $recno, $fldno) = @_; 130 | if ($err == 2014) { 131 | push @rpt => [ $recno, $fldno, $pos ]; 132 | $csv->SetDiag (0); 133 | } 134 | }); 135 | is_deeply ([ $csv->getline_all ($fh), @rpt ], 136 | [[[ 1, "foo" ], [ 2, "bar", "fail" ], [ 3, "baz" ], [ 4 ], [ 5, "eox" ]], 137 | [ 2, 3, 12 ], [ 4, 1, 3 ]], "Can catch strict 2014 with \$csv"); 138 | close $fh; 139 | 140 | open $fh, "<", $tfn or die "$tfn: $!\n"; 141 | @rpt = (); 142 | $csv = Text::CSV->new ({ strict => 1, auto_diag => 1, callbacks => { 143 | error => sub { 144 | my ($err, $msg, $pos, $recno, $fldno) = @_; 145 | if ($err == 2014) { 146 | push @rpt => [ $recno, $fldno, $pos ]; 147 | Text::CSV->SetDiag (0); 148 | } 149 | }}}); 150 | is_deeply ([ $csv->getline_all ($fh), @rpt ], 151 | [[[ 1, "foo" ], [ 2, "bar", "fail" ], [ 3, "baz" ], [ 4 ], [ 5, "eox" ]], 152 | [ 2, 3, 12 ], [ 4, 1, 3 ]], "Can catch strict 2014 with class"); 153 | close $fh; 154 | 155 | # Under strcict, fail un not enough fields. 156 | # Under non-strict expect the value of the previous record 157 | foreach my $test ( 158 | [ "a,b,c\n" . "d,e,f\n". "g,h\n". "i,j,k\n", 159 | "a,b,c\n" . "d,e,f\n". "g,h,f\n". "i,j,k\n", 2, 5 ], 160 | [ "a,b,c\n" . "d,e,f\n". "g,h\n" , 161 | "a,b,c\n" . "d,e,f\n". "g,h,f\n" , 2, 5 ], 162 | [ "a,b,c\n" . "g,h\n". "i,j,k\n", 163 | "a,b,c\n" . "g,h,c\n". "i,j,k\n", 1, 5 ], 164 | [ "a,b\n" . "d,e,f\n". "g,h\n". "i,j,k\n", 165 | "a,b,*\n" . "d,e,f\n". "g,h,f\n". "i,j,k\n", 1, 5 ], 166 | ) { 167 | my ($dta, $dta0, $err_line, $pos) = @$test; 168 | open $fh, ">", $tfn or die "$tfn: $!\n"; 169 | print $fh $dta; 170 | close $fh; 171 | my $expect = [ map {[ split m/,/ => $_ ]} grep m/\S/ => split "\n" => $dta0 ]; 172 | foreach my $strict (0, 1) { 173 | open $fh, "<", $tfn or die "$tfn: $!\n"; 174 | my $csv = Text::CSV->new ({ strict => $strict }); 175 | my ($r1, $r2, $r3) = ("-", "+", "*"); 176 | $csv->bind_columns (\($r1, $r2, $r3)); 177 | my @out; 178 | eval { 179 | while ($csv->getline ($fh)) { 180 | push @out => [ $r1, $r2, $r3 ]; 181 | } 182 | }; 183 | close $fh; 184 | my @err = $csv->error_diag; 185 | if ($strict) { 186 | is ($err[0], 2014, "ENF"); 187 | splice @$expect, $err_line; 188 | } 189 | else { 190 | is ($err[0], 2012, "EOF"); 191 | } 192 | is_deeply (\@out, $expect, "Bound + strict = $strict"); 193 | } 194 | } 195 | 196 | { ok (my $csv = Text::CSV->new ({ strict => 1 }), "Issue#58 data first"); 197 | ok ($csv->column_names (qw( A B C )), "Expect 3 colums"); 198 | is_deeply ($csv->getline_hr (*DATA), { A => 1, B => 2, C => 42 }, "Stream OK"); 199 | ok ($csv->parse ("1,2,42"), "Parse"); 200 | is_deeply ([ $csv->fields ], [ 1, 2, 42 ], "Parse OK"); 201 | is ($csv->parse ("2,42"), 0, "Parse not enough"); 202 | my @err = $csv->error_diag; # error-code, str, pos, rec, fld 203 | is ($err[0], 2014, "Error 2014"); 204 | is ($err[4], 2, "Just got 2"); 205 | } 206 | { ok (my $csv = Text::CSV->new ({ strict => 1 }), "Issue#58 no data first"); 207 | ok ($csv->column_names (qw( A B C )), "Expect 3 colums"); 208 | is ($csv->parse ("2,42"), 0, "Parse not enough"); 209 | my @err = $csv->error_diag; # error-code, str, pos, rec, fld 210 | is ($err[0], 2014, "Error 2014"); 211 | is ($err[4], 2, "Just got 2"); 212 | } 213 | { ok (my $csv = Text::CSV->new ({ strict => 1 }), "Issue#62 no data first"); 214 | my $tf = "issue-62-$$.csv"; 215 | END { -e $tf and unlink $tf } 216 | open my $fh, ">", $tf; 217 | print $fh "A,B\n1,2\n"; 218 | close $fh; 219 | open $fh, "<", $tf; 220 | ok (my @col = @{$csv->getline ($fh)}, "Get header"); 221 | my $val = {}; 222 | ok ($csv->bind_columns (\@{$val}{@col}), "Bind columns"); 223 | ok ($csv->getline ($fh), "Values into bound hash entries"); 224 | my @err = $csv->error_diag; # error-code, str, pos, rec, fld 225 | is ($err[0], 0, "No error 2014"); 226 | is_deeply ($val, { A => 1, B => 2 }, "Content"); 227 | close $fh; 228 | unlink $tf; 229 | } 230 | __END__ 231 | 1,2,42 232 | -------------------------------------------------------------------------------- /t/51_utf8.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | use charnames ":full"; 6 | 7 | use Test::More; 8 | $| = 1; 9 | 10 | BEGIN { 11 | $] < 5.008002 and 12 | plan skip_all => "UTF8 tests useless in this ancient perl version"; 13 | } 14 | 15 | my @tests; 16 | my $ebcdic = ord ("A") == 0xC1; 17 | 18 | BEGIN { 19 | delete $ENV{PERLIO}; 20 | 21 | my $pu = $ENV{PERL_UNICODE}; 22 | $pu = defined $pu && ($pu eq "" || $pu =~ m/[oD]/ || ($pu =~ m/^[0-9]+$/ && $pu & 16)); 23 | 24 | my $euro_ch = "\x{20ac}"; 25 | 26 | utf8::encode (my $bytes = $euro_ch); 27 | utf8::downgrade (my $bytes_dn = $bytes); 28 | utf8::upgrade (my $bytes_up = $bytes); 29 | 30 | @tests = ( 31 | # $test $perlio $data, $encoding $expect_w 32 | # ---------------------------- ------------------- ----------- --------- ---------- 33 | [ "Unicode default", "", $euro_ch, "utf8", $pu ? "no warn" : "warn" ], 34 | [ "Unicode binmode", "[binmode]", $euro_ch, "utf8", "warn", ], 35 | [ "Unicode :utf8", ":utf8", $euro_ch, "utf8", "no warn", ], 36 | [ "Unicode :encoding(utf8)", ":encoding(utf8)", $euro_ch, "utf8", "no warn", ], 37 | [ "Unicode :encoding(UTF-8)", ":encoding(UTF-8)", $euro_ch, "utf8", "no warn", ], 38 | 39 | [ "bytes dn default", "", $bytes_dn, "[none]", "no warn", ], 40 | [ "bytes dn binmode", "[binmode]", $bytes_dn, "[none]", "no warn", ], 41 | [ "bytes dn :utf8", ":utf8", $bytes_dn, "utf8", "no warn", ], 42 | [ "bytes dn :encoding(utf8)", ":encoding(utf8)", $bytes_dn, "utf8", "no warn", ], 43 | [ "bytes dn :encoding(UTF-8)", ":encoding(UTF-8)", $bytes_dn, "utf8", "no warn", ], 44 | 45 | [ "bytes up default", "", $bytes_up, "[none]", "no warn", ], 46 | [ "bytes up binmode", "[binmode]", $bytes_up, "[none]", "no warn", ], 47 | [ "bytes up :utf8", ":utf8", $bytes_up, "utf8", "no warn", ], 48 | [ "bytes up :encoding(utf8)", ":encoding(utf8)", $bytes_up, "utf8", "no warn", ], 49 | [ "bytes up :encoding(UTF-8)", ":encoding(UTF-8)", $bytes_up, "utf8", "no warn", ], 50 | ); 51 | 52 | my $builder = Test::More->builder; 53 | binmode $builder->output, ":encoding(utf8)"; 54 | binmode $builder->failure_output, ":encoding(utf8)"; 55 | binmode $builder->todo_output, ":encoding(utf8)"; 56 | 57 | plan tests => 11 + 6 * @tests + 4 * 22 + 6 + 10 + 2; 58 | } 59 | 60 | BEGIN { 61 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 62 | use_ok "Text::CSV", ("csv"); 63 | plan skip_all => "Cannot load Text::CSV" if $@; 64 | require "./t/util.pl"; 65 | } 66 | 67 | sub hexify { join " ", map { sprintf "%02x", $_ } unpack "C*", @_ } 68 | sub warned { length ($_[0]) ? "warn" : "no warn" } 69 | 70 | my $csv = Text::CSV->new ({ binary => 1, auto_diag => 1 }); 71 | 72 | for (@tests) { 73 | my ($test, $perlio, $data, $enc, $expect_w) = @$_; 74 | 75 | my $expect = qq{"$data"}; 76 | $enc eq "utf8" and utf8::encode ($expect); 77 | 78 | my ($p_out, $p_fh) = (""); 79 | my ($c_out, $c_fh) = (""); 80 | 81 | if ($perlio eq "[binmode]") { 82 | open $p_fh, ">", \$p_out or die "IO: $!\n"; binmode $p_fh; 83 | open $c_fh, ">", \$c_out or die "IO: $!\n"; binmode $c_fh; 84 | } 85 | else { 86 | open $p_fh, ">$perlio", \$p_out or die "IO: $!\n"; 87 | open $c_fh, ">$perlio", \$c_out or die "IO: $!\n"; 88 | } 89 | 90 | my $p_warn = ""; 91 | { local $SIG{__WARN__} = sub { $p_warn .= join "", @_ }; 92 | ok ((print $p_fh qq{"$data"}), "$test perl print"); 93 | close $p_fh; 94 | } 95 | 96 | my $c_warn = ""; 97 | { local $SIG{__WARN__} = sub { $c_warn .= join "", @_ }; 98 | ok ($csv->print ($c_fh, [ $data ]), "$test csv print"); 99 | close $c_fh; 100 | } 101 | 102 | is (hexify ($c_out), hexify ($p_out), "$test against Perl"); 103 | is (hexify ($c_out), hexify ($expect), "$test against expected"); 104 | 105 | is (warned ($c_warn), warned ($p_warn), "$test against Perl warning"); 106 | is (warned ($c_warn), $expect_w, "$test against expected warning"); 107 | } 108 | 109 | # Test automatic upgrades for valid UTF-8 110 | { my $blob = pack "C*", 0..255; $blob =~ tr/",//d; 111 | # perl-5.10.x has buggy SvCUR () on blob 112 | $] >= 5.010000 && $] <= 5.012001 and $blob =~ tr/\0//d; 113 | my $b1 = "\x{b6}"; # PILCROW SIGN in ISO-8859-1 114 | my $b2 = $ebcdic # ARABIC COMMA in UTF-8 115 | ? "\x{b8}\x{57}\x{53}" 116 | : "\x{d8}\x{8c}"; 117 | my @data = ( 118 | qq[1,aap,3], # No diac 119 | qq[1,a${b1}p,3], # Single-byte 120 | qq[1,a${b2}p,3], # Multi-byte 121 | qq[1,"$blob",3], # Binary shit 122 | ) x 2; 123 | my $data = join "\n" => @data; 124 | my @expect = ("aap", "a\266p", "a\x{060c}p", $blob) x 2; 125 | 126 | my $csv = Text::CSV->new ({ binary => 1, auto_diag => 1 }); 127 | 128 | foreach my $bc (undef, 3) { 129 | my @read; 130 | 131 | # Using getline () 132 | open my $fh, "<", \$data or die "IO: $!\n"; binmode $fh; 133 | $bc and $csv->bind_columns (\my ($f1, $f2, $f3)); 134 | is (scalar $csv->bind_columns, $bc, "Columns_bound?"); 135 | while (my $row = $csv->getline ($fh)) { 136 | push @read, $bc ? $f2 : $row->[1]; 137 | } 138 | close $fh; 139 | is_deeply (\@read, \@expect, "Set and reset UTF-8 ".($bc?"no bind":"bind_columns")); 140 | is_deeply ([ map { utf8::is_utf8 ($_) } @read ], 141 | [ "", "", 1, "", "", "", 1, "" ], "UTF8 flags"); 142 | 143 | # Using parse () 144 | @read = map { 145 | $csv->parse ($_); 146 | $bc ? $f2 : ($csv->fields)[1]; 147 | } @data; 148 | is_deeply (\@read, \@expect, "Set and reset UTF-8 ".($bc?"no bind":"bind_columns")); 149 | is_deeply ([ map { utf8::is_utf8 ($_) } @read ], 150 | [ "", "", 1, "", "", "", 1, "" ], "UTF8 flags"); 151 | } 152 | } 153 | 154 | my $sep = "\x{2665}";#"\N{INVISIBLE SEPARATOR}"; 155 | my $quo = "\x{2661}";#"\N{FULLWIDTH QUOTATION MARK}"; 156 | foreach my $new (0, 1, 2, 3) { 157 | my %attr = ( 158 | binary => 1, 159 | always_quote => 1, 160 | );; 161 | $new & 1 and $attr{sep} = $sep; 162 | $new & 2 and $attr{quote} = $quo; 163 | my $csv = Text::CSV->new (\%attr); 164 | 165 | my $s = $attr{sep} || ','; 166 | my $q = $attr{quote} || '"'; 167 | 168 | note ("Test SEP: '$s', QUO: '$q'") if $Test::More::VERSION > 0.81; 169 | is ($csv->sep, $s, "sep"); 170 | is ($csv->quote, $q, "quote"); 171 | 172 | foreach my $data ( 173 | [ 1, 2 ], 174 | [ "\N{EURO SIGN}", "\N{SNOWMAN}" ], 175 | # [ $sep, $quo ], 176 | ) { 177 | 178 | my $exp8 = join $s => map { qq{$q$_$q} } @$data; 179 | utf8::encode (my $expb = $exp8); 180 | my @exp = ($expb, $exp8); 181 | 182 | ok ($csv->combine (@$data), "combine"); 183 | my $x = $csv->string; 184 | is ($csv->string, $exp8, "string"); 185 | 186 | open my $fh, ">:encoding(utf8)", \(my $out = "") or die "IO: $!\n"; 187 | ok ($csv->print ($fh, $data), "print with UTF8 sep"); 188 | close $fh; 189 | 190 | is ($out, $expb, "output"); 191 | 192 | ok ($csv->parse ($expb), "parse"); 193 | is_deeply ([ $csv->fields ], $data, "fields"); 194 | 195 | open $fh, "<", \$expb or die "IO: $!\n"; binmode $fh; 196 | is_deeply ($csv->getline ($fh), $data, "data from getline ()"); 197 | close $fh; 198 | 199 | $expb =~ tr/"//d; 200 | 201 | ok ($csv->parse ($expb), "parse"); 202 | is_deeply ([ $csv->fields ], $data, "fields"); 203 | 204 | open $fh, "<", \$expb or die "IO: $!\n"; binmode $fh; 205 | is_deeply ($csv->getline ($fh), $data, "data from getline ()"); 206 | close $fh; 207 | } 208 | } 209 | 210 | { my $h = "\N{WHITE HEART SUIT}"; 211 | my $H = "\N{BLACK HEART SUIT}"; 212 | my $str = "${h}I$h$H${h}L\"${h}ve$h$H${h}Perl$h"; 213 | utf8::encode ($str); 214 | ok (my $aoa = csv (in => \$str, sep => $H, quote => $h), "Hearts"); 215 | is_deeply ($aoa, [[ "I", "L${h}ve", "Perl"]], "I $H Perl"); 216 | 217 | ok (my $csv = Text::CSV->new ({ 218 | binary => 1, sep => $H, quote => $h }), "new hearts"); 219 | ok ($csv->combine (@{$aoa->[0]}), "combine"); 220 | ok ($str = $csv->string, "string"); 221 | utf8::decode ($str); 222 | is ($str, "I${H}${h}L\"${h}ve${h}${H}Perl", "Correct quotation"); 223 | } 224 | 225 | # Tests pulled from tests in Raku 226 | { my $csv = Text::CSV->new ({ binary => 1, auto_diag => 1 }); 227 | my $h = pack "C*", 224, 34, 204, 182; 228 | ok ($csv->combine (1, $h, 3)); 229 | ok (my $s = $csv->string, "String"); 230 | my $b = $h; 231 | utf8::encode ($b); 232 | ok ($csv->combine (1, $b, 3)); 233 | ok ($s = $csv->string, "String"); 234 | } 235 | 236 | { my $h = qq{\x{10fffd}xE0"}; #" 237 | my $b = $h; 238 | ok ($csv->combine (1, $b, 3)); 239 | ok (my $s = $csv->string, "String"); 240 | $b = $h; 241 | utf8::encode ($b); 242 | ok ($csv->combine (1, $b, 3)); 243 | ok ($s = $csv->string, "String"); 244 | $b = $h; 245 | utf8::encode ($b); 246 | ok ($csv->combine (1, $b, 3)); 247 | ok ($s = $csv->string, "String"); 248 | } 249 | 250 | { my $file = "Eric,\N{LATIN CAPITAL LETTER E WITH ACUTE}RIC\n"; 251 | utf8::encode ($file); 252 | open my $fh, "<", \$file or die $!; 253 | 254 | my $csv = Text::CSV->new ({ binary => 1, auto_diag => 2 }); 255 | is_deeply ( 256 | [ $csv->header ($fh) ], 257 | [ "eric", "\N{LATIN SMALL LETTER E WITH ACUTE}ric" ], 258 | "Lowercase unicode header"); 259 | } 260 | 261 | { my $file = "Eric,\N{LATIN SMALL LETTER E WITH ACUTE}ric\n"; 262 | utf8::encode ($file); 263 | open my $fh, "<", \$file or die $!; 264 | 265 | my $csv = Text::CSV->new ({ binary => 1, auto_diag => 2 }); 266 | is_deeply ( 267 | [ $csv->header ($fh, { munge => "uc" }) ], 268 | [ "ERIC", "\N{LATIN CAPITAL LETTER E WITH ACUTE}RIC" ], 269 | "Uppercase unicode header"); 270 | } 271 | -------------------------------------------------------------------------------- /t/91_csv_cb.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | #use Test::More "no_plan"; 7 | use Test::More tests => 82; 8 | 9 | BEGIN { 10 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 11 | use_ok "Text::CSV", ("csv"); 12 | plan skip_all => "Cannot load Text::CSV" if $@; 13 | require "./t/util.pl"; 14 | } 15 | 16 | my $tfn = "_91test.csv"; END { -f $tfn and unlink $tfn } 17 | my $data = 18 | "foo,bar,baz\n". 19 | "1,2,3\n". 20 | "2,a b,\n"; 21 | open my $fh, ">", $tfn or die "$tfn: $!"; 22 | print $fh $data; 23 | close $fh; 24 | 25 | my $aoa = [ 26 | [qw( foo bar baz )], 27 | [ 1, 2, 3 ], 28 | [ 2, "a b", "" ], 29 | ]; 30 | my $aoh = [ 31 | { foo => 1, bar => 2, baz => 3 }, 32 | { foo => 2, bar => "a b", baz => "" }, 33 | ]; 34 | 35 | for (qw( after_in on_in before_out )) { 36 | is_deeply (csv (in => $tfn, $_ => sub {}), $aoa, "callback $_ on AOA with empty sub"); 37 | is_deeply (csv (in => $tfn, callbacks => { $_ => sub {} }), $aoa, "callback $_ on AOA with empty sub"); 38 | } 39 | is_deeply (csv (in => $tfn, after_in => sub {}, 40 | callbacks => { on_in => sub {} }), $aoa, "callback after_in and on_in on AOA"); 41 | 42 | for (qw( after_in on_in before_out )) { 43 | is_deeply (csv (in => $tfn, headers => "auto", $_ => sub {}), $aoh, "callback $_ on AOH with empty sub"); 44 | is_deeply (csv (in => $tfn, headers => "auto", callbacks => { $_ => sub {} }), $aoh, "callback $_ on AOH with empty sub"); 45 | } 46 | is_deeply (csv (in => $tfn, headers => "auto", after_in => sub {}, 47 | callbacks => { on_in => sub {} }), $aoh, "callback after_in and on_in on AOH"); 48 | 49 | is_deeply (csv (in => $tfn, after_in => sub { push @{$_[1]}, "A" }), [ 50 | [qw( foo bar baz A )], 51 | [ 1, 2, 3, "A" ], 52 | [ 2, "a b", "", "A" ], 53 | ], "AOA ith after_in callback"); 54 | 55 | is_deeply (csv (in => $tfn, headers => "auto", after_in => sub { $_[1]{baz} = "A" }), [ 56 | { foo => 1, bar => 2, baz => "A" }, 57 | { foo => 2, bar => "a b", baz => "A" }, 58 | ], "AOH with after_in callback"); 59 | 60 | is_deeply (csv (in => $tfn, filter => { 2 => sub { /a/ }}), [ 61 | [qw( foo bar baz )], 62 | [ 2, "a b", "" ], 63 | ], "AOA with filter on col 2"); 64 | is_deeply (csv (in => $tfn, filter => { 2 => sub { /a/ }, 65 | 1 => sub { length > 1 }}), [ 66 | [qw( foo bar baz )], 67 | ], "AOA with filter on col 1 and 2"); 68 | is_deeply (csv (in => $tfn, filter => { foo => sub { $_ > 1 }}), [ 69 | { foo => 2, bar => "a b", baz => "" }, 70 | ], "AOH with filter on column name"); 71 | 72 | SKIP: { 73 | $] < 5.008001 and skip "No HOH/xx support in $]", 3; 74 | is_deeply (csv (in => $tfn, headers => "lc"), 75 | [ { foo => 1, bar => 2, baz => 3 }, 76 | { foo => 2, bar => "a b", baz => "" }], 77 | "AOH with lc headers"); 78 | is_deeply (csv (in => $tfn, headers => "uc"), 79 | [ { FOO => 1, BAR => 2, BAZ => 3 }, 80 | { FOO => 2, BAR => "a b", BAZ => "" }], 81 | "AOH with lc headers"); 82 | is_deeply (csv (in => $tfn, headers => sub { lcfirst uc $_[0] }), 83 | [ { fOO => 1, bAR => 2, bAZ => 3 }, 84 | { fOO => 2, bAR => "a b", bAZ => "" }], 85 | "AOH with mangled headers"); 86 | } 87 | 88 | SKIP: { 89 | $] < 5.008001 and skip "No BOM support in $]", 1; 90 | is_deeply (csv (in => $tfn, munge => { bar => "boo" }), 91 | [{ baz => 3, boo => 2, foo => 1 }, 92 | { baz => "", boo => "a b", foo => 2 }], "Munge with hash"); 93 | } 94 | 95 | open $fh, ">>", $tfn or die "$tfn: $!"; 96 | print $fh <<"EOD"; 97 | 3,3,3 98 | 4,5,6 99 | 5,7,9 100 | 6,9,12 101 | 7,11,15 102 | 8,13,18 103 | EOD 104 | close $fh; 105 | 106 | is_deeply (csv (in => $tfn, 107 | filter => { foo => sub { $_ > 2 && $_[1][2] - $_[1][1] < 4 }}), [ 108 | { foo => 3, bar => 3, baz => 3 }, 109 | { foo => 4, bar => 5, baz => 6 }, 110 | { foo => 5, bar => 7, baz => 9 }, 111 | { foo => 6, bar => 9, baz => 12 }, 112 | ], "AOH with filter on column name + on other numbered fields"); 113 | 114 | is_deeply (csv (in => $tfn, 115 | filter => { foo => sub { $_ > 2 && $_{baz} - $_{bar} < 4 }}), [ 116 | { foo => 3, bar => 3, baz => 3 }, 117 | { foo => 4, bar => 5, baz => 6 }, 118 | { foo => 5, bar => 7, baz => 9 }, 119 | { foo => 6, bar => 9, baz => 12 }, 120 | ], "AOH with filter on column name + on other named fields"); 121 | 122 | # Check content ref in on_in AOA 123 | { my $aoa = csv ( 124 | in => $tfn, 125 | filter => { 1 => sub { m/^[3-9]/ }}, 126 | on_in => sub { 127 | is ($_[1][1], 2 * $_[1][0] - 3, "AOA $_[1][0]: b = 2a - 3 \$_[1][]"); 128 | }); 129 | } 130 | # Check content ref in on_in AOH 131 | { my $aoa = csv ( 132 | in => $tfn, 133 | headers => "auto", 134 | filter => { foo => sub { m/^[3-9]/ }}, 135 | after_parse => sub { 136 | is ($_[1]{bar}, 2 * $_[1]{foo} - 3, "AOH $_[1]{foo}: b = 2a - 3 \$_[1]{}"); 137 | }); 138 | } 139 | # Check content ref in on_in AOH with aliases %_ 140 | SKIP: { 141 | $] < 5.008001 and skip "No AOH/alias support in $]", 7; # 6 in on_in, 1 is_deeply 142 | %_ = ( brt => 42 ); 143 | my $aoa = csv ( 144 | in => $tfn, 145 | headers => "auto", 146 | filter => { foo => sub { m/^[3-9]/ }}, 147 | on_in => sub { 148 | is ($_{bar}, 2 * $_{foo} - 3, "AOH $_{foo}: b = 2a - 3 \$_{}"); 149 | }); 150 | is_deeply (\%_, { brt => 42 }, "%_ restored"); 151 | } 152 | 153 | SKIP: { 154 | $] < 5.008001 and skip "Too complicated test for $]", 2; 155 | # Add to %_ in callback 156 | # And test bizarre (but allowed) attribute combinations 157 | # Most of them can be either left out or done more efficiently in 158 | # a different way 159 | my $xcsv = Text::CSV->new; 160 | is_deeply (csv (in => $tfn, 161 | seps => [ ",", ";" ], 162 | munge => "uc", 163 | quo => '"', 164 | esc => '"', 165 | csv => $xcsv, 166 | filter => { 1 => sub { $_ eq "4" }}, 167 | on_in => sub { $_{BRT} = 42; }), 168 | [{ FOO => 4, BAR => 5, BAZ => 6, BRT => 42 }], 169 | "AOH with addition to %_ in on_in"); 170 | is_deeply ($xcsv->csv ( 171 | file => $tfn, 172 | sep_set => [ ";", "," ], 173 | munge_column_names => "uc", 174 | quote_char => '"', 175 | quote => '"', 176 | escape_char => '"', 177 | escape => '"', 178 | filter => { 1 => sub { $_ eq "4" }}, 179 | after_in => sub { $_{BRT} = 42; }), 180 | [{ FOO => 4, BAR => 5, BAZ => 6, BRT => 42 }], 181 | "AOH with addition to %_ in on_in"); 182 | } 183 | 184 | 185 | SKIP: { 186 | $] < 5.008001 and skip "Too complicated test for $]", 2; 187 | ok (my $hr = csv (in => $tfn, key => "foo", on_in => sub { 188 | $_[1]{quz} = "B"; $_{ziq} = 2; }), 189 | "Get into hashref with key and on_in"); 190 | is_deeply ($hr->{8}, {qw( bar 13 baz 18 foo 8 quz B ziq 2 )}, 191 | "on_in with key works"); 192 | } 193 | 194 | open $fh, ">", $tfn or die "$tfn: $!"; 195 | print $fh <<"EOD"; 196 | 3,3,3 197 | 198 | 5,7,9 199 | , 200 | "", 201 | ,, , 202 | ,"", 203 | ,," ", 204 | "" 205 | 8,13,18 206 | EOD 207 | close $fh; 208 | 209 | SKIP: { 210 | $] < 5.008001 and skip "Too complicated test for $]", 4; 211 | is_deeply (csv (in => $tfn, filter => "not_blank"), 212 | [[3,3,3],[5,7,9],["",""],["",""],["",""," ",""], 213 | ["","",""],["",""," ",""],[8,13,18]], 214 | "filter => not_blank"); 215 | is_deeply (csv (in => $tfn, filter => "not_empty"), 216 | [[3,3,3],[5,7,9],["",""," ",""],["",""," ",""],[8,13,18]], 217 | "filter => not_empty"); 218 | is_deeply (csv (in => $tfn, filter => "filled"), 219 | [[3,3,3],[5,7,9],[8,13,18]], 220 | "filter => filled"); 221 | 222 | is_deeply (csv (in => $tfn, filter => sub { 223 | grep { defined && m/\S/ } @{$_[1]} }), 224 | [[3,3,3],[5,7,9],[8,13,18]], 225 | "filter => filled"); 226 | } 227 | 228 | { my @err; 229 | my $aoa = csv (in => $tfn, strict => 1, on_error => sub { @err = @_ }); 230 | is_deeply ($aoa, [[3,3,3]], "Bad CSV still returns ref"); 231 | is ($err[0], 2014, "ENF - Inconsistent number of fields"); 232 | is (0 + Text::CSV->error_diag, 2014, "Error is kept"); 233 | } 234 | 235 | # Count rows in different ways 236 | open $fh, ">", $tfn or die "$tfn: $!"; 237 | print $fh <<"EOD"; 238 | foo,bar,baz 239 | 1,,3 240 | 0,"d 241 | €",4 242 | 999,999, 243 | EOD 244 | close $fh; 245 | 246 | { my $n = 0; 247 | open my $fh, "<", $tfn; 248 | my $csv = Text::CSV->new ({ binary => 1 }); 249 | while (my $row = $csv->getline ($fh)) { $n++; } 250 | close $fh; 251 | is ($n, 4, "Count rows with getline"); 252 | } 253 | { my $n = 0; 254 | my $aoa = csv (in => $tfn, on_in => sub { $n++ }); 255 | is ($n, 4, "Count rows with on_in"); 256 | } 257 | { my $n = 0; 258 | my $aoa = csv (in => $tfn, filter => { 0 => sub { $n++; 0; }}); 259 | is ($n, 4, "Count rows with filter hash"); 260 | } 261 | SKIP: { 262 | $] < 5.008001 and skip "Too complicated test for $]", 1; 263 | my $n = 0; 264 | my $aoa = csv (in => $tfn, filter => sub { $n++; 0; }); 265 | is ($n, 4, "Count rows with filter sub"); 266 | } 267 | SKIP: { 268 | $] < 5.008001 and skip "Too complicated test for $]", 1; 269 | my $n = 0; 270 | csv (in => $tfn, on_in => sub { $n++; 0; }, out => \"skip"); 271 | is ($n, 4, "Count rows with on_in and skipped out"); 272 | } 273 | 274 | # sep_set, seps, sep on problematic header 275 | foreach my $sep (",", ";", "\t") { 276 | my $ph = "Problematic header"; 277 | 278 | open $fh, ">", $tfn or die "$tfn: $!"; 279 | print $fh qq{foo${sep}"bar: a, b"${sep}"c;d"${sep}"e"\n}; 280 | print $fh qq{1${sep}2${sep}3${sep}4\n}; 281 | close $fh; 282 | 283 | my $exp = [{ 284 | "foo" => 1, 285 | "bar: a, b" => 2, 286 | "c;d" => 3, 287 | "e" => 4, 288 | }]; 289 | 290 | ok (csv (in => $tfn, allow_loose_quotes => 1), "$ph, AoA"); 291 | 292 | if ($] < 5.010000) { 293 | ok (1, "Unsupported header feature for $] - sep: $sep") for 1..6; 294 | next; 295 | } 296 | 297 | my @err; 298 | is (eval { 299 | local $SIG{__WARN__} = sub { push @err => @_ }; 300 | csv (in => $tfn, bom => 1); 301 | }, undef, "$ph: cannot decide on sep"); 302 | like ($err[0], qr{ERROR: 1011\b}, "$ph: error 1011"); 303 | 304 | is_deeply (csv (in => $tfn, bom => 1, sep_set => [ $sep ]), $exp, "$ph: sep_set"); 305 | is_deeply (csv (in => $tfn, bom => 1, seps => [ $sep ]), $exp, "$ph: seps"); 306 | is_deeply (csv (in => $tfn, bom => 1, sep_char => $sep ), $exp, "$ph: sep_char"); 307 | is_deeply (csv (in => $tfn, bom => 1, sep => $sep ), $exp, "$ph: sep"); 308 | } 309 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl extension Text::CSV. 2 | 3 | 2.06 2025-03-03 4 | - Imported tests/fixes from Text::CSV_XS 1.60 5 | 6 | 2.05 2025-01-11 7 | - Imported tests/fixes from Text::CSV_XS 1.59 8 | 9 | 2.04 2023-12-02 10 | - Imported tests/fixes from Text::CSV_XS 1.53 11 | - Fixed skip_empty_rows('skip') and trailing newlines (GH#65, bugfood++) 12 | 13 | 2.03 2023-08-11 14 | - Imported tests/fixes from Text::CSV_XS 1.51 15 | 16 | 2.02 2022-08-08 17 | - Imported tests/fixes from Text::CSV_XS 1.48 18 | - Fixed a case where csv function is called as a method (GH#46) 19 | 20 | 2.01 2021-06-19 21 | - Imported tests/fixes from Text::CSV_XS 1.46 22 | - Updated XS_Version to 1.46, and if an older version 23 | of Text::CSV_XS is installed, make sure to update it 24 | (GH#49, mohawk2++) 25 | 26 | 2.00 2019-05-11 27 | - Imported tests/fixes from Text::CSV_XS 1.39 28 | - Fix strict on streaming EOF 29 | - Fixed to update (cached) eol_len correctly 30 | 31 | 1.99 2019-01-02 32 | - Fixed a number of tests to skip for older perls 33 | 34 | 1.98 2019-01-02 35 | - Imported tests/fixes from Text::CSV_XS 1.38 36 | - Added munge as alias for munge_column_names 37 | - Added support for key-value pair and combined keys 38 | 39 | 1.97 2018-08-17 40 | - Fix/add minimum perl version (GH-38, Kivanc Yazan++) 41 | - Updated MANIFEST 42 | 43 | 1.96 2018-08-14 44 | - Imported tests/fixes from Text::CSV_XS 1.36 45 | - Added undef_str and keep_headers attributes 46 | - Added csv(out => \"skip") 47 | - Added formula actions 48 | - Fixed BOM issues 49 | - Fixed internal cache handling 50 | - Added license and preferred issue tracker to META files (GH#26, garu++) 51 | 52 | 1.95 2017-04-27 53 | - import "strict" attribute introduced in Text::CSV_XS 1.29 54 | 55 | 1.94 2017-04-11 56 | - Fix 5.6.2 issues 57 | 58 | 1.93 2017-04-04 59 | - Fix a test for perl without doc in @INC (kentnl++) 60 | 61 | 1.92 2017-04-01 62 | - Imported tests/fixes from Text::CSV_XS 1.28 63 | - Fix crlf issue for csv () on Windows (RT#120466) 64 | - New error code for illegal argument(s)/parameter(s) 65 | - Fix tests for perl without dot in @INC 66 | 67 | 1.91 2017-01-28 68 | - production release 69 | 70 | 1.90_01 2017-01-20 71 | - Text::CSV_PP is totally refactored using the code/doc of 72 | Text::CSV_XS 1.27. Almost all the code/docs in CSV_XS.pm are 73 | copied and a large portion of CSV_XS.xs is ported verbatim, 74 | and now CSV_PP passes all the tests for CSV_XS (with slight 75 | modification like s/XS/PP/g). 76 | 77 | 1.33 Tue Mar 3 14:13:41 2015 78 | - Fix some reported bugs with handling fields with zeros. 79 | https://rt.cpan.org/Public/Bug/Display.html?id=93518 80 | https://rt.cpan.org/Public/Bug/Display.html?id=92509 81 | patched by shlomif 82 | - catch up Text::CSV_XS 1.02 83 | * add decode_utf8 attribute by ktat 84 | - fix warnings: $. is undefined by ktat 85 | - typo fixes in doc by anirvan, dsteinbrunner and pdl. 86 | - parse() supports bind_columns() 87 | 88 | * TODO: Updating documents and adding diag_verbose in the next version. 89 | Catching up CSV_XS 1.04. 90 | 91 | 1.32 92 | - fix t/rt71_pp.t 93 | 94 | 1.31 Thu Jun 13 14:06:49 2013 95 | - fix handling UTF8 in parse method. 96 | - fix getline with allow_loose_quotes (rt#83705) 97 | - add allow_unquoted_escape 98 | - fix parsing escapted sep char (found in Text::CSV_XS rt#81295) 99 | 100 | 1.30 Tue Jun 11 00:06:02 2013 101 | - catch up Text::CSV_XS 0.99 102 | (except for diag_verbose and allow_unquoted_escape) 103 | 104 | 1.21 Mon Dec 27 12:35:35 2010 105 | - updated the compatibility for Text::CSV_XS version 0.80 106 | * added getline_all() and getaline_hr_all() 107 | * added missing test file 108 | 109 | 1.20 Wed Oct 20 13:53:59 2010 110 | - couldn't parse the csv containing the column starting with '0'. (hiratara) 111 | * patched by hiratara 112 | * enhanced getline regexp (makamaka) 113 | * resolved a bug in bleadperl-fb85c04 114 | - added tests into t/71_pp.t (hiratara) 115 | 116 | 1.19 Sat Oct 2 14:15:59 2010 117 | - getline didn't work correctly with 0 or null containing lines 118 | (pointed by Bernhard Prott) 119 | - updated the compatibility for Text::CSV_XS version 0.74 120 | * real eol support for parsing streams (beyond \n, \r and \r\n) 121 | * clarify doc for always_quote to not quote undef fields 122 | and XS and PP incompatibility of UTF8 process for print and combine 123 | 124 | 1.18 Sat Jun 19 10:34:07 2010 125 | - fixed a combine bug with quote_space reported and patched by rt#58356 126 | - updated test files compatible to CSV_XS 0.73 127 | 128 | 1.17 Tue Mar 16 15:20:34 2010 129 | - fixed parse working when setting quote_char undef. 130 | - made Text::CSV_XS compat 0.71 131 | * Text::CSV->error_diag() in void context warns instead of doing nothing 132 | * auto_diag also used for new () itself 133 | - added quote_null (introduced in Text::CSV_XS 0.72) 134 | 135 | 1.16 Tue Dec 8 19:02:58 2009 136 | - updated the compatibility for Text::CSV_XS version 0.70 137 | * Added quote_space attribute 138 | * Forbad \r and \n in sep_char, quote_char, and escape_char 139 | 140 | 1.15 Thu Oct 15 17:23:39 2009 141 | - updated the compatibility for Text::CSV_XS version 0.69 142 | * Auto detection of eol => "\r" in streams 143 | (but incomplete correspondence. I will rewrite CSV_PP in the future) 144 | 145 | 1.14 Thu Oct 8 15:02:24 2009 146 | - updated the compatibility for Text::CSV_XS version 0.68 147 | * fail if first arg to new () is not a hash ref 148 | * added empty_is_undef 149 | * error_diag () uses warn () in void context instead of STDERR 150 | * added auto_diag attribute 151 | (not yet implemented localization feature for autodie) 152 | * updated documents same as Text::CSV_XS 153 | 154 | 1.13 Fri Jul 31 12:02:53 2009 155 | - getline() didn't handle '0' starting multi line data 156 | (pointed by Diego Santa Cruz). 157 | 158 | 1.12 Sat May 16 10:46:38 2009 159 | - updated the compatibility for Text::CSV_XS version 0.65 160 | * new()ing errors can be checked on number (1002) 161 | * modified doc for error_diag() return value in case of constructor failure 162 | - parse() didn't set the given string ref into {_STRING}. (rt#45215) 163 | - getline() didn't handle a line having null (ex. "0) 164 | 165 | 1.11 Sat Mar 21 16:07:29 2009 166 | - updated the compatibility for Text::CSV_XS version 0.63 167 | * added error 1002 168 | - updated the compatibility for Text::CSV_XS version 0.58 169 | * fixed allow_loose_escapes bug 170 | 171 | 1.10 Wed Oct 22 02:34:03 2008 172 | - updated the compatibility for Text::CSV_XS version 0.56 173 | * updated docs 174 | * setting eol with undef are treated as "" 175 | * in print method, don't print $\ twice 176 | * undef treated as 0 for boolean attributes 177 | 178 | 1.09 Fri Sep 5 11:34:00 2008 179 | - updated the compatibility for Text::CSV_XS version 0.54 180 | * default eol for print is $\ 181 | * fixed SetDiag(0) 182 | * IO failure in print 183 | 184 | **** Text::CSV_PP doesn't support the error msg 2023 **** 185 | 186 | 1.08 Fri Aug 22 11:21:38 2008 187 | - fixed a bug in parsing tab separated values with allow_whitespace 188 | pointed by and thanks a patch to Mike O'Sullivan 189 | 190 | 1.07 Fri Aug 1 11:13:06 2008 191 | - updated the compatibility for Text::CSV_XS version 0.52 192 | modified column_names() 193 | - fixed a parsing bug with quote_char being undef 194 | pointed by Matt (rt#38083) 195 | 196 | 1.06 Wed Jun 18 14:35:40 2008 197 | - updated the compatibility for Text::CSV_XS version 0.51 198 | * set binary => 1 when UTF8 flag marked. 199 | * removed the max of 255 for bind_columns. 200 | - made the value type of $csv->{_STRING} corresponding to XS. 201 | 202 | 1.05 Fri May 2 13:15:49 2008 203 | - fixed quoting process in combine. 204 | because of using bytes.pm, added a dummy for Perl 5.005 205 | - renamed combine, parse, string and fields internally. 206 | (for coming Text::CSV::Encoded) 207 | - removed dynamic mode. 208 | 209 | 1.04 Tue Apr 22 16:01:19 2008 210 | - updated the compatibility for Text::CSV_XS version 0.43 211 | * parse errors try to remember failing position 212 | (but in using PP version backend, it is usually helpless) 213 | - fix a serious bug with setter methods. 214 | all setter methods couldn't take undef value... 215 | 216 | 1.03 Fri Apr 11 17:39:12 2008 217 | - updated the compatibility for Text::CSV_XS version 0.41 218 | getline_hr, column_names, bind_columns 219 | - Makefile.PL requires Perl versoin from 5.005 to 5.00503. 220 | - fixed combine() for quoting binary chars. 221 | - updated the document as same as Text::CSV_XS 0.41. 222 | 223 | 1.02 Fri Mar 7 07:37:11 2008 224 | - updated the compatibility for Text::CSV_XS version 0.36 225 | * auto-load IO::Handle when needed 226 | - fixed version() and its doc (Text::CSV and Text::CSV_PP). 227 | Text::CSV->version returns the worker module version. 228 | Thanks to Robin Barker's patche. 229 | 230 | 1.01 Tue Mar 4 02:33:28 2008 231 | - updated the compatibilities for Text::CSV_XS version 0.35 232 | * diagnostics for failed new () 233 | * 'blank_is_undef' option 234 | * enhanced the error messages 235 | - updated docs 236 | - fixed allow_whitespace() 237 | - modifiled t/80_diag.t for overloaded error object. 238 | 239 | 1.00 Wed Nov 28 14:28:30 2007 240 | - renamed $ENV{TEXT_CSV_XS} to $ENV{PERL_TEXT_CSV} 241 | - added $ENV{PERL_TEXT_CSV} acceptable values 242 | - deleted the dynamic mode section from the pod doc 243 | - deleted t/exp01-dynamic.t 244 | (the feature still remains.) 245 | 246 | 247 | 0.99_06 Thu Nov 8 13:24:31 2007 248 | - modified _set_methods for Pod::Coverage test 249 | - added t/exp01-dynamic.t 250 | 251 | 0.99_05 Wed Nov 7 16:15:34 2007 (Text::CSV_PP 1.08) 252 | - added 'dynamic mode' which can specify the worker module in new()ing 253 | This is so experimental that may be removed. 254 | - modified prototypes of Text::CSV_PP::NV, IV, PV 255 | 256 | 0.99_04 Tue Nov 6 13:40:47 2007 (Text::CSV_PP 1.07) 257 | - re-rename Text::CSV_PP 258 | - added TODO 259 | 260 | 0.99_03 Mon Nov 5 16:00:00 2007 261 | - CPAN released but beta version. 262 | - test suits are from Text::CSV_XS 0.32 and modfied for Text::CSV tests. 263 | 264 | 0.99_02 Fri Nov 2 14:37:30 2007 265 | - pre release version. 266 | - passed the all Text::CSV_XS 0.32 test suits 267 | 268 | 0.99 Sat Jun 23 17:10:47 2007 269 | - maintainer was changed. 270 | - rewritten to make a wrapper to Text::CSV_XS and Text::CSV_PP 271 | 272 | 0.01 06/05/1997 273 | - original version by Alan Citterman 274 | 275 | -------------------------------------------------------------------------------- /t/71_pp.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | # tests for bug report fixes or patches. 4 | 5 | use strict; 6 | $^W = 1; 7 | 8 | use Test::More tests => 104; 9 | 10 | 11 | BEGIN { $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; } 12 | 13 | BEGIN { 14 | require_ok "Text::CSV"; 15 | plan skip_all => "Cannot load Text::CSV" if $@; 16 | } 17 | 18 | #warn Text::CSV->backend; 19 | 20 | my $csv = Text::CSV->new( { sep_char => "\t", blank_is_undef => 1, allow_whitespace => 1 } ); 21 | 22 | ok $csv->parse(qq|John\t\t"my notes"|); 23 | 24 | is_deeply ([ $csv->fields ], [ "John", undef, "my notes" ], "Tab with allow_white_space"); 25 | 26 | 27 | 28 | # 2009-04-23 rt#45215 29 | 30 | my $str = "this,is,some,csv,data\n"; 31 | 32 | $csv = Text::CSV->new; 33 | $csv->parse($str); 34 | 35 | is( $csv->string, $str ); 36 | 37 | #=pod 38 | 39 | # 2009-05-16 40 | # getline() handles having escaped null 41 | 42 | my $opts = { 43 | 'escape_char' => '"', 44 | 'quote_char' => '"', 45 | 'binary' => 1, 46 | 'sep_char' => ',' 47 | }; 48 | 49 | my $eol = "\r\n"; 50 | my $blob = ( join "", map { chr $_ } 0 .. 255 ) x 1; 51 | #my $blob = ( join "", map { chr $_ } 0 .. 2 ) x 1; 52 | 53 | $csv = Text::CSV->new( $opts ); 54 | 55 | open( FH, '>__test.csv' ) or die $!; 56 | binmode FH; 57 | 58 | # writting 59 | ok( $csv->print( *FH, [ $blob ] ) ); 60 | close( FH ); 61 | 62 | # reading 63 | open( FH, "__test.csv" ) or die $!; 64 | binmode FH; 65 | 66 | $opts->{eol} = $eol; 67 | $csv = Text::CSV->new( $opts ); 68 | 69 | ok( my $colref = $csv->getline( *FH ) ); 70 | 71 | is( $colref->[0], $blob, "blob" ); 72 | 73 | close( FH ); 74 | 75 | #exit; 76 | unlink( '__test.csv' ); 77 | 78 | #=cut 79 | 80 | # 2009-07-30 81 | # getline() handles a 0 staring multiline 82 | 83 | 84 | # writting 85 | open( FH, '>__test.csv' ) or die $!; 86 | binmode FH; 87 | 88 | 89 | ok( $csv->print( *FH, [ "00" ] ) ); 90 | ok( $csv->print( *FH, [ "\00" ] ) ); 91 | ok( $csv->print( *FH, [ "0\0" ] ) ); 92 | ok( $csv->print( *FH, [ "\0\0" ] ) ); 93 | 94 | ok( $csv->print( *FH, [ "0\n0" ] ) ); 95 | ok( $csv->print( *FH, [ "\0\n0" ] ) ); 96 | ok( $csv->print( *FH, [ "0\n\0" ] ) ); 97 | ok( $csv->print( *FH, [ "\0\n\0" ] ) ); 98 | 99 | ok( $csv->print( *FH, [ "\"0\n0" ] ) ); 100 | ok( $csv->print( *FH, [ "\"\0\n0" ] ) ); 101 | ok( $csv->print( *FH, [ "\"0\n\0" ] ) ); 102 | ok( $csv->print( *FH, [ "\"\0\n\0" ] ) ); 103 | 104 | ok( $csv->print( *FH, [ "\"0\n\"0" ] ) ); 105 | ok( $csv->print( *FH, [ "\"\0\n\"0" ] ) ); 106 | ok( $csv->print( *FH, [ "\"0\n\"\0" ] ) ); 107 | ok( $csv->print( *FH, [ "\"\0\n\"\0" ] ) ); 108 | 109 | ok( $csv->print( *FH, [ "0\n0", "0\n0" ] ) ); 110 | ok( $csv->print( *FH, [ "\0\n0", "\0\n0" ] ) ); 111 | ok( $csv->print( *FH, [ "0\n\0", "0\n\0" ] ) ); 112 | ok( $csv->print( *FH, [ "\0\n\0", "\0\n\0" ] ) ); 113 | 114 | $csv->always_quote(1); 115 | 116 | ok( $csv->print( *FH, [ "", undef, "0\n", "", "\0\n0" ] ) ); 117 | 118 | 119 | close( FH ); 120 | 121 | # reading 122 | open( FH, "__test.csv" ) or die $!; 123 | binmode FH; 124 | 125 | is( $csv->getline( *FH )->[0], "00", '*00' ); # Test::More warns 00 126 | is( $csv->getline( *FH )->[0], "\00", '\00' ); 127 | is( $csv->getline( *FH )->[0], "0\0", '0\0' ); 128 | is( $csv->getline( *FH )->[0], "\0\0", '\0\0' ); 129 | 130 | is( $csv->getline( *FH )->[0], "0\n0", '*0\n0' ); # Test::More warns 00 131 | is( $csv->getline( *FH )->[0], "\0\n0", '\0\n0' ); 132 | is( $csv->getline( *FH )->[0], "0\n\0", '0\n\0' ); 133 | is( $csv->getline( *FH )->[0], "\0\n\0", '\0\n\0' ); 134 | 135 | is( $csv->getline( *FH )->[0], "\"0\n0", '\"0\n0' ); 136 | is( $csv->getline( *FH )->[0], "\"\0\n0", '\"\0\n0' ); 137 | is( $csv->getline( *FH )->[0], "\"0\n\0", '\"0\n\0' ); 138 | is( $csv->getline( *FH )->[0], "\"\0\n\0", '\"\0\n\0' ); 139 | 140 | is( $csv->getline( *FH )->[0], "\"0\n\"0", '\"0\n\"0' ); 141 | is( $csv->getline( *FH )->[0], "\"\0\n\"0", '\"\0\n\"0' ); 142 | is( $csv->getline( *FH )->[0], "\"0\n\"\0", '\"0\n\"\0' ); 143 | is( $csv->getline( *FH )->[0], "\"\0\n\"\0", '\"\0\n\"\0' ); 144 | 145 | is( $csv->getline( *FH )->[1], "0\n0", '*0\n0' ); # Test::More warns 00 146 | is( $csv->getline( *FH )->[1], "\0\n0", '\0\n0' ); 147 | is( $csv->getline( *FH )->[1], "0\n\0", '0\n\0' ); 148 | is( $csv->getline( *FH )->[1], "\0\n\0", '\0\n\0' ); 149 | 150 | $csv->blank_is_undef(1); 151 | 152 | my $col = $csv->getline( *FH ); 153 | 154 | is( $col->[0], "", '' ); 155 | is( $col->[1], undef, '' ); 156 | is( $col->[2], "0\n", '' ); 157 | is( $col->[3], "", '' ); 158 | is( $col->[4], "\0\n0", '' ); 159 | 160 | close( FH ); 161 | 162 | unlink( '__test.csv' ); 163 | 164 | # 2010-06-18 reported by https://rt.cpan.org/Public/Bug/Display.html?id=58356 165 | 166 | $csv = Text::CSV->new ({ binary => 1, quote_space => 0 }); 167 | my @list = ( 168 | "a a", 169 | "b,b", 170 | "c ,c", 171 | ); 172 | 173 | ok( $csv->combine( @list ) ); 174 | is( $csv->string, q{a a,"b,b","c ,c"} ); 175 | 176 | 177 | # 2010-06-22 reported 178 | { 179 | $csv = Text::CSV->new ({ binary => 1, sep_char => ';', always_quote => 1 }); 180 | 181 | open( FH, '>__test.csv' ) or die $!; 182 | binmode FH; 183 | 184 | ok( $csv->print( *FH, [ 0, qq{t"t"\n} ] ) ); 185 | 186 | close( FH ); 187 | 188 | open( FH, "__test.csv" ) or die $!; 189 | binmode FH; 190 | 191 | my $col = $csv->getline( *FH ); 192 | 193 | is( $col->[0], "0" ); 194 | is( $col->[1], qq{t"t"\n} ); 195 | close( FH ); 196 | 197 | unlink( '__test.csv' ); 198 | } 199 | 200 | 201 | # 2010-10-13 reported by hiratara 202 | { 203 | $csv = Text::CSV->new ({ binary => 1, eol => $/, always_quote => 1 }); 204 | 205 | open( FH, '>__test.csv' ) or die $!; 206 | binmode FH; 207 | 208 | ok( $csv->print( *FH, [qw/A 01/] ) ); 209 | ok( $csv->print( *FH, [qw/B 02/] ) ); 210 | close( FH ); 211 | 212 | open( FH, "__test.csv" ) or die $!; 213 | binmode FH; 214 | 215 | my $col = $csv->getline( *FH ); 216 | 217 | is( $col->[0], 'A' ); 218 | is( $col->[1], '01' ); 219 | 220 | $col = $csv->getline( *FH ); 221 | 222 | is( $col->[0], 'B' ); 223 | is( $col->[1], '02' ); 224 | close( FH ); 225 | 226 | unlink( '__test.csv' ); 227 | } 228 | 229 | 230 | # 2010-10-13 reported(2) by hiratara 231 | { 232 | $csv = Text::CSV->new ({ binary => 1, eol => $/ }); 233 | 234 | open( FH, '>__test.csv' ) or die $!; 235 | binmode FH; 236 | 237 | ok( $csv->print( *FH, [qw/1 0"/] ) ); 238 | ok( $csv->print( *FH, [qw/2 0"/] ) ); 239 | close( FH ); 240 | 241 | open( FH, "__test.csv" ) or die $!; 242 | binmode FH; 243 | 244 | my $col = $csv->getline( *FH ); 245 | 246 | is( $col->[0], '1' ); 247 | is( $col->[1], '0"' ); 248 | 249 | $col = $csv->getline( *FH ); 250 | 251 | is( $col->[0], '2' ); 252 | is( $col->[1], '0"' ); 253 | 254 | close( FH ); 255 | 256 | unlink( '__test.csv' ); 257 | } 258 | 259 | 260 | { # previous three test merged 261 | $csv = Text::CSV->new ({ binary => 1, eol => $/ }); 262 | 263 | open( FH, '>__test.csv' ) or die $!; 264 | binmode FH; 265 | 266 | ok( $csv->print( *FH, [ 0, qq{t"t"\n} ] ) ); 267 | ok( $csv->print( *FH, [qw/A 01/] ) ); 268 | ok( $csv->print( *FH, [qw/1 0"/] ) ); 269 | ok( $csv->print( *FH, [undef,undef] ) ); 270 | ok( $csv->print( *FH, [qw/1 0"/] ) ); 271 | ok( $csv->print( *FH, [qw/A 01/] ) ); 272 | close( FH ); 273 | 274 | open( FH, "__test.csv" ) or die $!; 275 | binmode FH; 276 | 277 | my $col = $csv->getline( *FH ); 278 | is( $col->[0], "0" ); 279 | is( $col->[1], qq{t"t"\n} ); 280 | 281 | $col = $csv->getline( *FH ); 282 | is( $col->[0], 'A' ); 283 | is( $col->[1], '01' ); 284 | 285 | $col = $csv->getline( *FH ); 286 | is( $col->[0], '1' ); 287 | is( $col->[1], '0"' ); 288 | 289 | $col = $csv->getline( *FH ); 290 | is( $col->[0], '' ); 291 | is( $col->[1], '' ); 292 | 293 | $col = $csv->getline( *FH ); 294 | is( $col->[0], '1' ); 295 | is( $col->[1], '0"' ); 296 | 297 | $col = $csv->getline( *FH ); 298 | is( $col->[0], 'A' ); 299 | is( $col->[1], '01' ); 300 | close( FH ); 301 | 302 | unlink( '__test.csv' ); 303 | } 304 | 305 | 306 | SKIP: { # https://rt.cpan.org/Ticket/Display.html?id=83705 307 | skip "pp only for now", 3 unless Text::CSV->is_pp; 308 | 309 | my $csv = Text::CSV->new( 310 | { 311 | binary => 1, 312 | allow_loose_escapes => 1, 313 | allow_loose_quotes => 1, 314 | sep_char => q{;}, 315 | escape_char => q{"}, 316 | quote_char => q{"} 317 | } 318 | ); 319 | 320 | $csv->parse(q{"6RE";"EINKAUF";"5";"";"2,5" HD"}); 321 | is_deeply([$csv->fields], ["6RE","EINKAUF","5","",'2,5" HD']); 322 | 323 | my $csv_dump = q{"6RE";"EINKAUF";"5";"";"2,5" HD" 324 | "LIDL";"-2"}; 325 | 326 | open( FH, '>__test.csv' ) or die $!; 327 | print FH $csv_dump; 328 | close FH; 329 | 330 | open FH, '<__test.csv'; 331 | 332 | is_deeply( $csv->getline(*FH), ["6RE","EINKAUF","5","",'2,5" HD'] ); 333 | is_deeply( $csv->getline(*FH), ['LIDL','-2'] ); 334 | 335 | close FH; 336 | 337 | unlink( '__test.csv' ); 338 | 339 | } 340 | 341 | { # imported from t/70_rt.t 342 | my $csv = Text::CSV->new ({ escape_char => "\\", auto_diag => 1 }); 343 | 344 | ok( $csv->parse(q{1,"\,",3}) ); 345 | is_deeply ([ $csv->fields ], [ 1, ",", 3 ], "escaped sep in quoted field"); 346 | ok( $csv->parse(q{1,"2\,4",3}) ); 347 | is_deeply ([ $csv->fields ], [ 1, "2,4", 3 ], "escaped sep in quoted field"); 348 | 349 | $csv->allow_unquoted_escape(1); 350 | ok( $csv->parse(q{1,\,,3}) ); 351 | is_deeply ([ $csv->fields ], [ 1, ",", 3 ], "escaped sep in quoted field"); 352 | ok( $csv->parse(q{1,2\,4,3}) ); 353 | is_deeply ([ $csv->fields ], [ 1, "2,4", 3 ], "escaped sep in quoted field"); 354 | } 355 | 356 | { # https://github.com/makamaka/Text-CSV/pull/3 357 | 358 | { 359 | package FakeFileHandleForEOF; 360 | 361 | sub new { return bless { line => "foo,bar,baz\n" }, shift } 362 | 363 | sub getline { 364 | my $self = shift; 365 | return delete $self->{line}; 366 | } 367 | 368 | sub eof { 369 | my $self = shift; 370 | return not exists $self->{line}; 371 | } 372 | } 373 | 374 | my $csv = Text::CSV->new({binary => 1}); 375 | my $fh = FakeFileHandleForEOF->new; 376 | ok(!$fh->eof); 377 | eval { is_deeply( $csv->getline($fh), [qw[ foo bar baz ]]) }; 378 | is($@, '', "no exception thrown"); 379 | ok($fh->eof); 380 | } 381 | 382 | { # https://github.com/makamaka/Text-CSV/issues/14 383 | # https://rt.cpan.org/Ticket/Display.html?id=109719 384 | SKIP: { 385 | skip "requires Encode", 1 unless eval "require Encode"; 386 | my $csv = Text::CSV->new({empty_is_undef => 1, blank_is_undef => 1}); 387 | my $line = "foo,,bar,"; 388 | Encode::_utf8_on($line); 389 | $csv->parse($line); 390 | my @fields = $csv->fields; 391 | is_deeply \@fields => ['foo', undef, 'bar', undef]; 392 | } 393 | } 394 | -------------------------------------------------------------------------------- /t/12_acc.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; # use warnings core since 5.6 5 | 6 | use Test::More tests => 245; 7 | 8 | BEGIN { 9 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 10 | use_ok "Text::CSV"; 11 | plan skip_all => "Cannot load Text::CSV" if $@; 12 | } 13 | 14 | my $Backend = Text::CSV->backend; 15 | 16 | my $csv; 17 | ok ($csv = Text::CSV->new, "new ()"); 18 | 19 | is ($csv->quote_char, '"', "quote_char"); 20 | is ($csv->quote, '"', "quote"); 21 | is ($csv->escape_char, '"', "escape_char"); 22 | is ($csv->sep_char, ",", "sep_char"); 23 | is ($csv->sep, ",", "sep"); 24 | is ($csv->eol, "", "eol"); 25 | is ($csv->always_quote, 0, "always_quote"); 26 | is ($csv->binary, 0, "binary"); 27 | is ($csv->keep_meta_info, 0, "keep_meta_info"); 28 | is ($csv->allow_loose_quotes, 0, "allow_loose_quotes"); 29 | is ($csv->allow_loose_escapes, 0, "allow_loose_escapes"); 30 | is ($csv->allow_unquoted_escape, 0, "allow_unquoted_escape"); 31 | is ($csv->allow_whitespace, 0, "allow_whitespace"); 32 | is ($csv->blank_is_undef, 0, "blank_is_undef"); 33 | is ($csv->empty_is_undef, 0, "empty_is_undef"); 34 | is ($csv->auto_diag, 0, "auto_diag"); 35 | is ($csv->diag_verbose, 0, "diag_verbose"); 36 | is ($csv->verbatim, 0, "verbatim"); 37 | is ($csv->formula, "none", "formula"); 38 | is ($csv->strict, 0, "strict"); 39 | is ($csv->strict_eol, 0, "strict_eol"); 40 | is ($csv->skip_empty_rows, 0, "skip_empty_rows"); 41 | is ($csv->quote_space, 1, "quote_space"); 42 | is ($csv->quote_empty, 0, "quote_empty"); 43 | is ($csv->escape_null, 1, "escape_null"); 44 | is ($csv->quote_null, 1, "quote_null"); 45 | is ($csv->quote_binary, 1, "quote_binary"); 46 | is ($csv->record_number, 0, "record_number"); 47 | is ($csv->decode_utf8, 1, "decode_utf8"); 48 | is ($csv->undef_str, undef, "undef_str"); 49 | is ($csv->comment_str, undef, "comment_str"); 50 | 51 | is ($csv->binary (1), 1, "binary (1)"); 52 | my @fld = ( 'txt =, "Hi!"', "Yes", "", 2, undef, "1.09", "\r", undef ); 53 | ok ($csv->combine (@fld), "combine"); 54 | is ($csv->string, 55 | qq{"txt =, ""Hi!""",Yes,,2,,1.09,"\r",}, "string"); 56 | 57 | is ($csv->sep_char (";"), ";", "sep_char (;)"); 58 | is ($csv->sep ("**"), "**", "sep (**)"); 59 | is ($csv->sep (";"), ";", "sep (;)"); 60 | is ($csv->sep_char (), ";", "sep_char ()"); 61 | is ($csv->quote_char ("="), "=", "quote_char (=)"); 62 | is ($csv->quote_char (undef), undef, "quote_char (undef)"); 63 | is ($csv->{quote_char}, undef, "{quote_char} (undef)"); 64 | is ($csv->quote (undef), "", "quote (undef)"); 65 | is ($csv->quote (""), "", "quote (undef)"); 66 | is ($csv->quote ("**"), "**", "quote (**)"); 67 | is ($csv->quote ("="), "=", "quote (=)"); 68 | is ($csv->eol (undef), "", "eol (undef)"); 69 | is ($csv->eol (""), "", "eol ('')"); 70 | is ($csv->eol ("\r"), "\r", "eol (\\r)"); 71 | is ($csv->keep_meta_info (1), 1, "keep_meta_info (1)"); 72 | is ($csv->keep_meta_info (0), 0, "keep_meta_info (0)"); 73 | is ($csv->keep_meta_info (""), 0, "keep_meta_info ('')"); 74 | is ($csv->keep_meta_info (undef), 0, "keep_meta_info (undef)"); 75 | is ($csv->keep_meta_info ("false"), 0, "keep_meta_info (undef)"); 76 | is ($csv->keep_meta_info ("true"), 1, "keep_meta_info (undef)"); 77 | is ($csv->always_quote (undef), 0, "always_quote (undef)"); 78 | is ($csv->always_quote (1), 1, "always_quote (1)"); 79 | is ($csv->allow_loose_quotes (1), 1, "allow_loose_quotes (1)"); 80 | is ($csv->allow_loose_escapes (1), 1, "allow_loose_escapes (1)"); 81 | is ($csv->allow_unquoted_escape (1), 1, "allow_unquoted_escape (1)"); 82 | is ($csv->allow_whitespace (1), 1, "allow_whitespace (1)"); 83 | is ($csv->blank_is_undef (1), 1, "blank_is_undef (1)"); 84 | is ($csv->empty_is_undef (1), 1, "empty_is_undef (1)"); 85 | is ($csv->auto_diag (1), 1, "auto_diag (1)"); 86 | is ($csv->auto_diag (2), 2, "auto_diag (2)"); 87 | is ($csv->auto_diag (9), 9, "auto_diag (9)"); 88 | is ($csv->auto_diag ("true"), 1, "auto_diag (\"true\")"); 89 | is ($csv->auto_diag ("false"), 0, "auto_diag (\"false\")"); 90 | is ($csv->auto_diag (undef), 0, "auto_diag (undef)"); 91 | is ($csv->auto_diag (""), 0, "auto_diag (\"\")"); 92 | is ($csv->diag_verbose (1), 1, "diag_verbose (1)"); 93 | is ($csv->diag_verbose (2), 2, "diag_verbose (2)"); 94 | is ($csv->diag_verbose (9), 9, "diag_verbose (9)"); 95 | is ($csv->diag_verbose ("true"), 1, "diag_verbose (\"true\")"); 96 | is ($csv->diag_verbose ("false"), 0, "diag_verbose (\"false\")"); 97 | is ($csv->diag_verbose (undef), 0, "diag_verbose (undef)"); 98 | is ($csv->diag_verbose (""), 0, "diag_verbose (\"\")"); 99 | is ($csv->verbatim (1), 1, "verbatim (1)"); 100 | is ($csv->formula ("diag"), "diag", "formula (\"diag\")"); 101 | is ($csv->strict (1), 1, "strict (1)"); 102 | is ($csv->strict_eol (1), 1, "strict_eol (1)"); 103 | is ($csv->skip_empty_rows (1), 1, "skip_empty_rows (1)"); 104 | is ($csv->quote_space (1), 1, "quote_space (1)"); 105 | is ($csv->quote_empty (1), 1, "quote_empty (1)"); 106 | is ($csv->escape_null (1), 1, "escape_null (1)"); 107 | is ($csv->quote_null (1), 1, "quote_null (1)"); 108 | is ($csv->quote_binary (1), 1, "quote_binary (1)"); 109 | is ($csv->escape_char (undef), undef, "escape_char (undef)"); 110 | is ($csv->{escape_char}, undef, "{escape_char} (undef)"); 111 | is ($csv->escape_char ("\\"), "\\", "escape_char (\\)"); 112 | ok ($csv->combine (@fld), "combine"); 113 | is ($csv->string, 114 | qq{=txt \\=, "Hi!"=;=Yes=;==;=2=;;=1.09=;=\r=;\r}, "string"); 115 | is ($csv->undef_str ("-"), "-", "undef_str"); 116 | is ($csv->comment_str ("#"), "#", "comment_str"); 117 | 118 | is ($csv->allow_whitespace (0), 0, "allow_whitespace (0)"); 119 | is ($csv->quote_space (0), 0, "quote_space (0)"); 120 | is ($csv->quote_empty (0), 0, "quote_empty (0)"); 121 | is ($csv->escape_null (0), 0, "escape_null (0)"); 122 | is ($csv->quote_null (0), 0, "quote_null (0)"); 123 | is ($csv->quote_binary (0), 0, "quote_binary (0)"); 124 | is ($csv->decode_utf8 (0), 0, "decode_utf8 (0)"); 125 | is ($csv->sep ("--"), "--", "sep (\"--\")"); 126 | is ($csv->sep_char (), "\0", "sep_char"); 127 | is ($csv->quote ("++"), "++", "quote (\"++\")"); 128 | is ($csv->quote_char (), "\0", "quote_char"); 129 | is ($csv->undef_str (undef), undef, "undef_str"); 130 | is ($csv->comment_str (undef), undef, "comment_str"); 131 | 132 | # Test single-byte specials in UTF-8 mode 133 | is ($csv->sep ("|"), "|", "sep |"); 134 | is ($csv->sep_char (), "|", "sep_char"); 135 | chop (my $s = "|\x{20ac}"); 136 | is ($csv->sep ($s), "|", "sep |"); 137 | is ($csv->sep (), "|", "sep_char"); 138 | is ($csv->sep_char (), "|", "sep_char"); 139 | is ($csv->quote ("'"), "'", "quote '"); 140 | is ($csv->quote_char (), "'", "quote_char"); 141 | chop (my $q = "'\x{20ac}"); 142 | is ($csv->quote ($q), "'", "quote '"); 143 | is ($csv->quote (), "'", "quote_char"); 144 | is ($csv->quote_char (), "'", "quote_char"); 145 | 146 | # Funny settings, all three translate to \0 internally 147 | ok ($csv = Text::CSV->new ({ 148 | sep => "::::::::::", 149 | quote_char => undef, 150 | escape_char => undef, 151 | }), "new (undef ...)"); 152 | is ($csv->sep_char, "\0", "sep_char undef"); 153 | is ($csv->sep, "::::::::::", "sep long"); 154 | is ($csv->quote_char, undef, "quote_char undef"); 155 | is ($csv->quote, undef, "quote undef"); 156 | is ($csv->escape_char, undef, "escape_char undef"); 157 | ok ($csv->parse ("foo"), "parse (foo)"); 158 | $csv->sep_char (","); 159 | is ($csv->record_number, 1, "record_number"); 160 | ok ($csv->parse ("foo"), "parse (foo)"); 161 | is ($csv->record_number, 2, "record_number"); 162 | ok (!$csv->parse ("foo,foo\0bar"), "parse (foo)"); 163 | $csv->escape_char ("\\"); 164 | ok (!$csv->parse ("foo,foo\0bar"), "parse (foo)"); 165 | $csv->binary (1); 166 | ok ( $csv->parse ("foo,foo\0bar"), "parse (foo)"); 167 | 168 | # Attribute aliasses 169 | ok ($csv = Text::CSV->new ({ quote_always => 1, verbose_diag => 1})); 170 | is ($csv->always_quote, 1, "always_quote = quote_always"); 171 | is ($csv->diag_verbose, 1, "diag_verbose = verbose_diag"); 172 | ok ($csv = Text::CSV->new ({ escape_char => undef }), "undef escape aliases"); 173 | is ($csv->escape_char, undef, "escape_char is undef"); 174 | ok ($csv = Text::CSV->new ({ quote => undef }), "undef quote aliases"); 175 | is ($csv->quote_char, undef, "quote_char is undef"); 176 | is ($csv->quote, undef, "quote is undef"); 177 | 178 | # Some forbidden combinations 179 | foreach my $ws (" ", "\t") { 180 | ok ($csv = Text::CSV->new ({ escape_char => $ws }), "New blank escape"); 181 | eval { ok ($csv->allow_whitespace (1), "Allow ws") }; 182 | is (($csv->error_diag)[0], 1002, "Wrong combo"); 183 | ok ($csv = Text::CSV->new ({ quote_char => $ws }), "New blank quote"); 184 | eval { ok ($csv->allow_whitespace (1), "Allow ws") }; 185 | is (($csv->error_diag)[0], 1002, "Wrong combo"); 186 | ok ($csv = Text::CSV->new ({ allow_whitespace => 1 }), "New ws 1"); 187 | eval { ok ($csv->escape_char ($ws), "esc") }; 188 | is (($csv->error_diag)[0], 1002, "Wrong combo"); 189 | ok ($csv = Text::CSV->new ({ allow_whitespace => 1 }), "New ws 1"); 190 | eval { ok ($csv->quote_char ($ws), "esc") }; 191 | is (($csv->error_diag)[0], 1002, "Wrong combo"); 192 | } 193 | foreach my $esc (undef, "", " ", "\t", "!!!!!!") { 194 | foreach my $quo (undef, "", " ", "\t", "!!!!!!") { 195 | defined $esc && $esc =~ m/[ \t]/ or 196 | defined $quo && $quo =~ m/[ \t]/ or next; 197 | my $wc = join " " => map { 198 | !defined $_ ? "" : 199 | $_ eq "" ? "" : 200 | $_ eq " " ? "" : 201 | $_ eq "\t" ? "" : $_ } 202 | "esc:", $esc, "quo:", $quo; 203 | eval { $csv = Text::CSV->new ({ 204 | escape => $esc, 205 | quote => $quo, 206 | allow_whitespace => 1, 207 | }) }; 208 | like ((Text::CSV::error_diag)[1], qr{^INI - allow_whitespace}, "Wrong combo - error message: $wc"); 209 | is ((Text::CSV::error_diag)[0], 1002, "Wrong combo - numeric error: $wc"); 210 | } 211 | } 212 | 213 | # Test 1003 in constructor 214 | foreach my $x ("\r", "\n", "\r\n", "x\n", "\rx") { 215 | foreach my $attr (qw( sep_char quote_char escape_char )) { 216 | #ok (1, "attr: $attr => ", $x =~ s/\n/\\n/gr =~ s/\r/\\r/gr); 217 | eval { $csv = Text::CSV->new ({ $attr => $x }) }; 218 | is ((Text::CSV::error_diag)[0], 1003, "eol in $attr"); 219 | } 220 | } 221 | # Test 1003 in methods 222 | foreach my $attr (qw( sep_char quote_char escape_char )) { 223 | ok ($csv = Text::CSV->new, "New"); 224 | eval { ok ($csv->$attr ("\n"), "$attr => \\n") }; 225 | is (($csv->error_diag)[0], 1003, "not allowed"); 226 | } 227 | 228 | # Too long attr (max 16) 229 | $csv = Text::CSV->new ({ quote => "'" }); 230 | my $xl = "X" x 32; 231 | eval { $csv->eol ($xl); }; 232 | is (($csv->error_diag)[0], 1005, "eol too long"); 233 | is ($csv->eol (), "", "eol unchanged"); 234 | eval { $csv->sep ($xl); }; 235 | is (($csv->error_diag)[0], 1006, "sep too long"); 236 | is ($csv->sep (), ",", "sep unchanged"); 237 | eval { $csv->quote ($xl); }; 238 | is (($csv->error_diag)[0], 1007, "quo too long"); 239 | is ($csv->quote (), "'", "quo unchanged"); 240 | eval { $csv = Text::CSV->new ({ eol => $xl }); }; 241 | is ($csv, undef, "new with EOL too long"); 242 | is ((Text::CSV::error_diag)[0], 1005, "error set"); 243 | eval { $csv = Text::CSV->new ({ sep => $xl }); }; 244 | is ($csv, undef, "new with SEP too long"); 245 | is ((Text::CSV::error_diag)[0], 1006, "error set"); 246 | eval { $csv = Text::CSV->new ({ quote => $xl }); }; 247 | is ($csv, undef, "new with QUO too long"); 248 | is ((Text::CSV::error_diag)[0], 1007, "error set"); 249 | 250 | # And test erroneous calls 251 | is (Text::CSV::new (0), undef, "new () as function"); 252 | is (Text::CSV::error_diag (), "usage: my \$csv = $Backend->new ([{ option => value, ... }]);", 253 | "Generic usage () message"); 254 | is (Text::CSV->new ({ oel => "" }), undef, "typo in attr"); 255 | is (Text::CSV::error_diag (), "INI - Unknown attribute 'oel'", "Unsupported attr"); 256 | is (Text::CSV->new ({ _STATUS => "" }), undef, "private attr"); 257 | is (Text::CSV::error_diag (), "INI - Unknown attribute '_STATUS'", "Unsupported private attr"); 258 | 259 | foreach my $arg (undef, 0, "", " ", 1, [], [ 0 ], *STDOUT) { 260 | is (Text::CSV->new ($arg), undef, "Illegal type for first arg"); 261 | is ((Text::CSV::error_diag)[0], 1000, "Should be a hashref - numeric error"); 262 | } 263 | 264 | my $attr = [ sort qw( 265 | eol 266 | sep_char sep quote_char quote escape_char 267 | binary decode_utf8 268 | auto_diag diag_verbose 269 | blank_is_undef empty_is_undef 270 | allow_whitespace allow_loose_quotes allow_loose_escapes allow_unquoted_escape 271 | always_quote quote_space quote_empty quote_binary 272 | escape_null 273 | keep_meta_info 274 | verbatim strict strict_eol skip_empty_rows formula 275 | undef_str comment_str 276 | types 277 | callbacks 278 | ENCODING 279 | )]; 280 | is_deeply ([ Text::CSV::known_attributes () ], $attr, "Known attributes (function)"); 281 | is_deeply ([ Text::CSV->known_attributes () ], $attr, "Known attributes (class method)"); 282 | is_deeply ([ Text::CSV->new->known_attributes () ], $attr, "Known attributes (method)"); 283 | 284 | 1; 285 | -------------------------------------------------------------------------------- /t/80_diag.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More tests => 316; 7 | #use Test::More "no_plan"; 8 | 9 | my %err; 10 | 11 | BEGIN { 12 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 13 | require_ok "Text::CSV"; 14 | plan skip_all => "Cannot load Text::CSV" if $@; 15 | require "./t/util.pl"; 16 | 17 | open my $fh, "<", "lib/Text/CSV_PP.pm" or die "Cannot read error messages from PP\n"; 18 | while (<$fh>) { 19 | m/^\s+([0-9]{4}) => "([^"]+)"/ and $err{$1} = $2; 20 | } 21 | close $fh; 22 | } 23 | 24 | my $tfn = "_80test.csv"; END { -f $tfn and unlink $tfn; } 25 | $| = 1; 26 | 27 | my $csv = Text::CSV->new (); 28 | is (Text::CSV::error_diag (), "", "Last failure for new () - OK"); 29 | is_deeply ([ $csv->error_diag ], [ 0, "", 0, 0, 0, 0 ], "OK in list context"); 30 | 31 | sub parse_err { 32 | my ($n_err, $p_err, $r_err, $f_err, $str) = @_; 33 | my $s_err = $err{$n_err}; 34 | my $STR = _readable ($str); 35 | is ($csv->parse ($str), 0, "$n_err - Err for parse ('$STR')"); 36 | is ($csv->error_diag () + 0, $n_err, "$n_err - Diag in numerical context"); 37 | is ($csv->error_diag (), $s_err, "$n_err - Diag in string context"); 38 | my ($c_diag, $s_diag, $p_diag, $r_diag, $f_diag) = $csv->error_diag (); 39 | is ($c_diag, $n_err, "$n_err - Num diag in list context"); 40 | is ($s_diag, $s_err, "$n_err - Str diag in list context"); 41 | is ($p_diag, $p_err, "$n_err - Pos diag in list context"); 42 | is ($r_diag, $r_err, "$n_err - Rec diag in list context"); 43 | is ($f_diag, $f_err, "$n_err - Fld diag in list context"); 44 | } # parse_err 45 | 46 | parse_err 2023, 19, 1, 2, qq{2023,",2008-04-05,"Foo, Bar",\n}; # " 47 | 48 | $csv = Text::CSV->new ({ escape_char => "+", eol => "\n" }); 49 | is ($csv->error_diag (), "", "No errors yet"); 50 | 51 | parse_err 2010, 3, 1, 1, qq{"x"\r}; 52 | parse_err 2011, 4, 2, 1, qq{"x"x}; 53 | 54 | parse_err 2021, 2, 3, 1, qq{"\n"}; 55 | parse_err 2022, 2, 4, 1, qq{"\r"}; 56 | parse_err 2025, 2, 5, 1, qq{"+ "}; 57 | parse_err 2026, 2, 6, 1, qq{"\0 "}; 58 | parse_err 2027, 1, 7, 1, '"'; 59 | parse_err 2031, 1, 8, 1, qq{\r }; 60 | parse_err 2032, 2, 9, 1, qq{ \r}; 61 | parse_err 2034, 4, 10, 2, qq{1, "bar",2}; 62 | parse_err 2037, 1, 11, 1, qq{\0 }; 63 | 64 | { my @warn; 65 | local $SIG{__WARN__} = sub { push @warn => @_ }; 66 | $csv->error_diag (); 67 | ok (@warn == 1, "Got error message"); 68 | like ($warn[0], qr{^# CSV_(?:PP|XS) ERROR: 2037 - EIF}, "error content"); 69 | } 70 | 71 | is ($csv->eof, "", "No EOF"); 72 | $csv->SetDiag (2012); 73 | is ($csv->eof, 1, "EOF caused by 2012"); 74 | 75 | is (Text::CSV->new ({ ecs_char => ":" }), undef, "Unsupported option"); 76 | 77 | { my @warn; 78 | local $SIG{__WARN__} = sub { push @warn => @_ }; 79 | Text::CSV::error_diag (); 80 | ok (@warn == 1, "Error_diag in void context ::"); 81 | like ($warn[0], qr{^# CSV_(?:PP|XS) ERROR: 1000 - INI}, "error content"); 82 | } 83 | { my @warn; 84 | local $SIG{__WARN__} = sub { push @warn => @_ }; 85 | Text::CSV->error_diag (); 86 | ok (@warn == 1, "Error_diag in void context ->"); 87 | like ($warn[0], qr{^# CSV_(?:PP|XS) ERROR: 1000 - INI}, "error content"); 88 | } 89 | 90 | { my @warn; 91 | local $SIG{__WARN__} = sub { push @warn => @_ }; 92 | is (Text::CSV->new ({ auto_diag => 0, ecs_char => ":" }), undef, 93 | "Unsupported option"); 94 | ok (@warn == 0, "Error_diag in from new ({ auto_diag => 0})"); 95 | } 96 | { my @warn; 97 | local $SIG{__WARN__} = sub { push @warn => @_ }; 98 | is (Text::CSV->new ({ auto_diag => 1, ecs_char => ":" }), undef, 99 | "Unsupported option"); 100 | ok (@warn == 1, "Error_diag in from new ({ auto_diag => 1})"); 101 | like ($warn[0], qr{^# CSV_(?:PP|XS) ERROR: 1000 - INI}, "error content"); 102 | } 103 | 104 | is (Text::CSV::error_diag (), "INI - Unknown attribute 'ecs_char'", 105 | "Last failure for new () - FAIL"); 106 | is (Text::CSV->error_diag (), "INI - Unknown attribute 'ecs_char'", 107 | "Last failure for new () - FAIL"); 108 | is (Text::CSV::error_diag (bless {}, "Foo"), "INI - Unknown attribute 'ecs_char'", 109 | "Last failure for new () - FAIL"); 110 | $csv->SetDiag (1000); 111 | is (0 + $csv->error_diag (), 1000, "Set error NUM"); 112 | is ( $csv->error_diag (), "INI - constructor failed","Set error STR"); 113 | $csv->SetDiag (0); 114 | is (0 + $csv->error_diag (), 0, "Reset error NUM"); 115 | is ( $csv->error_diag (), "", "Reset error STR"); 116 | 117 | ok (1, "Test auto_diag"); 118 | $csv = Text::CSV->new ({ auto_diag => 1 }); 119 | { my @warn; 120 | local $SIG{__WARN__} = sub { push @warn => @_ }; 121 | is ($csv->{_RECNO}, 0, "No records read yet"); 122 | is ($csv->parse ('"","'), 0, "1 - bad parse"); 123 | ok (@warn == 1, "1 - One error"); 124 | like ($warn[0], qr '^# CSV_(?:PP|XS) ERROR: 2027 -', "1 - error message"); 125 | is ($csv->{_RECNO}, 1, "One record read"); 126 | } 127 | { my @warn; 128 | local $SIG{__WARN__} = sub { push @warn => @_ }; 129 | is ($csv->diag_verbose (3), 3, "Set diag_verbose"); 130 | is ($csv->parse ('"","'), 0, "1 - bad parse"); 131 | ok (@warn == 1, "1 - One error"); 132 | @warn = split m/\n/ => $warn[0]; 133 | ok (@warn == 3, "1 - error plus two lines"); 134 | like ($warn[0], qr '^# CSV_(?:PP|XS) ERROR: 2027 -', "1 - error message"); 135 | like ($warn[1], qr '^"","', "1 - input line"); 136 | like ($warn[2], qr '^ \^', "1 - position indicator"); 137 | is ($csv->{_RECNO}, 2, "Another record read"); 138 | } 139 | { ok ($csv->{auto_diag} = 2, "auto_diag = 2 to die"); 140 | eval { $csv->parse ('"","') }; 141 | like ($@, qr '^# CSV_(?:PP|XS) ERROR: 2027 -', "2 - error message"); 142 | } 143 | 144 | { my @warn; 145 | local $SIG{__WARN__} = sub { push @warn => @_ }; 146 | 147 | # Invalid error_input calls 148 | is (Text::CSV::error_input (undef), undef, "Bad error_input call"); 149 | is (Text::CSV::error_input (""), undef, "Bad error_input call"); 150 | is (Text::CSV::error_input ([]), undef, "Bad error_input call"); 151 | is (Text::CSV->error_input, undef, "Bad error_input call"); 152 | 153 | ok (my $csv = Text::CSV->new (), "new for cache diag"); 154 | $csv->_cache_diag (); 155 | ok (@warn == 1, "Got warn"); 156 | is ($warn[0], "CACHE: invalid\n", "Uninitialized cache"); 157 | 158 | @warn = (); 159 | ok ($csv->parse ("1"), "parse"); # initialize cache 160 | $csv->_cache_set (987, 10); 161 | ok (@warn == 1, "Got warn"); 162 | is ($warn[0], "Unknown cache index 987 ignored\n", "Ignore bad cache calls"); 163 | 164 | is ($csv->parse ('"'), 0, "Bad parse"); 165 | is ($csv->error_input, '"', "Error input"); 166 | ok ($csv->_cache_set (34, 0), "Reset error input (dangerous!)"); 167 | is ($csv->error_input, '"', "Error input not reset"); 168 | } 169 | 170 | { my $csv = Text::CSV->new (); 171 | ok ($csv->parse (q{1,"abc"}), "Valid parse"); 172 | is ($csv->error_input (), undef, "Undefined error_input"); 173 | is ($csv->{_ERROR_INPUT}, undef, "Undefined error_input"); 174 | } 175 | 176 | foreach my $spec ( 177 | undef, # No spec at all 178 | "", # No spec at all 179 | "row=0", # row > 0 180 | "col=0", # col > 0 181 | "cell=0", # cell = r,c 182 | "cell=0,0", # TL col > 0 183 | "cell=1,0", # TL row > 0 184 | "cell=1,1;0,1", # BR col > 0 185 | "cell=1,1;1,0", # BR row > 0 186 | "row=*", # * only after n- 187 | "col=3-1", # to >= from 188 | "cell=4,1;1", # cell has no ; 189 | "cell=3,3-2,1", # bottom-right should be right to and below top-left 190 | "cell=3,3-2,*", # bottom-right should be right to and below top-left 191 | "cell=3,3-4,1", # bottom-right should be right to and below top-left 192 | "cell=3,3-*,1", # bottom-right should be right to and below top-left 193 | "cell=1,*", # * in single cell col 194 | "cell=*,1", # * in single cell row 195 | "cell=*,*", # * in single cell row and column 196 | "cell=1,*-8,9", # * in cell range top-left cell col 197 | "cell=*,1-8,9", # * in cell range top-left cell row 198 | "cell=*,*-8,9", # * in cell range top-left cell row and column 199 | "row=/", # illegal character 200 | "col=4;row=3", # cannot combine rows and columns 201 | ) { 202 | my $csv = Text::CSV->new (); 203 | my $r; 204 | eval { $r = $csv->fragment (undef, $spec); }; 205 | is ($r, undef, "Cannot do fragment with bad RFC7111 spec"); 206 | my ($c_diag, $s_diag, $p_diag) = $csv->error_diag (); 207 | is ($c_diag, 2013, "Illegal RFC7111 spec"); 208 | is ($p_diag, 0, "Position"); 209 | } 210 | 211 | my $diag_file = "_$$.out"; 212 | open EH, ">&STDERR" or die "STDERR: $!\n"; 213 | open STDERR, ">", $diag_file or die "STDERR: $!\n"; 214 | # Trigger extra output for longer quote and sep 215 | is ($csv->sep ("--"), "--", "set longer sep"); 216 | is ($csv->quote ("^^"), "^^", "set longer quote"); 217 | ok ($csv->_cache_diag, "Cache debugging output"); 218 | close STDERR; 219 | open STDERR, ">&EH" or die "STDERR: $!\n"; 220 | open EH, "<", $diag_file or die "STDERR: $!\n"; 221 | is (scalar , "CACHE:\n", "Title"); 222 | while () { 223 | m/^\s+(?:tmp|bptr|cache)\b/ and next; 224 | like ($_, qr{^ \w+\s+[0-9a-f]+:(?:".*"|\s*[0-9]+)$}, "Content"); 225 | } 226 | close EH; 227 | unlink $diag_file; 228 | 229 | { my $err = ""; 230 | local $SIG{__DIE__} = sub { $err = shift; }; 231 | ok (my $csv = Text::CSV->new, "new"); 232 | eval { $csv->print_hr (*STDERR, {}); }; 233 | is (0 + $csv->error_diag, 3009, "Missing column names"); 234 | ok ($csv->column_names ("foo"), "set columns"); 235 | eval { $csv->print_hr (*STDERR, []); }; 236 | is (0 + $csv->error_diag, 3010, "print_hr needs a hashref"); 237 | } 238 | 239 | { my $csv = Text::CSV->new ({ sep_char => "=" }); 240 | eval { $csv->quote ("::::::::::::::"); }; 241 | is (0 + $csv->error_diag, 0, "Can set quote to something long"); 242 | eval { $csv->quote ("="); }; 243 | is (0 + $csv->error_diag, 1001, "Cannot set quote to current sep"); 244 | } 245 | 246 | { my $csv = Text::CSV->new ({ quote_char => "=" }); 247 | eval { $csv->sep ("::::::::::::::"); }; 248 | is (0 + $csv->error_diag, 0, "Can set sep to something long"); 249 | eval { $csv->sep (undef); }; 250 | is (0 + $csv->error_diag, 1008, "Can set sep to undef"); 251 | eval { $csv->sep (""); }; 252 | is (0 + $csv->error_diag, 1008, "Can set sep to empty"); 253 | eval { $csv->sep ("="); }; 254 | is (0 + $csv->error_diag, 1001, "Cannot set sep to current sep"); 255 | } 256 | 257 | { my $csv = Text::CSV->new; 258 | eval { $csv->header (undef, "foo"); }; 259 | is (0 + $csv->error_diag, 1014, "Cannot read header from undefined source"); 260 | eval { $csv->header (*STDIN, "foo"); }; 261 | like ($@, qr/^usage:/, "Illegal header call"); 262 | } 263 | 264 | { my $csv = Text::CSV->new; 265 | foreach my $arg ([], sub {}, Text::CSV->new, {}) { 266 | eval { $csv->parse ($arg) }; 267 | my @diag = $csv->error_diag; 268 | is ($diag[0], 1500, "Invalid parameters (code)"); 269 | like ($diag[1], qr{^PRM - Invalid/unsupported argument}, "Invalid parameters (msg)"); 270 | } 271 | } 272 | 273 | SKIP: { 274 | $] < 5.008 and skip qq{$] does not support ScalarIO}, 24; 275 | foreach my $key ({}, sub {}, []) { 276 | my $csv = Text::CSV->new; 277 | my $x = eval { $csv->csv (in => \"a,b", key => $key) }; 278 | is ($x, undef, "Invalid key"); 279 | my @diag = $csv->error_diag; 280 | is ($diag[0], 1501, "Invalid key type"); 281 | } 282 | 283 | { my $csv = Text::CSV->new; 284 | my $x = eval { $csv->csv (in => \"a,b", value => "b") }; 285 | is ($x, undef, "Value without key"); 286 | my @diag = $csv->error_diag; 287 | is ($diag[0], 1502, "No key"); 288 | } 289 | 290 | foreach my $val ({}, sub {}, []) { 291 | my $csv = Text::CSV->new; 292 | my $x = eval { $csv->csv (in => \"a,b", key => "a", value => $val) }; 293 | is ($x, undef, "Invalid value"); 294 | my @diag = $csv->error_diag; 295 | is ($diag[0], 1503, "Invalid value type"); 296 | } 297 | 298 | foreach my $ser ("die", 4) { 299 | ok (my $csv = Text::CSV->new ({ skip_empty_rows => $ser }), 300 | "New CSV for SER $ser"); 301 | is (eval { $csv->csv (in => \"\n") }, undef, 302 | "Parse empty line for SER $ser"); 303 | like ($@, qr{^Empty row}, "Message"); 304 | my @diag = $csv->error_diag; 305 | is ($diag[0], 2015, "Empty row"); 306 | like ($diag[1], qr{^ERW - Empty row}, "Error description"); 307 | } 308 | } 309 | 310 | # Issue 19: auto_diag > 1 does not die if ->header () is used 311 | if ($] >= 5.008002) { 312 | open my $fh, ">", $tfn or die "$tfn: $!\n"; 313 | print $fh qq{foo,bar,baz\n}; 314 | print $fh qq{a,xxx,1\n}; 315 | print $fh qq{b,"xx"xx", 2"\n}; 316 | print $fh qq{c, foo , 3\n}; 317 | close $fh; 318 | foreach my $h (0, 1) { 319 | $@ = ""; 320 | my @row; 321 | my $ok = eval { 322 | open $fh, "<", $tfn or die "$tfn: $!\n"; 323 | my $csv = Text::CSV->new ({ auto_diag => 2 }); 324 | $h and push @row => [ $csv->header ($fh) ]; 325 | while (my $row = $csv->getline ($fh)) { push @row => $row } 326 | close $fh; 327 | 1; 328 | }; 329 | is_deeply (\@row, [[qw(foo bar baz)],[qw(a xxx 1)]], "2 valid rows"); 330 | like ($@, qr '^# CSV_(?:PP|XS) ERROR: 2023 -', "3rd row dies error 2023"); 331 | } 332 | } 333 | else { 334 | ok (1, "Test skipped in this version of perl") for 1..4; 335 | } 336 | 337 | 1; 338 | -------------------------------------------------------------------------------- /t/15_flags.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; # use warnings core since 5.6 5 | 6 | use Test::More tests => 229; 7 | 8 | BEGIN { 9 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 10 | use_ok "Text::CSV"; 11 | plan skip_all => "Cannot load Text::CSV" if $@; 12 | } 13 | 14 | sub crnlsp { 15 | my $csv = shift; 16 | ok (!$csv->parse (), "Missing arguments"); 17 | ok ( $csv->parse ("\n"), "NL"); 18 | if ($csv->eol eq "\r") { 19 | ok ( $csv->parse ("\r"), "CR"); 20 | ok ( $csv->parse ("\r\r"), "CR CR"); 21 | ok ( $csv->parse ("\r "), "CR + Space"); 22 | ok ( $csv->parse (" \r"), "Space + CR"); 23 | } 24 | else { 25 | ok (!$csv->parse ("\r"), "CR"); 26 | ok (!$csv->parse ("\r\r"), "CR CR"); 27 | if ($csv->binary) { 28 | ok ( $csv->parse ("\r "), "CR + Space"); 29 | ok ( $csv->parse (" \r"), "Space + CR"); 30 | } 31 | else { 32 | ok (!$csv->parse ("\r "), "CR + Space"); 33 | ok (!$csv->parse (" \r"), "Space + CR"); 34 | } 35 | } 36 | ok ( $csv->parse ("\r\n"), "CR NL"); 37 | ok ( $csv->parse ("\n "), "NL + Space"); 38 | ok ( $csv->parse ("\r\n "), "CR NL + Space"); 39 | if ($csv->binary) { 40 | ok ( $csv->parse (qq{"\n"}), "Quoted NL"); 41 | ok ( $csv->parse (qq{"\r"}), "Quoted CR"); 42 | ok ( $csv->parse (qq{"\r\n"}), "Quoted CR NL"); 43 | ok ( $csv->parse (qq{"\n "}), "Quoted NL + Space"); 44 | ok ( $csv->parse (qq{"\r "}), "Quoted CR + Space"); 45 | ok ( $csv->parse (qq{"\r\n "}), "Quoted CR NL + Space"); 46 | } 47 | else { 48 | ok (!$csv->parse (qq{"\n"}), "Quoted NL"); 49 | ok (!$csv->parse (qq{"\r"}), "Quoted CR"); 50 | ok (!$csv->parse (qq{"\r\n"}), "Quoted CR NL"); 51 | ok (!$csv->parse (qq{"\n "}), "Quoted NL + Space"); 52 | ok (!$csv->parse (qq{"\r "}), "Quoted CR + Space"); 53 | ok (!$csv->parse (qq{"\r\n "}), "Quoted CR NL + Space"); 54 | } 55 | ok (!$csv->parse (qq{"\r\r\n"\r}), "Quoted CR CR NL >CR"); 56 | ok (!$csv->parse (qq{"\r\r\n"\r\r}), "Quoted CR CR NL >CR CR"); 57 | ok (!$csv->parse (qq{"\r\r\n"\r\r\n}), "Quoted CR CR NL >CR CR NL"); 58 | ok (!$csv->parse (qq{"\r\r\n"\t \r}), "Quoted CR CR NL >TAB Space CR"); 59 | ok (!$csv->parse (qq{"\r\r\n"\t \r\r}), "Quoted CR CR NL >TAB Space CR CR"); 60 | ok (!$csv->parse (qq{"\r\r\n"\t \r\r\n}), "Quoted CR CR NL >TAB Space CR CR NL"); 61 | } # crnlsp 62 | 63 | { my $csv = Text::CSV->new (); 64 | my $cb6 = chr (0xb6); # A random binary character 65 | 66 | is ($csv->meta_info, undef, "meta_info () before parse ()"); 67 | 68 | ok (1, "parse () tests - No meta_info"); 69 | crnlsp ($csv); 70 | ok (!$csv->parse ('"abc'), "Missing closing \""); 71 | ok (!$csv->parse ('ab"c'), "\" outside of \"'s"); 72 | ok (!$csv->parse ('"ab"c"'), "Bad character sequence"); 73 | ok (!$csv->parse ("ab${cb6}c"), "Binary character"); 74 | ok (!$csv->parse (qq{"ab${cb6}c"}), "Binary character in quotes"); 75 | ok (!$csv->parse (qq("abc\nc")), "Bad character (NL)"); 76 | ok (!$csv->status (), "Wrong status ()"); 77 | ok ( $csv->parse ('","'), "comma - parse ()"); 78 | is ( scalar $csv->fields (), 1, "comma - fields () - count"); 79 | is ( scalar $csv->meta_info (), 0, "comma - meta_info () - count"); 80 | is (($csv->fields ())[0], ",", "comma - fields () - content"); 81 | is (($csv->meta_info ())[0], undef, "comma - meta_info () - content"); 82 | ok ( $csv->parse (qq("","I said,\t""Hi!""","")), "Hi! - parse ()"); 83 | is ( scalar $csv->fields (), 3, "Hi! - fields () - count"); 84 | is ( scalar $csv->meta_info (), 0, "Hi! - meta_info () - count"); 85 | } 86 | 87 | { my $csv = Text::CSV->new ({ keep_meta_info => 1 }); 88 | 89 | ok (1, "parse () tests - With flags"); 90 | is ( $csv->meta_info, undef, "meta_info before parse"); 91 | 92 | ok (!$csv->parse (), "Missing arguments"); 93 | is ( $csv->meta_info, undef, "meta_info after failing parse"); 94 | crnlsp ($csv); 95 | ok (!$csv->parse ('"abc'), "Missing closing \""); 96 | ok (!$csv->parse ('ab"c'), "\" outside of \"'s"); 97 | ok (!$csv->parse ('"ab"c"'), "Bad character sequence"); 98 | ok (!$csv->parse (qq("abc\nc")), "Bad character (NL)"); 99 | ok (!$csv->status (), "Wrong status ()"); 100 | ok ( $csv->parse ('","'), "comma - parse ()"); 101 | is ( scalar $csv->fields (), 1, "comma - fields () - count"); 102 | is ( scalar $csv->meta_info (), 1, "comma - meta_info () - count"); 103 | is (($csv->fields ())[0], ",", "comma - fields () - content"); 104 | is (($csv->meta_info ())[0], 1, "comma - meta_info () - content"); 105 | ok ( $csv->parse (qq("","I said,\t""Hi!""",)), "Hi! - parse ()"); 106 | is ( scalar $csv->fields (), 3, "Hi! - fields () - count"); 107 | is ( scalar $csv->meta_info (), 3, "Hi! - meta_info () - count"); 108 | 109 | is (($csv->fields ())[0], "", "Hi! - fields () - field 1"); 110 | is (($csv->meta_info ())[0], 1, "Hi! - meta_info () - field 1"); 111 | is (($csv->fields ())[1], qq(I said,\t"Hi!"), "Hi! - fields () - field 2"); 112 | is (($csv->meta_info ())[1], 1, "Hi! - meta_info () - field 2"); 113 | is (($csv->fields ())[2], "", "Hi! - fields () - field 3"); 114 | is (($csv->meta_info ())[2], 0, "Hi! - meta_info () - field 3"); 115 | } 116 | 117 | { my $csv = Text::CSV->new ({ 118 | keep_meta_info => 1, 119 | binary => 1, 120 | quote_space => 0, 121 | }); 122 | ok ($csv->parse (qq{1,,"", ," ",f,"g","h""h",h\xb6lp,"h\xb6lp"}), "Parse"); 123 | ok (my @f = $csv->fields, "fields"); 124 | is_deeply (\@f, [ 1, "", "", " ", " ", "f", "g", "h\"h", 125 | "h\xb6lp", "h\xb6lp" ], "fields content"); 126 | ok ($csv->combine (@f), "combine"); 127 | is ($csv->string, 128 | qq{1,,, , ,f,g,"h""h",h\xb6lp,h\xb6lp}, "string 1"); 129 | ok ($csv->parse (qq{1,,"", ," ",f,"g","h""h",h\xb6lp,"h\xb6lp"}), "Parse"); 130 | is ($csv->keep_meta_info (11), 11, "keep meta on out"); 131 | ok ($csv->combine (@f), "combine"); 132 | is ($csv->string, 133 | qq{1,,"", ," ",f,"g","h""h",h\xb6lp,"h\xb6lp"}, "string 11"); 134 | ok ($csv->parse (qq{1,,"1193-1",4,"",,6}), "parse under 11"); 135 | ok ($csv->combine ($csv->fields), "combine"); 136 | is ($csv->string, qq{1,,"1193-1",4,"",,6}, "return same"); 137 | } 138 | 139 | { my $csv = Text::CSV->new ({ keep_meta_info => 1, eol => "\r" }); 140 | 141 | ok (1, "parse () tests - With flags"); 142 | is ( $csv->meta_info, undef, "meta_info before parse"); 143 | 144 | ok (!$csv->parse (), "Missing arguments"); 145 | is ( $csv->meta_info, undef, "meta_info after failing parse"); 146 | crnlsp ($csv); 147 | ok (!$csv->parse ('"abc'), "Missing closing \""); 148 | ok (!$csv->parse ('ab"c'), "\" outside of \"'s"); 149 | ok (!$csv->parse ('"ab"c"'), "Bad character sequence"); 150 | ok (!$csv->parse (qq("abc\nc")), "Bad character (NL)"); 151 | ok (!$csv->status (), "Wrong status ()"); 152 | ok ( $csv->parse ('","'), "comma - parse ()"); 153 | is ( scalar $csv->fields (), 1, "comma - fields () - count"); 154 | is ( scalar $csv->meta_info (), 1, "comma - meta_info () - count"); 155 | is (($csv->fields ())[0], ",", "comma - fields () - content"); 156 | is (($csv->meta_info ())[0], 1, "comma - meta_info () - content"); 157 | ok ( $csv->parse (qq("","I said,\t""Hi!""",)), "Hi! - parse ()"); 158 | is ( scalar $csv->fields (), 3, "Hi! - fields () - count"); 159 | is ( scalar $csv->meta_info (), 3, "Hi! - meta_info () - count"); 160 | 161 | is (($csv->fields ())[0], "", "Hi! - fields () - field 1"); 162 | is (($csv->meta_info ())[0], 1, "Hi! - meta_info () - field 1"); 163 | is (($csv->fields ())[1], qq(I said,\t"Hi!"), "Hi! - fields () - field 2"); 164 | is (($csv->meta_info ())[1], 1, "Hi! - meta_info () - field 2"); 165 | is (($csv->fields ())[2], "", "Hi! - fields () - field 3"); 166 | is (($csv->meta_info ())[2], 0, "Hi! - meta_info () - field 3"); 167 | } 168 | 169 | { my $csv = Text::CSV->new ({ keep_meta_info => 1, binary => 1 }); 170 | 171 | is ($csv->is_quoted (0), undef, "is_quoted () before parse"); 172 | is ($csv->is_binary (0), undef, "is_binary () before parse"); 173 | is ($csv->is_missing (0), undef, "is_missing () before parse"); 174 | 175 | my $bintxt = chr ($] < 5.006 ? 0xbf : 0x20ac); 176 | ok ( $csv->parse (qq{,"1","a\rb",0,"a\nb",1,\x8e,"a\r\n","$bintxt","",}), 177 | "parse () - mixed quoted/binary"); 178 | is (scalar $csv->fields, 11, "fields () - count"); 179 | my @fflg; 180 | ok (@fflg = $csv->meta_info, "meta_info ()"); 181 | is (scalar @fflg, 11, "meta_info () - count"); 182 | is_deeply ([ @fflg ], [ 0, 1, 3, 0, 3, 0, 2, 3, 3, 1, 0 ], "meta_info ()"); 183 | 184 | is ($csv->is_quoted (0), 0, "fflag 0 - not quoted"); 185 | is ($csv->is_binary (0), 0, "fflag 0 - not binary"); 186 | is ($csv->is_missing (0), 0, "fflag 0 - not missig"); 187 | is ($csv->is_quoted (2), 1, "fflag 2 - quoted"); 188 | is ($csv->is_binary (2), 1, "fflag 2 - binary"); 189 | is ($csv->is_missing (2), 0, "fflag 2 - not missing"); 190 | 191 | is ($csv->is_quoted (6), 0, "fflag 5 - not quoted"); 192 | is ($csv->is_binary (6), 1, "fflag 5 - binary"); 193 | is ($csv->is_missing (6), 0, "fflag 5 - not missing"); 194 | 195 | is ($csv->is_quoted (-1), undef, "fflag -1 - undefined"); 196 | is ($csv->is_binary (-8), undef, "fflag -8 - undefined"); 197 | is ($csv->is_missing (-8), undef, "fflag -8 - undefined"); 198 | 199 | is ($csv->is_quoted (21), undef, "fflag 21 - undefined"); 200 | is ($csv->is_binary (98), undef, "fflag 98 - undefined"); 201 | is ($csv->is_missing (98), 1, "fflag 98 - missing"); 202 | } 203 | 204 | { my $csv = Text::CSV->new ({ escape_char => "+" }); 205 | 206 | ok ( $csv->parse ("+"), "ESC"); 207 | ok (!$csv->parse ("++"), "ESC ESC"); 208 | ok ( $csv->parse ("+ "), "ESC Space"); 209 | ok ( $csv->parse ("+0"), "ESC NUL"); 210 | ok ( $csv->parse ("+\n"), "ESC NL"); 211 | ok (!$csv->parse ("+\r"), "ESC CR"); 212 | ok ( $csv->parse ("+\r\n"), "ESC CR NL"); 213 | ok (!$csv->parse (qq{"+"}), "Quo ESC"); 214 | ok (!$csv->parse (qq{""+}), "Quo ESC >"); 215 | ok ( $csv->parse (qq{"++"}), "Quo ESC ESC"); 216 | ok (!$csv->parse (qq{"+ "}), "Quo ESC Space"); 217 | ok ( $csv->parse (qq{"+0"}), "Quo ESC NUL"); 218 | ok (!$csv->parse (qq{"+\n"}), "Quo ESC NL"); 219 | ok (!$csv->parse (qq{"+\r"}), "Quo ESC CR"); 220 | ok (!$csv->parse (qq{"+\r\n"}), "Quo ESC CR NL"); 221 | } 222 | 223 | { my $csv = Text::CSV->new ({ escape_char => "+", binary => 1 }); 224 | 225 | ok ( $csv->parse ("+"), "ESC"); 226 | ok (!$csv->parse ("++"), "ESC ESC"); 227 | ok ( $csv->parse ("+ "), "ESC Space"); 228 | ok ( $csv->parse ("+0"), "ESC NUL"); 229 | ok ( $csv->parse ("+\n"), "ESC NL"); 230 | ok (!$csv->parse ("+\r"), "ESC CR"); 231 | ok ( $csv->parse ("+\r\n"), "ESC CR NL"); 232 | ok (!$csv->parse (qq{"+"}), "Quo ESC"); 233 | ok ( $csv->parse (qq{"++"}), "Quo ESC ESC"); 234 | ok (!$csv->parse (qq{"+ "}), "Quo ESC Space"); 235 | ok ( $csv->parse (qq{"+0"}), "Quo ESC NUL"); 236 | ok (!$csv->parse (qq{"+\n"}), "Quo ESC NL"); 237 | ok (!$csv->parse (qq{"+\r"}), "Quo ESC CR"); 238 | ok (!$csv->parse (qq{"+\r\n"}), "Quo ESC CR NL"); 239 | } 240 | 241 | ok (1, "Testing always_quote"); 242 | { ok (my $csv = Text::CSV->new ({ always_quote => 0 }), "new (aq => 0)"); 243 | ok ($csv->combine (1..3), "Combine"); 244 | is ($csv->string, q{1,2,3}, "String"); 245 | is ($csv->always_quote, 0, "Attr 0"); 246 | ok ($csv->always_quote (1), "Attr 1"); 247 | ok ($csv->combine (1..3), "Combine"); 248 | is ($csv->string, q{"1","2","3"}, "String"); 249 | is ($csv->always_quote, 1, "Attr 1"); 250 | is ($csv->always_quote (0), 0, "Attr 0"); 251 | ok ($csv->combine (1..3), "Combine"); 252 | is ($csv->string, q{1,2,3}, "String"); 253 | is ($csv->always_quote, 0, "Attr 0"); 254 | } 255 | 256 | ok (1, "Testing quote_space"); 257 | { ok (my $csv = Text::CSV->new ({ quote_space => 1 }), "new (qs => 1)"); 258 | ok ($csv->combine (1, " ", 3), "Combine"); 259 | is ($csv->string, q{1," ",3}, "String"); 260 | is ($csv->quote_space, 1, "Attr 1"); 261 | is ($csv->quote_space (0), 0, "Attr 0"); 262 | ok ($csv->combine (1, " ", 3), "Combine"); 263 | is ($csv->string, q{1, ,3}, "String"); 264 | is ($csv->quote_space, 0, "Attr 0"); 265 | is ($csv->quote_space (1), 1, "Attr 1"); 266 | ok ($csv->combine (1, " ", 3), "Combine"); 267 | is ($csv->string, q{1," ",3}, "String"); 268 | is ($csv->quote_space, 1, "Attr 1"); 269 | } 270 | 271 | ok (1, "Testing quote_empty"); 272 | { ok (my $csv = Text::CSV->new (), "new (default)"); 273 | is ($csv->quote_empty, 0, "default = 0"); 274 | ok ($csv->combine (1, undef, "", " ", 2), "combine qe = 0"); 275 | is ($csv->string, qq{1,,," ",2}, "string"); 276 | is ($csv->quote_empty (1), 1, "enable quote_empty"); 277 | ok ($csv->combine (1, undef, "", " ", 2), "combine qe = 1"); 278 | is ($csv->string, qq{1,,""," ",2}, "string"); 279 | } 280 | 281 | # https://rt.cpan.org/Public/Bug/Display.html?id=109097 282 | ok (1, "Testing quote_char as undef"); 283 | { my $csv = Text::CSV->new ({ quote_char => undef }); 284 | is ($csv->escape_char, '"', "Escape Char defaults to double quotes"); 285 | ok ($csv->combine ('space here', '"quoted"', '"quoted and spaces"'), "Combine"); 286 | is ($csv->string, q{space here,""quoted"",""quoted and spaces""}, "String"); 287 | } 288 | -------------------------------------------------------------------------------- /t/85_util.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | use Test::More; 7 | 8 | my $ebcdic = ord ("A") == 0xC1; 9 | my $pu; 10 | BEGIN { 11 | $pu = $ENV{PERL_UNICODE}; 12 | $pu = defined $pu && ($pu eq "" || $pu =~ m/[oD]/ || ($pu =~ m/^[0-9]+$/ && $pu & 16)); 13 | 14 | if ($] < 5.008002) { 15 | plan skip_all => "This test unit requires perl-5.8.2 or higher"; 16 | } 17 | else { 18 | my $n = 1448; 19 | $pu and $n -= 120; 20 | plan tests => $n; 21 | } 22 | 23 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 24 | 25 | use_ok "Text::CSV", "csv"; 26 | # Encode up to and including 2.01 have an error in a regex: 27 | # False [] range "\s-" in regex; marked by <-- HERE in m/\bkoi8[\s- <-- HERE _]*([ru])$/ 28 | # in Encode::Alias. This however does not influence this test, as then *all* encodings 29 | # are skipped as unsupported 30 | require Encode; 31 | require "./t/util.pl"; 32 | } 33 | 34 | $| = 1; 35 | 36 | ok (my $csv = Text::CSV->new, "new for header tests"); 37 | is ($csv->sep_char, ",", "Sep = ,"); 38 | 39 | my $hdr_lc = [qw( bar foo )]; 40 | 41 | foreach my $sep (",", ";") { 42 | my $data = "bAr,foo\n1,2\n3,4,5\n"; 43 | $data =~ s/,/$sep/g; 44 | 45 | $csv->column_names (undef); 46 | { open my $fh, "<", \$data; 47 | ok (my $slf = $csv->header ($fh), "header"); 48 | is ($slf, $csv, "Return self"); 49 | is ($csv->sep_char, $sep, "Sep = $sep"); 50 | is_deeply ([ $csv->column_names ], $hdr_lc, "headers"); 51 | is_deeply ($csv->getline ($fh), [ 1, 2 ], "Line 1"); 52 | is_deeply ($csv->getline ($fh), [ 3, 4, 5 ], "Line 2"); 53 | close $fh; 54 | } 55 | 56 | $csv->column_names (undef); 57 | { open my $fh, "<", \$data; 58 | ok (my @hdr = $csv->header ($fh), "header"); 59 | is_deeply (\@hdr, $hdr_lc, "Return headers"); 60 | close $fh; 61 | } 62 | 63 | $csv->column_names (undef); 64 | { open my $fh, "<", \$data; 65 | ok (my $slf = $csv->header ($fh), "header"); 66 | is ($slf, $csv, "Return self"); 67 | is ($csv->sep_char, $sep, "Sep = $sep"); 68 | is_deeply ([ $csv->column_names ], $hdr_lc, "headers"); 69 | is_deeply ($csv->getline_hr ($fh), { bar => 1, foo => 2 }, "Line 1"); 70 | is_deeply ($csv->getline_hr ($fh), { bar => 3, foo => 4 }, "Line 2"); 71 | close $fh; 72 | } 73 | 74 | { open my $fh, "<", \$data; 75 | is_deeply (csv (in => $fh, bom => 1), 76 | [{ bar => 1, foo => 2 }, { bar => 3, foo => 4 }], 77 | "use header () from csv () with $sep"); 78 | } 79 | 80 | { open my $fh, "<", \$data; 81 | is_deeply (csv (in => $fh, seps => [ ",", ";" ]), 82 | [{ bar => 1, foo => 2 }, { bar => 3, foo => 4 }], 83 | "use header () from csv () with $sep"); 84 | } 85 | 86 | { open my $fh, "<", \$data; 87 | is_deeply (csv (in => $fh, bom => 1, key => "bar"), 88 | { 1 => { bar => 1, foo => 2 }, 3 => { bar => 3, foo => 4 }}, 89 | "use header () from csv (key) with $sep"); 90 | } 91 | 92 | { open my $fh, "<", \$data; 93 | is_deeply (csv (in => $fh, munge => "uc", key => "BAR"), 94 | { 1 => { BAR => 1, FOO => 2 }, 3 => { BAR => 3, FOO => 4 }}, 95 | "use header () from csv (key, uc) with $sep"); 96 | } 97 | 98 | { open my $fh, "<", \$data; 99 | is_deeply (csv (in => $fh, set_column_names => 0), 100 | [[ "bar", "foo" ], [ 1, 2 ], [ 3, 4, 5 ]], 101 | "use header () from csv () with $sep to ARRAY not setting column names"); 102 | } 103 | { open my $fh, "<", \$data; 104 | is_deeply (csv (in => $fh, set_column_names => 0, munge => "none"), 105 | [[ "bAr", "foo" ], [ 1, 2 ], [ 3, 4, 5 ]], 106 | "use header () from csv () with $sep to ARRAY not setting column names not lc"); 107 | } 108 | } 109 | 110 | my $sep_utf = byte_utf8a_to_utf8n ("\xe2\x81\xa3"); # U+2063 INVISIBLE SEPARATOR 111 | my $sep_ok = [ "\t", "|", ",", ";", "##", $sep_utf ]; 112 | unless ($pu) { 113 | foreach my $sep (@$sep_ok) { 114 | my $data = "bAr,foo\n1,2\n3,4,5\n"; 115 | $data =~ s/,/$sep/g; 116 | 117 | $csv->column_names (undef); 118 | { open my $fh, "<", \$data; 119 | ok (my $slf = $csv->header ($fh, $sep_ok), "header with specific sep set"); 120 | is ($slf, $csv, "Return self"); 121 | is (Encode::encode ("utf-8", $csv->sep), $sep, "Sep = $sep"); 122 | is_deeply ([ $csv->column_names ], $hdr_lc, "headers"); 123 | is_deeply ($csv->getline ($fh), [ 1, 2 ], "Line 1"); 124 | is_deeply ($csv->getline ($fh), [ 3, 4, 5 ], "Line 2"); 125 | close $fh; 126 | } 127 | 128 | $csv->column_names (undef); 129 | { open my $fh, "<", \$data; 130 | ok (my @hdr = $csv->header ($fh, $sep_ok), "header with specific sep set"); 131 | is_deeply (\@hdr, $hdr_lc, "Return headers"); 132 | close $fh; 133 | } 134 | 135 | $csv->column_names (undef); 136 | { open my $fh, "<", \$data; 137 | ok (my $slf = $csv->header ($fh, { sep_set => $sep_ok }), "header with specific sep set as opt"); 138 | is ($slf, $csv, "Return self"); 139 | is (Encode::encode ("utf-8", $csv->sep), $sep, "Sep = $sep"); 140 | is_deeply ([ $csv->column_names ], $hdr_lc, "headers"); 141 | is_deeply ($csv->getline ($fh), [ 1, 2 ], "Line 1"); 142 | is_deeply ($csv->getline ($fh), [ 3, 4, 5 ], "Line 2"); 143 | close $fh; 144 | } 145 | 146 | $csv->column_names (undef); 147 | { open my $fh, "<", \$data; 148 | ok (my $slf = $csv->header ($fh, $sep_ok), "header with specific sep set"); 149 | is ($slf, $csv, "Return self"); 150 | is (Encode::encode ("utf-8", $csv->sep), $sep, "Sep = $sep"); 151 | is_deeply ([ $csv->column_names ], $hdr_lc, "headers"); 152 | is_deeply ($csv->getline_hr ($fh), { bar => 1, foo => 2 }, "Line 1"); 153 | is_deeply ($csv->getline_hr ($fh), { bar => 3, foo => 4 }, "Line 2"); 154 | close $fh; 155 | } 156 | } 157 | } 158 | 159 | for ( [ 1010, 0, qq{} ], # Empty header 160 | [ 1011, 0, qq{a,b;c,d} ], # Multiple allowed separators 161 | [ 1012, 0, qq{a,,b} ], # Empty header field 162 | [ 1013, 0, qq{a,a,b} ], # Non-unique headers 163 | [ 2027, 1, qq{a,"b\nc",c} ], # Embedded newline binary on 164 | [ 2021, 0, qq{a,"b\nc",c} ], # Embedded newline binary off 165 | ) { 166 | my ($err, $bin, $data) = @$_; 167 | $csv->binary ($bin); 168 | open my $fh, "<", \$data; 169 | my $self = eval { $csv->header ($fh); }; 170 | is ($self, undef, "FAIL for '$data'"); 171 | ok ($@, "Error"); 172 | is (0 + $csv->error_diag, $err, "Error code $err"); 173 | close $fh; 174 | } 175 | { open my $fh, "<", \"bar,bAr,bAR,BAR\n1,2,3,4"; 176 | $csv->column_names (undef); 177 | ok ($csv->header ($fh, { munge_column_names => "none", detect_bom => 0 }), "non-unique unfolded headers"); 178 | is_deeply ([ $csv->column_names ], [qw( bar bAr bAR BAR )], "Headers"); 179 | close $fh; 180 | } 181 | { open my $fh, "<", \"bar,bAr,bAR,BAR\n1,2,3,4"; 182 | $csv->column_names (undef); 183 | ok (my @hdr = $csv->header ($fh, { munge_column_names => "none" }), "non-unique unfolded headers"); 184 | is_deeply (\@hdr, [qw( bar bAr bAR BAR )], "Headers from method"); 185 | is_deeply ([ $csv->column_names ], [qw( bar bAr bAR BAR )], "Headers from column_names"); 186 | close $fh; 187 | } 188 | 189 | foreach my $sep (",", ";") { 190 | my $data = "bAr,foo\n1,2\n3,4,5\n"; 191 | $data =~ s/,/$sep/g; 192 | 193 | $csv->column_names (undef); 194 | { open my $fh, "<", \$data; 195 | ok (my $slf = $csv->header ($fh, { set_column_names => 0 }), "Header without column setting"); 196 | is ($slf, $csv, "Return self"); 197 | is ($csv->sep_char, $sep, "Sep = $sep"); 198 | is_deeply ([ $csv->column_names ], [], "headers"); 199 | is_deeply ($csv->getline ($fh), [ 1, 2 ], "Line 1"); 200 | is_deeply ($csv->getline ($fh), [ 3, 4, 5 ], "Line 2"); 201 | close $fh; 202 | } 203 | $csv->column_names (undef); 204 | { open my $fh, "<", \$data; 205 | ok (my @hdr = $csv->header ($fh, { set_column_names => 0 }), "Header without column setting"); 206 | is_deeply (\@hdr, $hdr_lc, "Headers from method"); 207 | is_deeply ([ $csv->column_names ], [], "Headers from column_names"); 208 | close $fh; 209 | } 210 | } 211 | 212 | foreach my $ss ("", "bad", sub { 1; }, \*STDOUT, +{}) { 213 | my $dta = "a,b\n1,2\n"; 214 | open my $fh, "<", \$dta; 215 | my @hdr = eval { $csv->header ($fh, { sep_set => $ss }) }; 216 | is (scalar @hdr, 0, "No header on invalid sep_set"); 217 | is (0 + $csv->error_diag, 1500, "Error code"); 218 | } 219 | 220 | foreach my $dta ("", "\xfe\xff", "\xf7\x64\x4c", "\xdd\x73\x66\x73", 221 | "\x0e\xfe\xff", "\xfb\xee\x28", "\x84\x31\x95\x33") { 222 | open my $fh, "<", \$dta; 223 | my @hdr = eval { $csv->header ($fh) }; 224 | is (scalar @hdr, 0, "No header on empty stream"); 225 | is (0 + $csv->error_diag, 1010, "Error code"); 226 | } 227 | 228 | my $n; 229 | for ([ undef, "_bar" ], [ "lc", "_bar" ], [ "uc", "_BAR" ], [ "none", "_bAr" ], 230 | [ sub { "column_".$n++ }, "column_0" ], [ "db", "bar" ]) { 231 | my ($munge, $hdr) = @$_; 232 | 233 | my $data = "_bAr,foo\n1,2\n3,4,5\n"; 234 | my $how = defined $munge ? ref $munge ? "CB" : $munge : "undef"; 235 | 236 | $n = 0; 237 | $csv->column_names (undef); 238 | open my $fh, "<", \$data; 239 | ok (my $slf = $csv->header ($fh, { munge_column_names => $munge }), "munge header with $how"); 240 | is (($csv->column_names)[0], $hdr, "folded header to $hdr"); 241 | close $fh; 242 | 243 | $n = 0; 244 | $csv->column_names (undef); 245 | open $fh, "<", \$data; 246 | ok (my @hdr = $csv->header ($fh, { munge_column_names => $munge }), "munge header with $how"); 247 | is ($hdr[0], $hdr, "folded header to $hdr"); 248 | close $fh; 249 | } 250 | 251 | my $fnm = "_85hdr.csv"; END { unlink $fnm; } 252 | 253 | my $a_ring = chr (utf8::unicode_to_native (0xe5)); 254 | foreach my $irs ("\n", chr (utf8::unicode_to_native (0xaa))) { 255 | local $/ = $irs; 256 | foreach my $eol ("\n", "\r\n", "\r") { 257 | my $str = join $eol => 258 | qq{zoo,b${a_ring}r}, 259 | qq{1,"1 \x{20ac} each"}, 260 | ""; 261 | for ( [ "none" => "" ], 262 | [ "utf-8" => "\xef\xbb\xbf" ], 263 | [ "utf-16be" => "\xfe\xff" ], 264 | [ "utf-16le" => "\xff\xfe" ], 265 | [ "utf-32be" => "\x00\x00\xfe\xff" ], 266 | [ "utf-32le" => "\xff\xfe\x00\x00" ], 267 | # Below 5 not (yet) supported by Encode 268 | [ "utf-1" => "\xf7\x64\x4c" ], 269 | [ "utf-ebcdic" => "\xdd\x73\x66\x73" ], 270 | [ "scsu" => "\x0e\xfe\xff" ], 271 | [ "bocu-1" => "\xfb\xee\x28" ], 272 | [ "gb-18030" => "\x84\x31\x95" ], 273 | # 274 | [ "UTF-8" => "\x{feff}" ], 275 | ) { 276 | my ($enc, $bom) = @$_; 277 | my ($enx, $box, $has_enc) = ($enc, $bom, 0); 278 | $enc eq "UTF-8" || $enc eq "none" or 279 | $box = eval { Encode::encode ($enc, chr (0xfeff)) }; 280 | $enc eq "none" and $enx = "utf-8"; 281 | 282 | # On os390, Encode only supports the following EBCDIC 283 | # cp37, cp500, cp875, cp1026, cp1047, and posix-bc 284 | # utf-ebcdic is not in the list 285 | eval { 286 | no warnings "utf8"; 287 | open my $fh, ">", $fnm; 288 | binmode $fh; 289 | if (defined $box) { 290 | print $fh byte_utf8a_to_utf8n ($box); 291 | print $fh Encode::encode ($enx, $str); 292 | $has_enc = 1; 293 | } 294 | else { 295 | print $fh Encode::encode ("utf-8", $str); 296 | } 297 | 298 | close $fh; 299 | }; 300 | #$ebcdic and $has_enc = 0; # TODO 301 | 302 | $csv = Text::CSV->new ({ binary => 1, auto_diag => 9 }); 303 | 304 | SKIP: { 305 | $has_enc or skip "Encoding $enc not supported", $enc =~ m/^utf/ ? 10 : 9; 306 | $csv->column_names (undef); 307 | open my $fh, "<", $fnm; 308 | binmode $fh; 309 | ok (1, "$fnm opened for enc $enc"); 310 | ok ($csv->header ($fh), "headers with BOM for $enc"); 311 | $enc =~ m/^utf/ and is ($csv->{ENCODING}, uc $enc, "Encoding inquirable"); 312 | 313 | is (($csv->column_names)[1], "b${a_ring}r", "column name was decoded"); 314 | ok (my $row = $csv->getline_hr ($fh), "getline_hr"); 315 | is ($row->{"b${a_ring}r"}, "1 \x{20ac} each", "Returned in Unicode"); 316 | close $fh; 317 | 318 | my $aoh; 319 | ok ($aoh = csv (in => $fnm, bom => 1), "csv (bom => 1)"); 320 | is_deeply ($aoh, 321 | [{ zoo => 1, "b${a_ring}r" => "1 \x{20ac} each" }], "Returned data bom = 1"); 322 | 323 | ok ($aoh = csv (in => $fnm, encoding => "auto"), "csv (encoding => auto)"); 324 | is_deeply ($aoh, 325 | [{ zoo => 1, "b${a_ring}r" => "1 \x{20ac} each" }], "Returned data auto"); 326 | } 327 | 328 | SKIP: { 329 | $has_enc or skip "Encoding $enc not supported", 7; 330 | $csv->column_names (undef); 331 | open my $fh, "<", $fnm; 332 | $enc eq "none" or binmode $fh, ":encoding($enc)"; 333 | ok (1, "$fnm opened for enc $enc"); 334 | ok ($csv->header ($fh), "headers with BOM for $enc"); 335 | is (($csv->column_names)[1], "b${a_ring}r", "column name was decoded"); 336 | ok (my $row = $csv->getline_hr ($fh), "getline_hr"); 337 | is ($row->{"b${a_ring}r"}, "1 \x{20ac} each", "Returned in Unicode"); 338 | close $fh; 339 | 340 | ok (my $aoh = csv (in => $fnm, bom => 1), "csv (bom => 1)"); 341 | is_deeply ($aoh, 342 | [{ zoo => 1, "b${a_ring}r" => "1 \x{20ac} each" }], "Returned data"); 343 | } 344 | 345 | unlink $fnm; 346 | } 347 | } 348 | } 349 | 350 | { # Header after first line with sep= 351 | open my $fh, ">", $fnm or die "$fnm: $!"; 352 | print $fh "sep=;\n"; 353 | print $fh "a;b 1;c\n"; 354 | print $fh "1;2;3\n"; 355 | close $fh; 356 | ok (my $aoh = csv (in => $fnm, munge => "db"), "Read header with sep=;"); 357 | is_deeply ($aoh, [{ a => 1, "b_1" => 2, c => 3 }], "Munged to db with sep"); 358 | } 359 | -------------------------------------------------------------------------------- /t/65_allow.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | $^W = 1; 5 | 6 | #use Test::More "no_plan"; 7 | use Test::More tests => 1119; 8 | 9 | BEGIN { 10 | $ENV{PERL_TEXT_CSV} = $ENV{TEST_PERL_TEXT_CSV} || 0; 11 | use_ok "Text::CSV", (); 12 | plan skip_all => "Cannot load Text::CSV" if $@; 13 | require "./t/util.pl"; 14 | } 15 | 16 | my $tfn = "_65test.csv"; END { -f $tfn and unlink $tfn; } 17 | my $csv; 18 | 19 | ok (1, "Allow unescaped quotes"); 20 | # Allow unescaped quotes inside an unquoted field 21 | { my @bad = ( 22 | # valid, line 23 | [ 1, 1, 0, qq{foo,bar,"baz",quux} ], 24 | [ 2, 0, 2034, qq{rj,bs,r"jb"s,rjbs} ], 25 | [ 3, 0, 2034, qq{some "spaced" quote data,2,3,4} ], 26 | [ 4, 1, 0, qq{and an,entirely,quoted,"field"} ], 27 | [ 5, 1, 0, qq{and then,"one with ""quoted"" quotes",okay,?} ], 28 | ); 29 | 30 | for (@bad) { 31 | my ($tst, $valid, $err, $bad) = @$_; 32 | $csv = Text::CSV->new (); 33 | ok ($csv, "$tst - new (alq => 0)"); 34 | is ($csv->parse ($bad), $valid, "$tst - parse () fail"); 35 | is (0 + $csv->error_diag, $err, "$tst - error $err"); 36 | 37 | $csv->allow_loose_quotes (1); 38 | ok ($csv->parse ($bad), "$tst - parse () pass"); 39 | ok (my @f = $csv->fields, "$tst - fields"); 40 | } 41 | 42 | #$csv = Text::CSV->new ({ quote_char => '"', escape_char => "=" }); 43 | #ok (!$csv->parse (qq{foo,d'uh"bar}), "should fail"); 44 | } 45 | 46 | ok (1, "Allow loose quotes inside quoted"); 47 | # Allow unescaped quotes inside a quoted field 48 | { my @bad = ( 49 | # valid, line 50 | [ 1, 1, 0, qq{foo,bar,"baz",quux} ], 51 | [ 2, 0, 2023, qq{rj,bs,"r"jb"s",rjbs} ], 52 | [ 3, 0, 2023, qq{"some "spaced" quote data",2,3,4} ], 53 | [ 4, 1, 0, qq{and an,entirely,quoted,"field"} ], 54 | [ 5, 1, 0, qq{and then,"one with ""quoted"" quotes",okay,?} ], 55 | ); 56 | 57 | for (@bad) { 58 | my ($tst, $valid, $err, $bad) = @$_; 59 | $csv = Text::CSV->new (); 60 | ok ($csv, "$tst - new (alq => 0)"); 61 | is ($csv->parse ($bad), $valid, "$tst - parse () fail"); 62 | is (0 + $csv->error_diag, $err, "$tst - error $err"); 63 | 64 | $csv->allow_loose_quotes (1); 65 | is ($csv->parse ($bad), $valid, "$tst - parse () fail with lq"); 66 | is (0 + $csv->error_diag, $err, "$tst - error $err"); 67 | 68 | $csv->escape_char (undef); 69 | ok ($csv->parse ($bad), "$tst - parse () pass"); 70 | ok (my @f = $csv->fields, "$tst - fields"); 71 | } 72 | } 73 | 74 | ok (1, "Allow loose escapes"); 75 | # Allow escapes to escape characters that should not be escaped 76 | { my @bad = ( 77 | # valid, line 78 | [ 1, 1, 0, qq{1,foo,bar,"baz",quux} ], 79 | [ 2, 1, 0, qq{2,escaped,"quote\\"s",in,"here"} ], 80 | [ 3, 1, 0, qq{3,escaped,quote\\"s,in,"here"} ], 81 | [ 4, 1, 0, qq{4,escap\\'d chars,allowed,in,unquoted,fields} ], 82 | [ 5, 0, 2025, qq{5,42,"and it\\'s dog",} ], 83 | 84 | [ 6, 1, 0, qq{\\,} ], 85 | [ 7, 1, 0, qq{\\} ], 86 | [ 8, 0, 2035, qq{foo\\} ], 87 | ); 88 | 89 | for (@bad) { 90 | my ($tst, $valid, $err, $bad) = @$_; 91 | $csv = Text::CSV->new ({ escape_char => "\\" }); 92 | ok ($csv, "$tst - new (ale => 0)"); 93 | is ($csv->parse ($bad), $valid, "$tst - parse () fail"); 94 | is (0 + $csv->error_diag, $err, "$tst - error $err"); 95 | 96 | $csv->allow_loose_escapes (1); 97 | if ($tst >= 8) { 98 | # Should always fail 99 | ok (!$csv->parse ($bad), "$tst - parse () fail"); 100 | is (0 + $csv->error_diag, $err, "$tst - error $err"); 101 | } 102 | else { 103 | ok ($csv->parse ($bad), "$tst - parse () pass"); 104 | ok (my @f = $csv->fields, "$tst - fields"); 105 | } 106 | } 107 | } 108 | 109 | ok (1, "Allow whitespace"); 110 | # Allow whitespace to surround sep char 111 | { my @bad = ( 112 | # valid, line 113 | [ 1, 1, 0, qq{1,foo,bar,baz,quux} ], 114 | [ 2, 1, 0, qq{1,foo,bar,"baz",quux} ], 115 | [ 3, 1, 0, qq{1, foo,bar,"baz",quux} ], 116 | [ 4, 1, 0, qq{ 1,foo,bar,"baz",quux} ], 117 | [ 5, 0, 2034, qq{1,foo,bar, "baz",quux} ], 118 | [ 6, 1, 0, qq{1,foo ,bar,"baz",quux} ], 119 | [ 7, 1, 0, qq{1,foo,bar,"baz",quux } ], 120 | [ 8, 1, 0, qq{1,foo,bar,"baz","quux"} ], 121 | [ 9, 0, 2023, qq{1,foo,bar,"baz" ,quux} ], 122 | [ 10, 0, 2023, qq{1,foo,bar,"baz","quux" } ], 123 | [ 11, 0, 2034, qq{ 1 , foo , bar , "baz" , quux } ], 124 | [ 12, 0, 2034, qq{ 1 , foo , bar , "baz" , quux } ], 125 | [ 13, 0, 2034, qq{ 1 , foo , bar , "baz"\t , quux } ], 126 | ); 127 | 128 | foreach my $eol ("", "\n", "\r", "\r\n") { 129 | my $s_eol = _readable ($eol); 130 | for (@bad) { 131 | my ($tst, $ok, $err, $bad) = @$_; 132 | $csv = Text::CSV->new ({ eol => $eol, binary => 1 }); 133 | ok ($csv, "$s_eol / $tst - new - '$bad')"); 134 | is ($csv->parse ($bad), $ok, "$s_eol / $tst - parse () fail"); 135 | is (0 + $csv->error_diag, $err, "$tst - error $err"); 136 | 137 | $csv->allow_whitespace (1); 138 | ok ($csv->parse ("$bad$eol"), "$s_eol / $tst - parse () pass"); 139 | 140 | ok (my @f = $csv->fields, "$s_eol / $tst - fields"); 141 | 142 | local $" = ","; 143 | is ("@f", $bad[0][-1], "$s_eol / $tst - content"); 144 | } 145 | } 146 | } 147 | 148 | ok (1, "Allow whitespace"); 149 | # Allow whitespace to surround sep char 150 | { my @bad = ( 151 | # test, ok, line 152 | [ 1, 1, 0, qq{1,foo,bar,baz,quux} ], 153 | [ 2, 1, 0, qq{1,foo,bar,"baz",quux} ], 154 | [ 3, 1, 0, qq{1, foo,bar,"baz",quux} ], 155 | [ 4, 1, 0, qq{ 1,foo,bar,"baz",quux} ], 156 | [ 5, 0, 2034, qq{1,foo,bar, "baz",quux} ], 157 | [ 6, 1, 0, qq{1,foo ,bar,"baz",quux} ], 158 | [ 7, 1, 0, qq{1,foo,bar,"baz",quux } ], 159 | [ 8, 1, 0, qq{1,foo,bar,"baz","quux"} ], 160 | [ 9, 0, 2023, qq{1,foo,bar,"baz" ,quux} ], 161 | [ 10, 0, 2023, qq{1,foo,bar,"baz","quux" } ], 162 | [ 11, 0, 2023, qq{1,foo,bar,"baz","quux" } ], 163 | [ 12, 0, 2034, qq{ 1 , foo , bar , "baz" , quux } ], 164 | [ 13, 0, 2034, qq{ 1 , foo , bar , "baz" , quux } ], 165 | [ 14, 0, 2034, qq{ 1 , foo , bar , "baz"\t , quux } ], 166 | ); 167 | 168 | foreach my $eol ("", "\n", "\r", "\r\n") { 169 | my $s_eol = _readable ($eol); 170 | for (@bad) { 171 | my ($tst, $ok, $err, $bad) = @$_; 172 | $csv = Text::CSV->new ({ 173 | eol => $eol, 174 | binary => 1, 175 | }); 176 | ok ($csv, "$s_eol / $tst - new - '$bad')"); 177 | is ($csv->parse ($bad), $ok, "$s_eol / $tst - parse () fail"); 178 | is (0 + $csv->error_diag, $err, "$tst - error $err"); 179 | 180 | $csv->allow_whitespace (1); 181 | ok ($csv->parse ("$bad$eol"), "$s_eol / $tst - parse () pass"); 182 | 183 | ok (my @f = $csv->fields, "$s_eol / $tst - fields"); 184 | 185 | local $" = ","; 186 | is ("@f", $bad[0][-1], "$s_eol / $tst - content"); 187 | } 188 | } 189 | } 190 | 191 | ok (1, "blank_is_undef"); 192 | foreach my $conf ( 193 | [ 0, 0, 0, 1, "", " ", '""', 2, "", "", "" ], 194 | [ 0, 0, 1, 1, undef, " ", '""', 2, undef, undef, undef ], 195 | [ 0, 1, 0, 1, "", " ", '""', 2, "", "", "" ], 196 | [ 0, 1, 1, 1, undef, " ", '""', 2, undef, undef, undef ], 197 | [ 1, 0, 0, 1, "", " ", '""', 2, "", "", "" ], 198 | [ 1, 0, 1, 1, "", " ", '""', 2, undef, "", undef ], 199 | [ 1, 1, 0, 1, "", " ", '""', 2, "", "", "" ], 200 | [ 1, 1, 1, 1, "", " ", '""', 2, undef, "", undef ], 201 | ) { 202 | my ($aq, $aw, $bu, @expect, $str) = @$conf; 203 | $csv = Text::CSV->new ({ always_quote => $aq, allow_whitespace => $aw, blank_is_undef => $bu }); 204 | ok ($csv, "new ({ aq $aq aw $aw bu $bu })"); 205 | ok ($csv->combine (1, "", " ", '""', 2, undef, "", undef), "combine ()"); 206 | ok ($str = $csv->string, "string ()"); 207 | foreach my $eol ("", "\n", "\r\n") { 208 | my $s_eol = _readable ($eol); 209 | ok ($csv->parse ($str.$eol), "parse (*$str$s_eol*)"); 210 | ok (my @f = $csv->fields, "fields ()"); 211 | is_deeply (\@f, \@expect, "result"); 212 | } 213 | } 214 | 215 | ok (1, "empty_is_undef"); 216 | foreach my $conf ( 217 | [ 0, 0, 0, 1, "", " ", '""', 2, "", "", "" ], 218 | [ 0, 0, 1, 1, undef, " ", '""', 2, undef, undef, undef ], 219 | [ 0, 1, 0, 1, "", " ", '""', 2, "", "", "" ], 220 | [ 0, 1, 1, 1, undef, " ", '""', 2, undef, undef, undef ], 221 | [ 1, 0, 0, 1, "", " ", '""', 2, "", "", "" ], 222 | [ 1, 0, 1, 1, undef, " ", '""', 2, undef, undef, undef ], 223 | [ 1, 1, 0, 1, "", " ", '""', 2, "", "", "" ], 224 | [ 1, 1, 1, 1, undef, " ", '""', 2, undef, undef, undef ], 225 | ) { 226 | my ($aq, $aw, $bu, @expect, $str) = @$conf; 227 | $csv = Text::CSV->new ({ always_quote => $aq, allow_whitespace => $aw, empty_is_undef => $bu }); 228 | ok ($csv, "new ({ aq $aq aw $aw bu $bu })"); 229 | ok ($csv->combine (1, "", " ", '""', 2, undef, "", undef), "combine ()"); 230 | ok ($str = $csv->string, "string ()"); 231 | foreach my $eol ("", "\n", "\r\n") { 232 | my $s_eol = _readable ($eol); 233 | ok ($csv->parse ($str.$eol), "parse (*$str$s_eol*)"); 234 | ok (my @f = $csv->fields, "fields ()"); 235 | is_deeply (\@f, \@expect, "result"); 236 | } 237 | } 238 | 239 | 240 | ok (1, "Trailing junk"); 241 | foreach my $bin (0, 1) { 242 | foreach my $eol (undef, "\r") { 243 | my $s_eol = _readable ($eol); 244 | my $csv = Text::CSV->new ({ binary => $bin, eol => $eol }); 245 | ok ($csv, "$s_eol - new ()"); 246 | my @bad = ( 247 | # test, line 248 | [ 1, qq{"\r\r\n"\r} ], 249 | [ 2, qq{"\r\r\n"\r\r} ], 250 | [ 3, qq{"\r\r\n"\r\r\n} ], 251 | [ 4, qq{"\r\r\n"\t \r} ], 252 | [ 5, qq{"\r\r\n"\t \r\r} ], 253 | [ 6, qq{"\r\r\n"\t \r\r\n} ], 254 | ); 255 | my @pass = ( 0, 0, 0, 1 ); 256 | my @fail = ( 2022, 2022, 2023, 0 ); 257 | 258 | foreach my $arg (@bad) { 259 | my ($tst, $bad) = @$arg; 260 | my $ok = ($bin << 1) | ($eol ? 1 : 0); 261 | is ($csv->parse ($bad), $pass[$ok], "$tst $ok - parse () default"); 262 | is (0 + $csv->error_diag, $fail[$ok], "$tst $ok - error $fail[$ok]"); 263 | 264 | $csv->allow_whitespace (1); 265 | is ($csv->parse ($bad), $pass[$ok], "$tst $ok - parse () allow"); 266 | is (0 + $csv->error_diag, $fail[$ok], "$tst $ok - error $fail[$ok]"); 267 | } 268 | } 269 | } 270 | 271 | { ok (1, "verbatim"); 272 | my $csv = Text::CSV->new ({ 273 | sep_char => "^", 274 | binary => 1, 275 | }); 276 | 277 | my @str = ( 278 | qq{M^^Abe^Timmerman#\r\n}, 279 | qq{M^^Abe\nTimmerman#\r\n}, 280 | ); 281 | 282 | my $gc; 283 | 284 | ok (1, "verbatim on parse ()"); 285 | foreach $gc (0, 1) { 286 | $csv->verbatim ($gc); 287 | 288 | ok ($csv->parse ($str[0]), "\\n $gc parse"); 289 | my @fld = $csv->fields; 290 | is (@fld, 4, "\\n $gc fields"); 291 | is ($fld[2], "Abe", "\\n $gc fld 2"); 292 | if ($gc) { # Note line ending is still there! 293 | is ($fld[3], "Timmerman#\r\n", "\\n $gc fld 3"); 294 | } 295 | else { # Note the stripped \r! 296 | is ($fld[3], "Timmerman#", "\\n $gc fld 3"); 297 | } 298 | 299 | ok ($csv->parse ($str[1]), "\\n $gc parse"); 300 | @fld = $csv->fields; 301 | is (@fld, 3, "\\n $gc fields"); 302 | if ($gc) { # All newlines verbatim 303 | is ($fld[2], "Abe\nTimmerman#\r\n", "\\n $gc fld 2"); 304 | } 305 | else { # Note, rest is next line 306 | is ($fld[2], "Abe", "\\n $gc fld 2"); 307 | } 308 | } 309 | 310 | $csv->eol ($/ = "#\r\n"); 311 | foreach $gc (0, 1) { 312 | $csv->verbatim ($gc); 313 | 314 | ok ($csv->parse ($str[0]), "#\\r\\n $gc parse"); 315 | my @fld = $csv->fields; 316 | is (@fld, 4, "#\\r\\n $gc fields"); 317 | is ($fld[2], "Abe", "#\\r\\n $gc fld 2"); 318 | is ($fld[3], $gc ? "Timmerman#\r\n" 319 | : "Timmerman", "#\\r\\n $gc fld 3"); 320 | 321 | ok ($csv->parse ($str[1]), "#\\r\\n $gc parse"); 322 | @fld = $csv->fields; 323 | is (@fld, 3, "#\\r\\n $gc fields"); 324 | is ($fld[2], $gc ? "Abe\nTimmerman#\r\n" 325 | : "Abe", "#\\r\\n $gc fld 2"); 326 | } 327 | 328 | my $fh; 329 | ok (1, "verbatim on getline (\$fh)"); 330 | open $fh, ">", $tfn or die "$tfn: $!\n"; 331 | print $fh @str, "M^Abe^*\r\n"; 332 | close $fh; 333 | 334 | foreach $gc (0, 1) { 335 | $csv->verbatim ($gc); 336 | 337 | open $fh, "<", $tfn or die "$tfn: $!\n"; 338 | 339 | my $row; 340 | ok ($row = $csv->getline ($fh), "#\\r\\n $gc getline"); 341 | is (@$row, 4, "#\\r\\n $gc fields"); 342 | is ($row->[2], "Abe", "#\\r\\n $gc fld 2"); 343 | is ($row->[3], "Timmerman", "#\\r\\n $gc fld 3"); 344 | 345 | ok ($row = $csv->getline ($fh), "#\\r\\n $gc parse"); 346 | is (@$row, 3, "#\\r\\n $gc fields"); 347 | is ($row->[2], $gc ? "Abe\nTimmerman" 348 | : "Abe", "#\\r\\n $gc fld 2"); 349 | } 350 | 351 | $gc = $csv->verbatim (); 352 | ok (my $row = $csv->getline ($fh), "#\\r\\n $gc parse EOF"); 353 | is (@$row, 3, "#\\r\\n $gc fields"); 354 | is ($row->[2], "*\r\n", "#\\r\\n $gc fld 2"); 355 | 356 | close $fh; 357 | 358 | $csv = Text::CSV->new ({ 359 | binary => 0, 360 | verbatim => 1, 361 | eol => "#\r\n", 362 | }); 363 | open $fh, ">", $tfn or die "$tfn: $!\n"; 364 | print $fh $str[1]; 365 | close $fh; 366 | open $fh, "<", $tfn or die "$tfn: $!\n"; 367 | is ($csv->getline ($fh), undef, "#\\r\\n $gc getline 2030"); 368 | is (0 + $csv->error_diag, 2030, "Got 2030"); 369 | close $fh; 370 | unlink $tfn; 371 | } 372 | 373 | { ok (1, "keep_meta_info on getline ()"); 374 | 375 | my $csv = Text::CSV->new ({ eol => "\n" }); 376 | 377 | open my $fh, ">", $tfn or die "$tfn: $!\n"; 378 | print $fh qq{1,"",,"Q",2\n}; 379 | close $fh; 380 | 381 | is ($csv->keep_meta_info (0), 0, "No meta info"); 382 | open $fh, "<", $tfn or die "$tfn: $!\n"; 383 | my $row = $csv->getline ($fh); 384 | ok ($row, "Get 1st line"); 385 | $csv->error_diag (); 386 | is ($csv->is_quoted (2), undef, "Is field 2 quoted?"); 387 | is ($csv->is_quoted (3), undef, "Is field 3 quoted?"); 388 | close $fh; 389 | 390 | open $fh, ">", $tfn or die "$tfn: $!\n"; 391 | print $fh qq{1,"",,"Q",2\n}; 392 | close $fh; 393 | 394 | is ($csv->keep_meta_info (1), 1, "Keep meta info"); 395 | open $fh, "<", $tfn or die "$tfn: $!\n"; 396 | $row = $csv->getline ($fh); 397 | ok ($row, "Get 2nd line"); 398 | $csv->error_diag (); 399 | is ($csv->is_quoted (2), 0, "Is field 2 quoted?"); 400 | is ($csv->is_quoted (3), 1, "Is field 3 quoted?"); 401 | close $fh; 402 | unlink $tfn; 403 | } 404 | 405 | { my $csv = Text::CSV->new ({}); 406 | 407 | my $s2023 = qq{2023,",2008-04-05," \tFoo, Bar",\n}; # " 408 | # ^ 409 | 410 | is ( $csv->parse ($s2023), 0, "Parse 2023"); 411 | is (($csv->error_diag)[0], 2023, "Fail code 2023"); 412 | is (($csv->error_diag)[2], 19, "Fail position"); 413 | 414 | is ( $csv->allow_whitespace (1), 1, "Allow whitespace"); 415 | is ( $csv->parse ($s2023), 0, "Parse 2023"); 416 | is (($csv->error_diag)[0], 2023, "Fail code 2023"); 417 | is (($csv->error_diag)[2], 22, "Space is eaten now"); 418 | } 419 | 420 | { my $csv = Text::CSV->new ({ allow_unquoted_escape => 1, escape_char => "=" }); 421 | my $str = q{1,3,=}; 422 | is ( $csv->parse ($str), 0, "Parse trailing ESC"); 423 | is (($csv->error_diag)[0], 2035, "Fail code 2035"); 424 | 425 | $str .= "0"; 426 | is ( $csv->parse ($str), 1, "Parse trailing ESC"); 427 | is_deeply ([ $csv->fields ], [ 1,3,"\0" ], "Parse passed"); 428 | } 429 | --------------------------------------------------------------------------------