This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
The test needs to be on defined $ENV{PERL_UNICODE} because during
[perl5.git] / 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 defined $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 }