1#!./perl 2 3my $PERLIO; 4 5BEGIN { 6 chdir 't' if -d 't'; 7 require './test.pl'; 8 set_up_inc('../lib'); 9 skip_all_without_perlio(); 10 # FIXME - more of these could be tested without Encode or full perl 11 skip_all_without_dynamic_extension('Encode'); 12 13 # Makes testing easier. 14 $ENV{PERLIO} = 'stdio' if exists $ENV{PERLIO} && $ENV{PERLIO} eq ''; 15 skip_all("PERLIO='$ENV{PERLIO}' unknown") 16 if exists $ENV{PERLIO} && $ENV{PERLIO} !~ /^(stdio|perlio|mmap)$/; 17 $PERLIO = exists $ENV{PERLIO} ? $ENV{PERLIO} : "(undef)"; 18} 19 20use Config; 21 22my $DOSISH = $^O =~ /^(?:MSWin32|os2)$/ ? 1 : 0; 23my $NONSTDIO = exists $ENV{PERLIO} && $ENV{PERLIO} ne 'stdio' ? 1 : 0; 24my $FASTSTDIO = $Config{d_faststdio} && $Config{usefaststdio} ? 1 : 0; 25my $UTF8_STDIN; 26if (${^UNICODE} & 1) { 27 if (${^UNICODE} & 64) { 28 # Conditional on the locale 29 $UTF8_STDIN = ${^UTF8LOCALE}; 30 } else { 31 # Unconditional 32 $UTF8_STDIN = 1; 33 } 34} else { 35 $UTF8_STDIN = 0; 36} 37my $NTEST = 62 - (($DOSISH || !$FASTSTDIO) ? 7 : 0) - ($DOSISH ? 7 : 0) 38 + $UTF8_STDIN; 39 40sub PerlIO::F_UTF8 () { 0x00008000 } # from perliol.h 41 42plan tests => $NTEST; 43 44print <<__EOH__; 45# PERLIO = $PERLIO 46# DOSISH = $DOSISH 47# NONSTDIO = $NONSTDIO 48# FASTSTDIO = $FASTSTDIO 49# UNICODE = ${^UNICODE} 50# UTF8LOCALE = ${^UTF8LOCALE} 51# UTF8_STDIN = $UTF8_STDIN 52__EOH__ 53 54{ 55 sub check { 56 my ($result, $expected, $id) = @_; 57 # An interesting dance follows where we try to make the following 58 # IO layer stack setups to compare equal: 59 # 60 # PERLIO UNIX-like DOS-like 61 # 62 # unset / "" unix perlio / stdio [1] unix crlf 63 # stdio unix perlio / stdio [1] stdio 64 # perlio unix perlio unix perlio 65 # mmap unix mmap unix mmap 66 # 67 # [1] "stdio" if Configure found out how to do "fast stdio" (depends 68 # on the stdio implementation) and in Perl 5.8, otherwise "unix perlio" 69 # 70 if ($NONSTDIO) { 71 # Get rid of "unix". 72 shift @$result if $result->[0] eq "unix"; 73 # Change expectations. 74 if ($FASTSTDIO) { 75 $expected->[0] = $ENV{PERLIO}; 76 } else { 77 $expected->[0] = $ENV{PERLIO} if $expected->[0] eq "stdio"; 78 } 79 } elsif (!$FASTSTDIO && !$DOSISH) { 80 splice(@$result, 0, 2, "stdio") 81 if @$result >= 2 && 82 $result->[0] eq "unix" && 83 $result->[1] eq "perlio"; 84 } elsif ($DOSISH) { 85 splice(@$result, 0, 2, "stdio") 86 if @$result >= 2 && 87 $result->[0] eq "unix" && 88 $result->[1] eq "crlf"; 89 } 90 if ($DOSISH && grep { $_ eq 'crlf' } @$expected) { 91 # 5 tests potentially skipped because 92 # DOSISH systems already have a CRLF layer 93 # which will make new ones not stick. 94 splice @$expected, 1, 1 if $expected->[1] eq 'crlf'; 95 } 96 my $n = scalar @$expected; 97 is(scalar @$result, $n, "$id - layers == $n"); 98 for (my $i = 0; $i < $n; $i++) { 99 my $j = $expected->[$i]; 100 if (ref $j eq 'CODE') { 101 ok($j->($result->[$i]), "$id - $i is ok"); 102 } else { 103 is($result->[$i], $j, 104 sprintf("$id - $i is %s", 105 defined $j ? $j : "undef")); 106 } 107 } 108 } 109 110 check([ PerlIO::get_layers(STDIN) ], 111 $UTF8_STDIN ? [ "stdio", "utf8" ] : [ "stdio" ], 112 "STDIN"); 113 114 my $afile = tempfile(); 115 open(F, ">:crlf", $afile); 116 117 check([ PerlIO::get_layers(F) ], 118 [ qw(stdio crlf) ], 119 "open :crlf"); 120 121 binmode(F, ":crlf"); 122 123 check([ PerlIO::get_layers(F) ], 124 [ qw(stdio crlf) ], 125 "binmode :crlf"); 126 127 binmode(F, ":encoding(cp1047)"); 128 129 check([ PerlIO::get_layers(F) ], 130 [ qw[stdio crlf encoding(cp1047) utf8] ], 131 ":encoding(cp1047)"); 132 133 binmode(F, ":crlf"); 134 135 check([ PerlIO::get_layers(F) ], 136 [ qw[stdio crlf encoding(cp1047) utf8 crlf utf8] ], 137 ":encoding(cp1047):crlf"); 138 139 binmode(F, ":pop:pop"); 140 141 check([ PerlIO::get_layers(F) ], 142 [ qw(stdio crlf) ], 143 ":pop"); 144 145 binmode(F, ":raw"); 146 147 check([ PerlIO::get_layers(F) ], 148 [ "stdio" ], 149 ":raw"); 150 151 binmode(F, ":utf8"); 152 153 check([ PerlIO::get_layers(F) ], 154 [ qw(stdio utf8) ], 155 ":utf8"); 156 157 binmode(F, ":bytes"); 158 159 check([ PerlIO::get_layers(F) ], 160 [ "stdio" ], 161 ":bytes"); 162 163 binmode(F, ":encoding(utf8)"); 164 165 check([ PerlIO::get_layers(F) ], 166 [ qw[stdio encoding(utf8) utf8] ], 167 ":encoding(utf8)"); 168 169 binmode(F, ":raw :crlf"); 170 171 check([ PerlIO::get_layers(F) ], 172 [ qw(stdio crlf) ], 173 ":raw:crlf"); 174 175 binmode(F, ":raw :encoding(latin1)"); # "latin1" will be canonized 176 177 # 7 tests potentially skipped. 178 unless ($DOSISH || !$FASTSTDIO) { 179 my @results = PerlIO::get_layers(F, details => 1); 180 181 # Get rid of the args and the flags. 182 splice(@results, 1, 2) if $NONSTDIO; 183 184 check([ @results ], 185 [ "stdio", undef, sub { $_[0] > 0 }, 186 "encoding", "iso-8859-1", sub { $_[0] & PerlIO::F_UTF8() } ], 187 ":raw:encoding(latin1)"); 188 } 189 190 binmode(F); 191 192 check([ PerlIO::get_layers(F) ], 193 [ "stdio" ], 194 "binmode"); 195 196 check([ PerlIO::get_layers(*F{IO}) ], 197 [ "stdio" ], 198 "binmode"); 199 200 # RT78844 201 { 202 local $@ = "foo"; 203 binmode(F, ":encoding(utf8)"); 204 is( $@, "foo", '$@ not clobbered by binmode and :encoding'); 205 } 206 207 close F; 208 209 { 210 use open(IN => ":crlf", OUT => ":encoding(cp1252)"); 211 212 open F, '<', $afile; 213 open G, '>', $afile; 214 215 check([ PerlIO::get_layers(F, input => 1) ], 216 [ qw(stdio crlf) ], 217 "use open IN"); 218 219 check([ PerlIO::get_layers(G, output => 1) ], 220 [ qw[stdio encoding(cp1252) utf8] ], 221 "use open OUT"); 222 223 close F; 224 close G; 225 } 226 227 # Check that PL_sigwarn's reference count is correct, and that 228 # &PerlIO::Layer::NoWarnings isn't prematurely freed. 229 fresh_perl_like (<<"EOT", qr/^CODE/, {}, "Check PL_sigwarn's reference count"); 230open(UTF, "<:raw:encoding(utf8)", '$afile') or die \$!; 231print ref *PerlIO::Layer::NoWarnings{CODE}; 232EOT 233 234 # [perl #97956] Not calling FETCH all the time on tied variables 235 my $f; 236 sub TIESCALAR { bless [] } 237 sub FETCH { ++$f; $_[0][0] = $_[1] } 238 sub STORE { $_[0][0] } 239 tie my $t, ""; 240 $t = *f; 241 $f = 0; PerlIO::get_layers $t; 242 is $f, 1, '1 fetch on tied glob'; 243 $t = \*f; 244 $f = 0; PerlIO::get_layers $t; 245 is $f, 1, '1 fetch on tied globref'; 246 $t = *f; 247 $f = 0; PerlIO::get_layers \$t; 248 is $f, 1, '1 fetch on referenced tied glob'; 249 $t = ''; 250 $f = 0; PerlIO::get_layers $t; 251 is $f, 1, '1 fetch on tied string'; 252 253 # No distinction between nums and strings 254 open "12", "<:crlf", "test.pl" or die "$0 cannot open test.pl: $!"; 255 ok PerlIO::get_layers(12), 'str/num arguments are treated identically'; 256} 257