t/io/layers.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7     unless (find PerlIO::Layer 'perlio') {
   8         print "1..0 # Skip: not perlio\n";
   9         exit 0;
  10     }
  11     if (exists $ENV{PERLIO} && $ENV{PERLIO} !~ /^(stdio|perlio|mmap)$/) {
  12         print "1..0 # PERLIO='$ENV{PERLIO}' unknown\n";
  13         exit 0;
  14     }
  15 }
  16
  17 plan tests => 43;
  18
  19 use Config;
  20
  21 my $NONSTDIO = exists $ENV{PERLIO} && $ENV{PERLIO} ne 'stdio';
  22
  23 SKIP: {
  24     skip("This perl does not have Encode", 43)
  25         unless " $Config{extensions} " =~ / Encode /;
  26
  27     sub check {
  28         my ($result, $expected, $id) = @_;
  29         my $n = scalar @$expected;
  30         is($n, scalar @$expected, "$id - layers = $n");
  31         if ($NONSTDIO) {
  32             # Get rid of "unix" and similar OS-specific low lever layer.
  33             shift(@$result);
  34             # Change expectations.
  35             $expected->[0] = $ENV{PERLIO} if $expected->[0] eq "stdio";
  36         }
  37         for (my $i = 0; $i < $n; $i++) {
  38             my $j = $expected->[$i];
  39             if (ref $j eq 'CODE') {
  40                 ok($j->($result->[$i]), "$id - $i is ok");
  41             } else {
  42                 is($result->[$i], $j,
  43                    sprintf("$id - $i is %s",
  44                            defined $j ? $j : "undef"));
  45             }
  46         }
  47     }
  48
  49     check([ PerlIO::get_layers(STDIN) ],
  50           [ "stdio" ],
  51           "STDIN");
  52
  53     open(F, ">:crlf", "afile");
  54
  55     check([ PerlIO::get_layers(F) ],
  56           [ qw(stdio crlf) ],
  57           "open :crlf");
  58
  59     binmode(F, ":encoding(sjis)"); # "sjis" will be canonized to "shiftjis"
  60
  61     check([ PerlIO::get_layers(F) ],
  62           [ qw[stdio crlf encoding(shiftjis) utf8] ],
  63           ":encoding(sjis)");
  64
  65     binmode(F, ":pop");
  66
  67     check([ PerlIO::get_layers(F) ],
  68           [ qw(stdio crlf) ],
  69           ":pop");
  70
  71     binmode(F, ":raw");
  72
  73     check([ PerlIO::get_layers(F) ],
  74           [ "stdio" ],
  75           ":raw");
  76
  77     binmode(F, ":utf8");
  78
  79     check([ PerlIO::get_layers(F) ],
  80           [ qw(stdio utf8) ],
  81           ":utf8");
  82
  83     binmode(F, ":bytes");
  84
  85     check([ PerlIO::get_layers(F) ],
  86           [ "stdio" ],
  87           ":bytes");
  88
  89     binmode(F, ":encoding(utf8)");
  90
  91     check([ PerlIO::get_layers(F) ],
  92             [ qw[stdio encoding(utf8) utf8] ],
  93             ":encoding(utf8)");
  94
  95     binmode(F, ":raw :crlf");
  96
  97     check([ PerlIO::get_layers(F) ],
  98           [ qw(stdio crlf) ],
  99           ":raw:crlf");
 100
 101     binmode(F, ":raw :encoding(latin1)"); # "latin1" will be canonized
 102
 103     {
 104         my @results = PerlIO::get_layers(F, details => 1);
 105
 106         # Get rid of "unix" and undef.
 107         splice(@results, 0, 2) if $NONSTDIO;
 108
 109         check([ @results ],
 110               [ "stdio",    undef,        sub { $_[0] > 0 },
 111                 "encoding", "iso-8859-1", sub { $_[0] & PerlIO::F_UTF8() } ],
 112               ":raw:encoding(latin1)");
 113     }
 114
 115     binmode(F);
 116
 117     check([ PerlIO::get_layers(F) ],
 118           [ "stdio" ],
 119           "binmode");
 120
 121     close F;
 122
 123     {
 124         use open(IN => ":crlf", OUT => ":encoding(cp1252)");
 125
 126         open F, "<afile";
 127         open G, ">afile";
 128
 129         check([ PerlIO::get_layers(F, input  => 1) ],
 130               [ qw(stdio crlf) ],
 131               "use open IN");
 132
 133         check([ PerlIO::get_layers(G, output => 1) ],
 134               [ qw[stdio encoding(cp1252) utf8] ],
 135               "use open OUT");
 136
 137         close F;
 138         close G;
 139     }
 140
 141     1 while unlink "afile";
 142 }