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