This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix double join problem for those places where free
[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 }
8d3a61d9
JH
11 if (exists $ENV{PERLIO} && $ENV{PERLIO} !~ /^(stdio|perlio|mmap)$/) {
12 print "1..0 # PERLIO='$ENV{PERLIO}' unknown\n";
13 exit 0;
14 }
39f7a870
JH
15}
16
17plan tests => 43;
18
19use Config;
20
79d9a4d7 21my $DOSISH = $^O =~ /^(?:MSWin32|cygwin|os2|dos|NetWare|mint)$/;
52f03692
JH
22my $NONSTDIO = exists $ENV{PERLIO} && $ENV{PERLIO} ne 'stdio';
23
491abfa0
JH
24SKIP: {
25 skip("This perl does not have Encode", 43)
26 unless " $Config{extensions} " =~ / Encode /;
39f7a870
JH
27
28 sub check {
29 my ($result, $expected, $id) = @_;
52f03692 30 if ($NONSTDIO) {
79d9a4d7
JH
31 # Get rid of "unix".
32 shift @$result if $result->[0] eq "unix";
fb189484 33 # Change expectations.
52f03692 34 $expected->[0] = $ENV{PERLIO} if $expected->[0] eq "stdio";
79d9a4d7
JH
35 } elsif ($DOSISH) {
36 splice(@$result, 0, 2, "stdio")
37 if $result->[0] eq "unix" &&
38 $result->[1] eq "crlf";
fb189484 39 }
79d9a4d7
JH
40 my $n = scalar @$expected;
41 is($n, scalar @$expected, "$id - layers = $n");
39f7a870
JH
42 for (my $i = 0; $i < $n; $i++) {
43 my $j = $expected->[$i];
44 if (ref $j eq 'CODE') {
fb189484 45 ok($j->($result->[$i]), "$id - $i is ok");
39f7a870
JH
46 } else {
47 is($result->[$i], $j,
8d3a61d9
JH
48 sprintf("$id - $i is %s",
49 defined $j ? $j : "undef"));
39f7a870
JH
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
79d9a4d7 82 binmode(F, ":pop") if $DOSISH; # Drop one extra :crlf.
39f7a870
JH
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
79d9a4d7
JH
109 SKIP: {
110 skip("too complex layer coreography", 7) if $DOSISH;
111
fb189484
JH
112 my @results = PerlIO::get_layers(F, details => 1);
113
79d9a4d7
JH
114 # Get rid of the args and the flags.
115 splice(@results, 1, 2) if $NONSTDIO;
fb189484
JH
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 }
39f7a870
JH
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)");
491abfa0 133
39f7a870
JH
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}