Commit | Line | Data |
---|---|---|
ec28694c JH |
1 | BEGIN { |
2 | chdir 't' if -d 't'; | |
3 | @INC = '../lib'; | |
4 | require Config; import Config; | |
0214bff6 | 5 | require './test.pl'; |
e05e9c3d | 6 | skip_all_without_perlio(); |
ec28694c JH |
7 | } |
8 | ||
67f2cc75 | 9 | plan tests => 48; |
ec28694c | 10 | |
51f12e47 | 11 | use_ok('PerlIO'); |
ec28694c JH |
12 | |
13 | my $txt = "txt$$"; | |
14 | my $bin = "bin$$"; | |
15 | my $utf = "utf$$"; | |
26e8050a | 16 | my $nonexistent = "nex$$"; |
ec28694c JH |
17 | |
18 | my $txtfh; | |
19 | my $binfh; | |
20 | my $utffh; | |
21 | ||
51f12e47 | 22 | ok(open($txtfh, ">:crlf", $txt)); |
ec28694c | 23 | |
51f12e47 | 24 | ok(open($binfh, ">:raw", $bin)); |
ec28694c | 25 | |
51f12e47 | 26 | ok(open($utffh, ">:utf8", $utf)); |
ec28694c JH |
27 | |
28 | print $txtfh "foo\n"; | |
29 | print $txtfh "bar\n"; | |
51f12e47 JH |
30 | |
31 | ok(close($txtfh)); | |
ec28694c JH |
32 | |
33 | print $binfh "foo\n"; | |
34 | print $binfh "bar\n"; | |
51f12e47 JH |
35 | |
36 | ok(close($binfh)); | |
ec28694c JH |
37 | |
38 | print $utffh "foo\x{ff}\n"; | |
39 | print $utffh "bar\x{abcd}\n"; | |
ec28694c | 40 | |
51f12e47 JH |
41 | ok(close($utffh)); |
42 | ||
43 | ok(open($txtfh, "<:crlf", $txt)); | |
44 | ||
45 | ok(open($binfh, "<:raw", $bin)); | |
46 | ||
47 | ||
48 | ok(open($utffh, "<:utf8", $utf)); | |
ec28694c | 49 | |
51f12e47 JH |
50 | is(scalar <$txtfh>, "foo\n"); |
51 | is(scalar <$txtfh>, "bar\n"); | |
ec28694c | 52 | |
51f12e47 JH |
53 | is(scalar <$binfh>, "foo\n"); |
54 | is(scalar <$binfh>, "bar\n"); | |
ec28694c | 55 | |
51f12e47 JH |
56 | is(scalar <$utffh>, "foo\x{ff}\n"); |
57 | is(scalar <$utffh>, "bar\x{abcd}\n"); | |
ec28694c | 58 | |
51f12e47 | 59 | ok(eof($txtfh));; |
ec28694c | 60 | |
51f12e47 | 61 | ok(eof($binfh)); |
ec28694c | 62 | |
51f12e47 | 63 | ok(eof($utffh)); |
ec28694c | 64 | |
51f12e47 | 65 | ok(close($txtfh)); |
ec28694c | 66 | |
51f12e47 | 67 | ok(close($binfh)); |
ec28694c | 68 | |
51f12e47 | 69 | ok(close($utffh)); |
ec28694c | 70 | |
51f12e47 JH |
71 | # magic temporary file via 3 arg open with undef |
72 | { | |
73 | ok( open(my $x,"+<",undef), 'magic temp file via 3 arg open with undef'); | |
74 | ok( defined fileno($x), ' fileno' ); | |
75 | ||
76 | select $x; | |
77 | ok( (print "ok\n"), ' print' ); | |
78 | ||
79 | select STDOUT; | |
80 | ok( seek($x,0,0), ' seek' ); | |
81 | is( scalar <$x>, "ok\n", ' readline' ); | |
82 | ok( tell($x) >= 3, ' tell' ); | |
83 | ||
84 | # test magic temp file over STDOUT | |
85 | open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!"; | |
86 | my $status = open(STDOUT,"+<",undef); | |
87 | open STDOUT, ">&OLDOUT" or die "cannot dup OLDOUT: $!"; | |
88 | # report after STDOUT is restored | |
89 | ok($status, ' re-open STDOUT'); | |
90 | close OLDOUT; | |
26e8050a NT |
91 | |
92 | SKIP: { | |
b1b34a55 | 93 | skip("TMPDIR not honored on this platform", 4) |
26e8050a NT |
94 | if !$Config{d_mkstemp} |
95 | || $^O eq 'VMS' || $^O eq 'MSwin32' || $^O eq 'os2'; | |
96 | local $ENV{TMPDIR} = $nonexistent; | |
7299ca58 NC |
97 | |
98 | # hardcoded default temp path | |
99 | my $perlio_tmp_file_glob = '/tmp/PerlIO_??????'; | |
100 | ||
0b99e986 | 101 | ok( open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to a non-existent dir'); |
26e8050a | 102 | |
af9379e9 NC |
103 | my $filename = find_filename($x, $perlio_tmp_file_glob); |
104 | is($filename, undef, "No tmp files leaked"); | |
03cfa418 | 105 | unlink_all $filename if defined $filename; |
7299ca58 | 106 | |
26e8050a NT |
107 | mkdir $ENV{TMPDIR}; |
108 | ok(open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to an existent dir'); | |
c1bf414c | 109 | |
af9379e9 NC |
110 | $filename = find_filename($x, $perlio_tmp_file_glob); |
111 | is($filename, undef, "No tmp files leaked"); | |
03cfa418 | 112 | unlink_all $filename if defined $filename; |
26e8050a | 113 | } |
51f12e47 JH |
114 | } |
115 | ||
67f2cc75 AC |
116 | # fileno() for directory handles, on supported platforms |
117 | SKIP: { | |
118 | opendir my $dh, "io" | |
119 | or die "Huh? Can't open directory 'io' containing this file: $!\n"; | |
120 | local $! = 0; | |
121 | my $fd = fileno $dh; | |
122 | my $errno = 0 + $!; | |
123 | closedir $dh | |
124 | or die "Huh? Can't close freshly-opened directory handle: $!\n"; | |
125 | if ($Config{d_dirfd} || $Config{d_dir_dd_fd}) { | |
126 | ok(defined $fd, "fileno(DIRHANDLE) is defined under dirfd()") | |
127 | or skip("directory fd was undefined", 1); | |
128 | like($fd, qr/\A\d+\z/a, | |
129 | "fileno(DIRHANDLE) yields non-negative int under dirfd()"); | |
130 | } | |
131 | else { | |
132 | ok(!defined $fd, "fileno(DIRHANDLE) is undef when no dirfd()"); | |
cfd916dd | 133 | isnt($errno, 0, "fileno(DIRHANDLE) sets errno when no dirfd()"); |
67f2cc75 AC |
134 | } |
135 | } | |
136 | ||
af9379e9 NC |
137 | sub find_filename { |
138 | my ($fh, @globs) = @_; | |
139 | my ($dev, $inode) = stat $fh; | |
140 | die "Can't stat $fh: $!" unless defined $dev; | |
141 | ||
142 | foreach (@globs) { | |
143 | foreach my $file (glob $_) { | |
144 | my ($this_dev, $this_inode) = stat $file; | |
145 | next unless defined $this_dev; | |
146 | return $file if $this_dev == $dev && $this_inode == $inode; | |
147 | } | |
148 | } | |
149 | return; | |
7299ca58 NC |
150 | } |
151 | ||
51f12e47 | 152 | # in-memory open |
0cb48d00 RGS |
153 | SKIP: { |
154 | eval { require PerlIO::scalar }; | |
155 | unless (find PerlIO::Layer 'scalar') { | |
abc55529 | 156 | skip("PerlIO::scalar not found", 11); |
0cb48d00 | 157 | } |
51f12e47 JH |
158 | my $var; |
159 | ok( open(my $x,"+<",\$var), 'magic in-memory file via 3 arg open with \\$var'); | |
160 | ok( defined fileno($x), ' fileno' ); | |
161 | ||
162 | select $x; | |
163 | ok( (print "ok\n"), ' print' ); | |
164 | ||
165 | select STDOUT; | |
166 | ok( seek($x,0,0), ' seek' ); | |
167 | is( scalar <$x>, "ok\n", ' readline' ); | |
168 | ok( tell($x) >= 3, ' tell' ); | |
169 | ||
170 | TODO: { | |
171 | local $TODO = "broken"; | |
172 | ||
173 | # test in-memory open over STDOUT | |
174 | open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!"; | |
175 | #close STDOUT; | |
176 | my $status = open(STDOUT,">",\$var); | |
177 | my $error = "$!" unless $status; # remember the error | |
3351db02 | 178 | close STDOUT unless $status; |
51f12e47 JH |
179 | open STDOUT, ">&OLDOUT" or die "cannot dup OLDOUT: $!"; |
180 | print "# $error\n" unless $status; | |
181 | # report after STDOUT is restored | |
182 | ok($status, ' open STDOUT into in-memory var'); | |
183 | ||
184 | # test in-memory open over STDERR | |
185 | open OLDERR, ">&STDERR" or die "cannot dup STDERR: $!"; | |
186 | #close STDERR; | |
187 | ok( open(STDERR,">",\$var), ' open STDERR into in-memory var'); | |
188 | open STDERR, ">&OLDERR" or die "cannot dup OLDERR: $!"; | |
189 | } | |
ec28694c | 190 | |
ec28694c | 191 | |
b4c6bb84 | 192 | { local $TODO = 'fails well back into 5.8.x'; |
86cb0d30 JV |
193 | |
194 | ||
b4c6bb84 | 195 | sub read_fh_and_return_final_rv { |
86cb0d30 JV |
196 | my ($fh) = @_; |
197 | my $buf = ''; | |
198 | my $rv; | |
199 | for (1..3) { | |
200 | $rv = read($fh, $buf, 1, length($buf)); | |
201 | next if $rv; | |
202 | } | |
203 | return $rv | |
b4c6bb84 | 204 | } |
86cb0d30 | 205 | |
b4c6bb84 FC |
206 | open(my $no_perlio, '<', \'ab') or die; |
207 | open(my $perlio, '<:crlf', \'ab') or die; | |
86cb0d30 | 208 | |
b4c6bb84 FC |
209 | is(read_fh_and_return_final_rv($perlio), |
210 | read_fh_and_return_final_rv($no_perlio), | |
211 | "RT#69332 - perlio should return the same value as nonperlio after EOF"); | |
86cb0d30 | 212 | |
b4c6bb84 FC |
213 | close ($perlio); |
214 | close ($no_perlio); | |
215 | } | |
86cb0d30 | 216 | |
b4c6bb84 FC |
217 | { # [perl #92258] |
218 | open my $fh, "<", \(my $f = *f); | |
219 | is join("", <$fh>), '*main::f', 'reading from a glob copy'; | |
220 | is ref \$f, 'GLOB', 'the glob copy is unaffected'; | |
221 | } | |
71edc894 | 222 | |
8a71e97e Z |
223 | } |
224 | ||
4cc39766 NC |
225 | { |
226 | # see RT #75722, RT #96008 | |
227 | fresh_perl_like(<<'EOP', | |
228 | unshift @INC, sub { | |
229 | return undef unless caller eq "main"; | |
230 | open my $fh, "<", \1; | |
231 | $fh; | |
232 | }; | |
233 | require Symbol; # doesn't matter whether it exists or not | |
234 | EOP | |
235 | qr/\ARecursive call to Perl_load_module in PerlIO_find_layer at/s, | |
236 | {stderr => 1}, | |
237 | 'Mutal recursion between Perl_load_module and PerlIO_find_layer croaks'); | |
238 | } | |
86cb0d30 | 239 | |
c7996136 LM |
240 | { |
241 | # RT #119287 | |
242 | $main::PerlIO_code_injection = 0; | |
243 | local $SIG{__WARN__} = sub {}; | |
244 | PerlIO->import('via; $main::PerlIO_code_injection = 1'); | |
245 | ok !$main::PerlIO_code_injection, "Can't inject code via PerlIO->import"; | |
246 | } | |
247 | ||
ec28694c | 248 | END { |
03cfa418 BG |
249 | unlink_all $txt; |
250 | unlink_all $bin; | |
251 | unlink_all $utf; | |
0b99e986 | 252 | rmdir $nonexistent; |
ec28694c JH |
253 | } |
254 |