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