Commit | Line | Data |
---|---|---|
ec28694c JH |
1 | BEGIN { |
2 | chdir 't' if -d 't'; | |
3 | @INC = '../lib'; | |
4 | require Config; import Config; | |
6b5da1a3 | 5 | unless (find PerlIO::Layer 'perlio') { |
dc87d25e | 6 | print "1..0 # Skip: PerlIO not used\n"; |
ec28694c JH |
7 | exit 0; |
8 | } | |
0214bff6 | 9 | require './test.pl'; |
ec28694c JH |
10 | } |
11 | ||
7299ca58 | 12 | plan tests => 42; |
ec28694c | 13 | |
51f12e47 | 14 | use_ok('PerlIO'); |
ec28694c JH |
15 | |
16 | my $txt = "txt$$"; | |
17 | my $bin = "bin$$"; | |
18 | my $utf = "utf$$"; | |
26e8050a | 19 | my $nonexistent = "nex$$"; |
ec28694c JH |
20 | |
21 | my $txtfh; | |
22 | my $binfh; | |
23 | my $utffh; | |
24 | ||
51f12e47 | 25 | ok(open($txtfh, ">:crlf", $txt)); |
ec28694c | 26 | |
51f12e47 | 27 | ok(open($binfh, ">:raw", $bin)); |
ec28694c | 28 | |
51f12e47 | 29 | ok(open($utffh, ">:utf8", $utf)); |
ec28694c JH |
30 | |
31 | print $txtfh "foo\n"; | |
32 | print $txtfh "bar\n"; | |
51f12e47 JH |
33 | |
34 | ok(close($txtfh)); | |
ec28694c JH |
35 | |
36 | print $binfh "foo\n"; | |
37 | print $binfh "bar\n"; | |
51f12e47 JH |
38 | |
39 | ok(close($binfh)); | |
ec28694c JH |
40 | |
41 | print $utffh "foo\x{ff}\n"; | |
42 | print $utffh "bar\x{abcd}\n"; | |
ec28694c | 43 | |
51f12e47 JH |
44 | ok(close($utffh)); |
45 | ||
46 | ok(open($txtfh, "<:crlf", $txt)); | |
47 | ||
48 | ok(open($binfh, "<:raw", $bin)); | |
49 | ||
50 | ||
51 | ok(open($utffh, "<:utf8", $utf)); | |
ec28694c | 52 | |
51f12e47 JH |
53 | is(scalar <$txtfh>, "foo\n"); |
54 | is(scalar <$txtfh>, "bar\n"); | |
ec28694c | 55 | |
51f12e47 JH |
56 | is(scalar <$binfh>, "foo\n"); |
57 | is(scalar <$binfh>, "bar\n"); | |
ec28694c | 58 | |
51f12e47 JH |
59 | is(scalar <$utffh>, "foo\x{ff}\n"); |
60 | is(scalar <$utffh>, "bar\x{abcd}\n"); | |
ec28694c | 61 | |
51f12e47 | 62 | ok(eof($txtfh));; |
ec28694c | 63 | |
51f12e47 | 64 | ok(eof($binfh)); |
ec28694c | 65 | |
51f12e47 | 66 | ok(eof($utffh)); |
ec28694c | 67 | |
51f12e47 | 68 | ok(close($txtfh)); |
ec28694c | 69 | |
51f12e47 | 70 | ok(close($binfh)); |
ec28694c | 71 | |
51f12e47 | 72 | ok(close($utffh)); |
ec28694c | 73 | |
51f12e47 JH |
74 | # magic temporary file via 3 arg open with undef |
75 | { | |
76 | ok( open(my $x,"+<",undef), 'magic temp file via 3 arg open with undef'); | |
77 | ok( defined fileno($x), ' fileno' ); | |
78 | ||
79 | select $x; | |
80 | ok( (print "ok\n"), ' print' ); | |
81 | ||
82 | select STDOUT; | |
83 | ok( seek($x,0,0), ' seek' ); | |
84 | is( scalar <$x>, "ok\n", ' readline' ); | |
85 | ok( tell($x) >= 3, ' tell' ); | |
86 | ||
87 | # test magic temp file over STDOUT | |
88 | open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!"; | |
89 | my $status = open(STDOUT,"+<",undef); | |
90 | open STDOUT, ">&OLDOUT" or die "cannot dup OLDOUT: $!"; | |
91 | # report after STDOUT is restored | |
92 | ok($status, ' re-open STDOUT'); | |
93 | close OLDOUT; | |
26e8050a NT |
94 | |
95 | SKIP: { | |
b1b34a55 | 96 | skip("TMPDIR not honored on this platform", 4) |
26e8050a NT |
97 | if !$Config{d_mkstemp} |
98 | || $^O eq 'VMS' || $^O eq 'MSwin32' || $^O eq 'os2'; | |
99 | local $ENV{TMPDIR} = $nonexistent; | |
7299ca58 NC |
100 | |
101 | # hardcoded default temp path | |
102 | my $perlio_tmp_file_glob = '/tmp/PerlIO_??????'; | |
103 | ||
0b99e986 | 104 | 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 | 105 | |
af9379e9 NC |
106 | my $filename = find_filename($x, $perlio_tmp_file_glob); |
107 | is($filename, undef, "No tmp files leaked"); | |
03cfa418 | 108 | unlink_all $filename if defined $filename; |
7299ca58 | 109 | |
26e8050a NT |
110 | mkdir $ENV{TMPDIR}; |
111 | 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 | 112 | |
af9379e9 NC |
113 | $filename = find_filename($x, $perlio_tmp_file_glob); |
114 | is($filename, undef, "No tmp files leaked"); | |
03cfa418 | 115 | unlink_all $filename if defined $filename; |
26e8050a | 116 | } |
51f12e47 JH |
117 | } |
118 | ||
af9379e9 NC |
119 | sub find_filename { |
120 | my ($fh, @globs) = @_; | |
121 | my ($dev, $inode) = stat $fh; | |
122 | die "Can't stat $fh: $!" unless defined $dev; | |
123 | ||
124 | foreach (@globs) { | |
125 | foreach my $file (glob $_) { | |
126 | my ($this_dev, $this_inode) = stat $file; | |
127 | next unless defined $this_dev; | |
128 | return $file if $this_dev == $dev && $this_inode == $inode; | |
129 | } | |
130 | } | |
131 | return; | |
7299ca58 NC |
132 | } |
133 | ||
51f12e47 | 134 | # in-memory open |
0cb48d00 RGS |
135 | SKIP: { |
136 | eval { require PerlIO::scalar }; | |
137 | unless (find PerlIO::Layer 'scalar') { | |
8a71e97e | 138 | skip("PerlIO::scalar not found", 9); |
0cb48d00 | 139 | } |
51f12e47 JH |
140 | my $var; |
141 | ok( open(my $x,"+<",\$var), 'magic in-memory file via 3 arg open with \\$var'); | |
142 | ok( defined fileno($x), ' fileno' ); | |
143 | ||
144 | select $x; | |
145 | ok( (print "ok\n"), ' print' ); | |
146 | ||
147 | select STDOUT; | |
148 | ok( seek($x,0,0), ' seek' ); | |
149 | is( scalar <$x>, "ok\n", ' readline' ); | |
150 | ok( tell($x) >= 3, ' tell' ); | |
151 | ||
152 | TODO: { | |
153 | local $TODO = "broken"; | |
154 | ||
155 | # test in-memory open over STDOUT | |
156 | open OLDOUT, ">&STDOUT" or die "cannot dup STDOUT: $!"; | |
157 | #close STDOUT; | |
158 | my $status = open(STDOUT,">",\$var); | |
159 | my $error = "$!" unless $status; # remember the error | |
3351db02 | 160 | close STDOUT unless $status; |
51f12e47 JH |
161 | open STDOUT, ">&OLDOUT" or die "cannot dup OLDOUT: $!"; |
162 | print "# $error\n" unless $status; | |
163 | # report after STDOUT is restored | |
164 | ok($status, ' open STDOUT into in-memory var'); | |
165 | ||
166 | # test in-memory open over STDERR | |
167 | open OLDERR, ">&STDERR" or die "cannot dup STDERR: $!"; | |
168 | #close STDERR; | |
169 | ok( open(STDERR,">",\$var), ' open STDERR into in-memory var'); | |
170 | open STDERR, ">&OLDERR" or die "cannot dup OLDERR: $!"; | |
171 | } | |
ec28694c | 172 | |
ec28694c | 173 | |
86cb0d30 JV |
174 | { local $TODO = 'fails well back into 5.8.x'; |
175 | ||
176 | ||
177 | sub read_fh_and_return_final_rv { | |
178 | my ($fh) = @_; | |
179 | my $buf = ''; | |
180 | my $rv; | |
181 | for (1..3) { | |
182 | $rv = read($fh, $buf, 1, length($buf)); | |
183 | next if $rv; | |
184 | } | |
185 | return $rv | |
186 | } | |
187 | ||
188 | open(my $no_perlio, '<', \'ab') or die; | |
189 | open(my $perlio, '<:crlf', \'ab') or die; | |
190 | ||
191 | is(read_fh_and_return_final_rv($perlio), read_fh_and_return_final_rv($no_perlio), "RT#69332 - perlio should return the same value as nonperlio after EOF"); | |
192 | ||
193 | close ($perlio); | |
194 | close ($no_perlio); | |
195 | } | |
196 | ||
8a71e97e Z |
197 | } |
198 | ||
86cb0d30 | 199 | |
ec28694c | 200 | END { |
03cfa418 BG |
201 | unlink_all $txt; |
202 | unlink_all $bin; | |
203 | unlink_all $utf; | |
0b99e986 | 204 | rmdir $nonexistent; |
ec28694c JH |
205 | } |
206 |