xt/author/Text_CSV_Various.t

   1 #!/usr/bin/perl
   2
   3 # This file is part of Koha.
   4 #
   5 # Koha is free software; you can redistribute it and/or modify it under the
   6 # terms of the GNU General Public License as published by the Free Software
   7 # Foundation; either version 3 of the License, or (at your option) any later
   8 # version.
   9 #
  10 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  11 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  12 # A PARTICULAR PURPOSE. See the GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License along
  15 # with Koha; if not, see <http://www.gnu.org/licenses>.
  16
  17 #This test demonstrates why Koha uses the CSV parser and configration
  18 #it does.  Specifically, the test is for Unicode compliance in text
  19 #parsing and data.  This test requires other modules that Koha doesn't
  20 #actually use, in order to compare.  Therefore, running this test is not
  21 #necessary to test your Koha installation.
  22
  23 use Modern::Perl;
  24
  25 use Test::More tests => 32;
  26 use Test::Warn;
  27 BEGIN {
  28         use FindBin;
  29         use lib $FindBin::Bin;
  30         use_ok('Text::CSV');
  31         use_ok('Text::CSV_XS');
  32         use_ok('Text::CSV::Unicode');
  33 }
  34
  35 sub pretty_line {
  36         my $max = 54;
  37         (@_) or return "#" x $max . "\n";
  38         my $phrase = "  " . shift() . "  ";
  39         my $half = "#" x (($max - length($phrase))/2);
  40         return $half . $phrase . $half . "\n";
  41 }
  42
  43 my ($csv, $bin, %parsers);
  44
  45 foreach(qw(Text::CSV Text::CSV_XS Text::CSV::Unicode)) {
  46     ok($csv = $_->new(),            $_ . '->new()');
  47     ok($bin = $_->new({binary=>1}), $_ . '->new({binary=>1})');
  48     $csv and $parsers{$_} = $csv;
  49     $bin and $parsers{$_ . " (binary)"} = $bin;
  50 }
  51
  52 my $lines = [
  53     {description=>"010D: LATIN SMALL LETTER C WITH CARON",     character=>'č', line=>'field1,second field,field3,do_we_have_a_č_problem?, f!fth field ,lastfield'},
  54     {description=>"0117: LATIN SMALL LETTER E WITH DOT ABOVE", character=>'ė', line=>'field1,second field,field3,do_we_have_a_ė_problem?, f!fth field ,lastfield'},
  55 ];
  56 # 010D: č LATIN SMALL LETTER C WITH CARON
  57 # 0117: ė LATIN SMALL LETTER E WITH DOT ABOVE
  58 ok( scalar(keys %parsers)>0 && scalar(@$lines)>0,
  59     sprintf "Testing %d lines with  %d parsers.",
  60          scalar(@$lines), scalar(keys %parsers) );
  61 foreach my $key (sort keys %parsers) {
  62     my $parser = $parsers{$key};
  63     print "Testing parser $key version " . ($parser->version||'?') . "\n";
  64 }
  65 my $i = 0;
  66 LINE: foreach (@$lines) {
  67     print pretty_line("Line " . ++$i);
  68     print pretty_line($_->{description} . ': ' . $_->{character});
  69     foreach my $key (sort keys %parsers) {
  70         my $parser = $parsers{$key};
  71         my ($status,$count,@fields);
  72         $status = $parser->parse($_->{line});
  73         if ($status) {
  74             ok($status, "parse ($key)");
  75             @fields = $parser->fields;
  76             ok(($count = scalar(@fields)) == 6, "Number of fields ($count of 6)");
  77             my $j = 0;
  78             foreach my $f (@fields) {
  79                 ++$j;
  80                 if ($j==4) {
  81                     if ($key ne 'Text::CSV::Unicode (binary)') {
  82                         warning_like {
  83                             print "\t field " . $j . ": $f\n"
  84                         } [ qr/Wide character in print/ ], 'Expected wide print';
  85                     } else {
  86                         print "\t field " . $j . ": $f\n"
  87                     }
  88                 }
  89                 else {
  90                     print "\t field " . $j . ": $f\n";
  91                 }
  92             }
  93         }
  94         else {
  95             ok(! $status, "parse ($key) fails as expected");
  96         }
  97     }
  98 }
  99 done_testing();