lib/Test/Harness/t/unicode.t

   1 #!/usr/bin/perl -w
   2
   3 use strict;
   4 use lib 't/lib';
   5 use Test::More;
   6 use TAP::Parser;
   7
   8 my @schedule;
   9 my %make_test;
  10
  11 BEGIN {
  12     plan skip_all => "unicode on Perl < 5.8.0"
  13       unless $] > 5.008;
  14
  15     plan skip_all => "PERL_UNICODE set"
  16       if $ENV{PERL_UNICODE};
  17
  18     eval "use File::Temp";
  19     plan skip_all => "File::Temp unavailable"
  20       if $@;
  21
  22     eval "use Encode";
  23     plan skip_all => "Encode unavailable"
  24       if $@;
  25
  26     # Subs that take the supplied TAP and turn it into a set of args to
  27     # supply to TAP::Harness->new. The returned hash includes the
  28     # temporary file so that its reference count doesn't go to zero
  29     # until we're finished with it.
  30     %make_test = (
  31         file => sub {
  32             my $source = shift;
  33             my $tmp    = File::Temp->new;
  34             open my $fh, ">$tmp" or die "Can't write $tmp ($!)\n";
  35             eval 'binmode( $fh, ":utf8" )';
  36             print $fh join( "\n", @$source ), "\n";
  37             close $fh;
  38
  39             open my $taph, "<$tmp" or die "Can't read $tmp ($!)\n";
  40             eval 'binmode( $taph, ":utf8" )';
  41             return {
  42                 temp => $tmp,
  43                 args => { source => $taph },
  44             };
  45         },
  46         script => sub {
  47             my $source = shift;
  48             my $tmp    = File::Temp->new;
  49             open my $fh, ">$tmp" or die "Can't write $tmp ($!)\n";
  50             eval 'binmode( $fh, ":utf8" )';
  51             print $fh map {"print qq{$_\\n};\n"} @$source;
  52             close $fh;
  53
  54             open my $taph, "<$tmp" or die "Can't read $tmp ($!)\n";
  55             return {
  56                 temp => $tmp,
  57                 args => { exec => [ $^X, "$tmp" ] },
  58             };
  59         },
  60     );
  61
  62     @schedule = (
  63         {   name   => 'Non-unicode warm up',
  64             source => [
  65                 'TAP version 13',
  66                 '1..1',
  67                 'ok 1 Everything is fine',
  68             ],
  69             expect => [
  70                 { isa => 'TAP::Parser::Result::Version', },
  71                 { isa => 'TAP::Parser::Result::Plan', },
  72                 {   isa         => 'TAP::Parser::Result::Test',
  73                     description => "Everything is fine"
  74                 },
  75             ],
  76         },
  77         {   name   => 'Unicode smiley',
  78             source => [
  79                 'TAP version 13',
  80                 '1..1',
  81
  82                 # Funky quoting / eval to avoid errors on older Perls
  83                 eval qq{"ok 1 Everything is fine \\x{263a}"},
  84             ],
  85             expect => [
  86                 { isa => 'TAP::Parser::Result::Version', },
  87                 { isa => 'TAP::Parser::Result::Plan', },
  88                 {   isa         => 'TAP::Parser::Result::Test',
  89                     description => eval qq{"Everything is fine \\x{263a}"}
  90                 },
  91             ],
  92         }
  93     );
  94
  95     plan 'no_plan';
  96 }
  97
  98 for my $test (@schedule) {
  99     for my $type ( sort keys %make_test ) {
 100         my $name = sprintf( "%s (%s)", $test->{name}, $type );
 101         my $args = $make_test{$type}->( $test->{source} );
 102
 103         my $parser = TAP::Parser->new( $args->{args} );
 104         isa_ok $parser, 'TAP::Parser';
 105         my @expect = @{ $test->{expect} };
 106         while ( my $tok = $parser->next ) {
 107             my $exp = shift @expect;
 108             for my $item ( sort keys %$exp ) {
 109                 my $val = $exp->{$item};
 110                 if ( 'isa' eq $item ) {
 111                     isa_ok $tok, $val;
 112                 }
 113                 elsif ( 'CODE' eq ref $val ) {
 114                     ok $val->($tok), "$name: assertion for $item";
 115                 }
 116                 else {
 117                     my $got = $tok->$item();
 118                     is $got, $val, "$name: value for $item matches";
 119                 }
 120             }
 121         }
 122     }
 123 }