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