This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix up Larry's copyright statements to my best knowledge.
[perl5.git] / t / io / layers.t
CommitLineData
39f7a870
JH
1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
5 @INC = '../lib';
6 require './test.pl';
491abfa0
JH
7 unless (find PerlIO::Layer 'perlio') {
8 print "1..0 # Skip: not perlio\n";
9 exit 0;
10 }
3b0db4f9
JH
11 # Makes testing easier.
12 $ENV{PERLIO} = 'stdio' if exists $ENV{PERLIO} && $ENV{PERLIO} eq '';
8d3a61d9 13 if (exists $ENV{PERLIO} && $ENV{PERLIO} !~ /^(stdio|perlio|mmap)$/) {
3b0db4f9 14 # We are not prepared for anything else.
8d3a61d9
JH
15 print "1..0 # PERLIO='$ENV{PERLIO}' unknown\n";
16 exit 0;
17 }
39f7a870
JH
18}
19
20plan tests => 43;
21
22use Config;
23
79d9a4d7 24my $DOSISH = $^O =~ /^(?:MSWin32|cygwin|os2|dos|NetWare|mint)$/;
52f03692
JH
25my $NONSTDIO = exists $ENV{PERLIO} && $ENV{PERLIO} ne 'stdio';
26
491abfa0
JH
27SKIP: {
28 skip("This perl does not have Encode", 43)
29 unless " $Config{extensions} " =~ / Encode /;
39f7a870
JH
30
31 sub check {
32 my ($result, $expected, $id) = @_;
3b0db4f9
JH
33 # An interesting dance follows where we try to make the following
34 # IO layer stack setups to compare equal:
35 #
36 # PERLIO UNIX-like DOS-like
37 #
38 # none or "" stdio unix crlf
39 # stdio stdio stdio
40 # perlio unix perlio unix perlio
41 # mmap unix mmap unix mmap
42 #
52f03692 43 if ($NONSTDIO) {
79d9a4d7
JH
44 # Get rid of "unix".
45 shift @$result if $result->[0] eq "unix";
fb189484 46 # Change expectations.
52f03692 47 $expected->[0] = $ENV{PERLIO} if $expected->[0] eq "stdio";
79d9a4d7
JH
48 } elsif ($DOSISH) {
49 splice(@$result, 0, 2, "stdio")
50 if $result->[0] eq "unix" &&
51 $result->[1] eq "crlf";
fb189484 52 }
79d9a4d7
JH
53 my $n = scalar @$expected;
54 is($n, scalar @$expected, "$id - layers = $n");
39f7a870
JH
55 for (my $i = 0; $i < $n; $i++) {
56 my $j = $expected->[$i];
57 if (ref $j eq 'CODE') {
fb189484 58 ok($j->($result->[$i]), "$id - $i is ok");
39f7a870
JH
59 } else {
60 is($result->[$i], $j,
8d3a61d9
JH
61 sprintf("$id - $i is %s",
62 defined $j ? $j : "undef"));
39f7a870
JH
63 }
64 }
65 }
66
67 check([ PerlIO::get_layers(STDIN) ],
68 [ "stdio" ],
69 "STDIN");
70
71 open(F, ">:crlf", "afile");
72
73 check([ PerlIO::get_layers(F) ],
74 [ qw(stdio crlf) ],
75 "open :crlf");
76
77 binmode(F, ":encoding(sjis)"); # "sjis" will be canonized to "shiftjis"
78
79 check([ PerlIO::get_layers(F) ],
80 [ qw[stdio crlf encoding(shiftjis) utf8] ],
81 ":encoding(sjis)");
82
83 binmode(F, ":pop");
84
85 check([ PerlIO::get_layers(F) ],
86 [ qw(stdio crlf) ],
87 ":pop");
88
89 binmode(F, ":raw");
90
91 check([ PerlIO::get_layers(F) ],
92 [ "stdio" ],
93 ":raw");
94
79d9a4d7 95 binmode(F, ":pop") if $DOSISH; # Drop one extra :crlf.
39f7a870
JH
96 binmode(F, ":utf8");
97
98 check([ PerlIO::get_layers(F) ],
99 [ qw(stdio utf8) ],
100 ":utf8");
101
102 binmode(F, ":bytes");
103
104 check([ PerlIO::get_layers(F) ],
105 [ "stdio" ],
106 ":bytes");
107
108 binmode(F, ":encoding(utf8)");
109
110 check([ PerlIO::get_layers(F) ],
111 [ qw[stdio encoding(utf8) utf8] ],
112 ":encoding(utf8)");
113
114 binmode(F, ":raw :crlf");
115
116 check([ PerlIO::get_layers(F) ],
117 [ qw(stdio crlf) ],
118 ":raw:crlf");
119
120 binmode(F, ":raw :encoding(latin1)"); # "latin1" will be canonized
121
79d9a4d7
JH
122 SKIP: {
123 skip("too complex layer coreography", 7) if $DOSISH;
124
fb189484
JH
125 my @results = PerlIO::get_layers(F, details => 1);
126
79d9a4d7
JH
127 # Get rid of the args and the flags.
128 splice(@results, 1, 2) if $NONSTDIO;
fb189484
JH
129
130 check([ @results ],
131 [ "stdio", undef, sub { $_[0] > 0 },
132 "encoding", "iso-8859-1", sub { $_[0] & PerlIO::F_UTF8() } ],
133 ":raw:encoding(latin1)");
134 }
39f7a870
JH
135
136 binmode(F);
137
138 check([ PerlIO::get_layers(F) ],
139 [ "stdio" ],
140 "binmode");
141
142 close F;
143
144 {
145 use open(IN => ":crlf", OUT => ":encoding(cp1252)");
491abfa0 146
39f7a870
JH
147 open F, "<afile";
148 open G, ">afile";
149
150 check([ PerlIO::get_layers(F, input => 1) ],
151 [ qw(stdio crlf) ],
152 "use open IN");
153
154 check([ PerlIO::get_layers(G, output => 1) ],
155 [ qw[stdio encoding(cp1252) utf8] ],
156 "use open OUT");
157
158 close F;
159 close G;
160 }
161
162 1 while unlink "afile";
163}