Commit | Line | Data |
---|---|---|
3eb568f1 NIS |
1 | #!./perl |
2 | ||
9f1b1f2d GS |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
20822f61 | 5 | @INC = '../lib'; |
ad20d923 | 6 | require './test.pl'; |
e620cd72 | 7 | } |
9f1b1f2d | 8 | |
853846ea | 9 | $| = 1; |
9f1b1f2d | 10 | use warnings; |
35066d42 | 11 | use Config; |
3eb568f1 | 12 | |
ac53db4c | 13 | plan tests => 108; |
2c8ac474 | 14 | |
b5fe401b MS |
15 | my $Perl = which_perl(); |
16 | ||
62a28c97 | 17 | my $afile = tempfile(); |
6170680b | 18 | { |
62a28c97 | 19 | unlink($afile) if -f $afile; |
ad20d923 | 20 | |
62a28c97 NC |
21 | $! = 0; # the -f above will set $! if $afile doesn't exist. |
22 | ok( open(my $f,"+>$afile"), 'open(my $f, "+>...")' ); | |
ad20d923 | 23 | |
2c8ac474 | 24 | binmode $f; |
62a28c97 | 25 | ok( -f $afile, ' its a file'); |
ad20d923 MS |
26 | ok( (print $f "SomeData\n"), ' we can print to it'); |
27 | is( tell($f), 9, ' tell()' ); | |
28 | ok( seek($f,0,0), ' seek set' ); | |
29 | ||
2c8ac474 | 30 | $b = <$f>; |
ad20d923 MS |
31 | is( $b, "SomeData\n", ' readline' ); |
32 | ok( -f $f, ' still a file' ); | |
33 | ||
e620cd72 | 34 | eval { die "Message" }; |
ad20d923 MS |
35 | like( $@, qr/<\$f> line 1/, ' die message correct' ); |
36 | ||
37 | ok( close($f), ' close()' ); | |
62a28c97 | 38 | ok( unlink($afile), ' unlink()' ); |
6170680b | 39 | } |
2c8ac474 | 40 | |
6170680b | 41 | { |
62a28c97 | 42 | ok( open(my $f,'>', $afile), "open(my \$f, '>', $afile)" ); |
ad20d923 MS |
43 | ok( (print $f "a row\n"), ' print'); |
44 | ok( close($f), ' close' ); | |
62a28c97 | 45 | ok( -s $afile < 10, ' -s' ); |
6170680b | 46 | } |
2c8ac474 | 47 | |
6170680b | 48 | { |
62a28c97 | 49 | ok( open(my $f,'>>', $afile), "open(my \$f, '>>', $afile)" ); |
ad20d923 MS |
50 | ok( (print $f "a row\n"), ' print' ); |
51 | ok( close($f), ' close' ); | |
62a28c97 | 52 | ok( -s $afile > 10, ' -s' ); |
6170680b | 53 | } |
2c8ac474 | 54 | |
6170680b | 55 | { |
62a28c97 | 56 | ok( open(my $f, '<', $afile), "open(my \$f, '<', $afile)" ); |
ad20d923 MS |
57 | my @rows = <$f>; |
58 | is( scalar @rows, 2, ' readline, list context' ); | |
59 | is( $rows[0], "a row\n", ' first line read' ); | |
60 | is( $rows[1], "a row\n", ' second line' ); | |
61 | ok( close($f), ' close' ); | |
6170680b | 62 | } |
2c8ac474 | 63 | |
6170680b | 64 | { |
62a28c97 | 65 | ok( -s $afile < 20, '-s' ); |
ad20d923 | 66 | |
62a28c97 | 67 | ok( open(my $f, '+<', $afile), 'open +<' ); |
ad20d923 MS |
68 | my @rows = <$f>; |
69 | is( scalar @rows, 2, ' readline, list context' ); | |
70 | ok( seek($f, 0, 1), ' seek cur' ); | |
71 | ok( (print $f "yet another row\n"), ' print' ); | |
72 | ok( close($f), ' close' ); | |
62a28c97 | 73 | ok( -s $afile > 20, ' -s' ); |
2c8ac474 | 74 | |
62a28c97 | 75 | unlink($afile); |
2c8ac474 | 76 | } |
c0ed5c75 | 77 | { |
ad20d923 | 78 | ok( open(my $f, '-|', <<EOC), 'open -|' ); |
dc459aad | 79 | $Perl -e "print qq(a row\\n); print qq(another row\\n)" |
6170680b | 80 | EOC |
2c8ac474 | 81 | |
ad20d923 MS |
82 | my @rows = <$f>; |
83 | is( scalar @rows, 2, ' readline, list context' ); | |
84 | ok( close($f), ' close' ); | |
2c8ac474 | 85 | } |
7b903762 | 86 | { |
ad20d923 | 87 | ok( open(my $f, '|-', <<EOC), 'open |-' ); |
b5fe401b | 88 | $Perl -pe "s/^not //" |
6170680b | 89 | EOC |
ad20d923 MS |
90 | |
91 | my @rows = <$f>; | |
92 | my $test = curr_test; | |
93 | print $f "not ok $test - piped in\n"; | |
94 | next_test; | |
95 | ||
96 | $test = curr_test; | |
97 | print $f "not ok $test - piped in\n"; | |
98 | next_test; | |
99 | ok( close($f), ' close' ); | |
2c8ac474 | 100 | sleep 1; |
ad20d923 | 101 | pass('flushing'); |
6170680b | 102 | } |
3eb568f1 | 103 | |
2c8ac474 | 104 | |
62a28c97 NC |
105 | ok( !eval { open my $f, '<&', $afile; 1; }, '<& on a non-filehandle' ); |
106 | like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); | |
2c8ac474 | 107 | |
ad20d923 MS |
108 | |
109 | # local $file tests | |
2c8ac474 | 110 | { |
62a28c97 | 111 | unlink($afile) if -f $afile; |
ad20d923 | 112 | |
62a28c97 | 113 | ok( open(local $f,"+>$afile"), 'open local $f, "+>", ...' ); |
2c8ac474 | 114 | binmode $f; |
ad20d923 | 115 | |
62a28c97 | 116 | ok( -f $afile, ' -f' ); |
ad20d923 MS |
117 | ok( (print $f "SomeData\n"), ' print' ); |
118 | is( tell($f), 9, ' tell' ); | |
119 | ok( seek($f,0,0), ' seek set' ); | |
120 | ||
2c8ac474 | 121 | $b = <$f>; |
ad20d923 MS |
122 | is( $b, "SomeData\n", ' readline' ); |
123 | ok( -f $f, ' still a file' ); | |
124 | ||
e620cd72 | 125 | eval { die "Message" }; |
ad20d923 MS |
126 | like( $@, qr/<\$f> line 1/, ' proper die message' ); |
127 | ok( close($f), ' close' ); | |
128 | ||
62a28c97 | 129 | unlink($afile); |
2c8ac474 GS |
130 | } |
131 | ||
2c8ac474 | 132 | { |
62a28c97 | 133 | ok( open(local $f,'>', $afile), 'open local $f, ">", ...' ); |
ad20d923 MS |
134 | ok( (print $f "a row\n"), ' print'); |
135 | ok( close($f), ' close'); | |
62a28c97 | 136 | ok( -s $afile < 10, ' -s' ); |
2c8ac474 GS |
137 | } |
138 | ||
2c8ac474 | 139 | { |
62a28c97 | 140 | ok( open(local $f,'>>', $afile), 'open local $f, ">>", ...' ); |
ad20d923 MS |
141 | ok( (print $f "a row\n"), ' print'); |
142 | ok( close($f), ' close'); | |
62a28c97 | 143 | ok( -s $afile > 10, ' -s' ); |
2c8ac474 GS |
144 | } |
145 | ||
2c8ac474 | 146 | { |
62a28c97 | 147 | ok( open(local $f, '<', $afile), 'open local $f, "<", ...' ); |
ad20d923 MS |
148 | my @rows = <$f>; |
149 | is( scalar @rows, 2, ' readline list context' ); | |
150 | ok( close($f), ' close' ); | |
2c8ac474 GS |
151 | } |
152 | ||
62a28c97 | 153 | ok( -s $afile < 20, ' -s' ); |
ad20d923 | 154 | |
2c8ac474 | 155 | { |
62a28c97 | 156 | ok( open(local $f, '+<', $afile), 'open local $f, "+<", ...' ); |
ad20d923 MS |
157 | my @rows = <$f>; |
158 | is( scalar @rows, 2, ' readline list context' ); | |
159 | ok( seek($f, 0, 1), ' seek cur' ); | |
160 | ok( (print $f "yet another row\n"), ' print' ); | |
161 | ok( close($f), ' close' ); | |
62a28c97 | 162 | ok( -s $afile > 20, ' -s' ); |
2c8ac474 | 163 | |
62a28c97 | 164 | unlink($afile); |
2c8ac474 GS |
165 | } |
166 | ||
c0ed5c75 | 167 | { |
ad20d923 | 168 | ok( open(local $f, '-|', <<EOC), 'open local $f, "-|", ...' ); |
dc459aad | 169 | $Perl -e "print qq(a row\\n); print qq(another row\\n)" |
2c8ac474 | 170 | EOC |
ad20d923 | 171 | my @rows = <$f>; |
2c8ac474 | 172 | |
ad20d923 MS |
173 | is( scalar @rows, 2, ' readline list context' ); |
174 | ok( close($f), ' close' ); | |
2c8ac474 | 175 | } |
ad20d923 | 176 | |
7b903762 | 177 | { |
ad20d923 | 178 | ok( open(local $f, '|-', <<EOC), 'open local $f, "|-", ...' ); |
b5fe401b | 179 | $Perl -pe "s/^not //" |
2c8ac474 | 180 | EOC |
ad20d923 MS |
181 | |
182 | my @rows = <$f>; | |
183 | my $test = curr_test; | |
184 | print $f "not ok $test - piping\n"; | |
185 | next_test; | |
186 | ||
187 | $test = curr_test; | |
188 | print $f "not ok $test - piping\n"; | |
189 | next_test; | |
190 | ok( close($f), ' close' ); | |
2c8ac474 | 191 | sleep 1; |
ad20d923 | 192 | pass("Flush"); |
2c8ac474 GS |
193 | } |
194 | ||
faecd977 | 195 | |
62a28c97 NC |
196 | ok( !eval { open local $f, '<&', $afile; 1 }, 'local <& on non-filehandle'); |
197 | like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); | |
ad20d923 | 198 | |
faecd977 GS |
199 | { |
200 | local *F; | |
ed2efe3e | 201 | for (1..2) { |
24a7a40d | 202 | ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' ); |
ad20d923 | 203 | is(scalar <F>, "ok\n", ' readline'); |
24a7a40d | 204 | ok( close F, ' close' ); |
ed2efe3e | 205 | } |
ad20d923 | 206 | |
ed2efe3e | 207 | for (1..2) { |
24a7a40d SG |
208 | ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|'); |
209 | is( scalar <F>, "ok\n", ' readline'); | |
ad20d923 | 210 | ok( close F, ' close' ); |
ed2efe3e | 211 | } |
faecd977 | 212 | } |
f6c77cf1 | 213 | |
04dd828a JH |
214 | |
215 | # other dupping techniques | |
216 | { | |
24a7a40d SG |
217 | ok( open(my $stdout, ">&", \*STDOUT), 'dup \*STDOUT into lexical fh'); |
218 | ok( open(STDOUT, ">&", $stdout), 'restore dupped STDOUT from lexical fh'); | |
219 | ||
3b82e551 JH |
220 | { |
221 | use strict; # the below should not warn | |
222 | ok( open(my $stdout, ">&", STDOUT), 'dup STDOUT into lexical fh'); | |
223 | } | |
224 | ||
24a7a40d | 225 | # used to try to open a file [perl #17830] |
0685228b | 226 | ok( open(my $stdin, "<&", fileno STDIN), 'dup fileno(STDIN) into lexical fh') or _diag $!; |
04dd828a JH |
227 | } |
228 | ||
35066d42 RGS |
229 | SKIP: { |
230 | skip "This perl uses perlio", 1 if $Config{useperlio}; | |
43651d81 NC |
231 | skip "miniperl cannot be relied on to load %Errno" |
232 | if $ENV{PERL_CORE_MINITEST}; | |
233 | # Force the reference to %! to be run time by writing ! as {"!"} | |
234 | skip "This system doesn't understand EINVAL", 1 | |
235 | unless exists ${"!"}{EINVAL}; | |
35066d42 | 236 | |
aaac28e4 | 237 | no warnings 'io'; |
43651d81 | 238 | ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL'); |
35066d42 RGS |
239 | } |
240 | ||
241 | { | |
242 | ok( !eval { open F, "BAR", "QUUX" }, 'Unknown open() mode' ); | |
243 | like( $@, qr/\QUnknown open() mode 'BAR'/, ' right error' ); | |
244 | } | |
0c4b0a3f JH |
245 | |
246 | { | |
247 | local $SIG{__WARN__} = sub { $@ = shift }; | |
248 | ||
249 | sub gimme { | |
250 | my $tmphandle = shift; | |
251 | my $line = scalar <$tmphandle>; | |
252 | warn "gimme"; | |
253 | return $line; | |
254 | } | |
255 | ||
256 | open($fh0[0], "TEST"); | |
257 | gimme($fh0[0]); | |
258 | like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem"); | |
259 | ||
260 | open($fh1{k}, "TEST"); | |
261 | gimme($fh1{k}); | |
262 | like($@, qr/<\$fh1{...}> line 1\./, "autoviv fh package helem"); | |
263 | ||
264 | my @fh2; | |
265 | open($fh2[0], "TEST"); | |
266 | gimme($fh2[0]); | |
267 | like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem"); | |
268 | ||
269 | my %fh3; | |
270 | open($fh3{k}, "TEST"); | |
271 | gimme($fh3{k}); | |
272 | like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem"); | |
0c4b0a3f JH |
273 | } |
274 | ||
7e72d509 | 275 | SKIP: { |
a9f76400 | 276 | skip("These tests use perlio", 5) unless $Config{useperlio}; |
7e72d509 JH |
277 | my $w; |
278 | use warnings 'layer'; | |
279 | local $SIG{__WARN__} = sub { $w = shift }; | |
280 | ||
62a28c97 | 281 | eval { open(F, ">>>", $afile) }; |
b4581f09 | 282 | like($w, qr/Invalid separator character '>' in PerlIO layer spec/, |
a9f76400 | 283 | "bad open (>>>) warning"); |
7e72d509 | 284 | like($@, qr/Unknown open\(\) mode '>>>'/, |
a9f76400 JH |
285 | "bad open (>>>) failure"); |
286 | ||
62a28c97 | 287 | eval { open(F, ">:u", $afile ) }; |
b4581f09 | 288 | like($w, qr/Unknown PerlIO layer "u"/, |
a9f76400 | 289 | 'bad layer ">:u" warning'); |
62a28c97 | 290 | eval { open(F, "<:u", $afile ) }; |
b4581f09 | 291 | like($w, qr/Unknown PerlIO layer "u"/, |
a9f76400 | 292 | 'bad layer "<:u" warning'); |
62a28c97 | 293 | eval { open(F, ":c", $afile ) }; |
b4581f09 JH |
294 | like($@, qr/Unknown open\(\) mode ':c'/, |
295 | 'bad layer ":c" failure'); | |
7e72d509 JH |
296 | } |
297 | ||
15332aa2 DM |
298 | # [perl #28986] "open m" crashes Perl |
299 | ||
300 | fresh_perl_like('open m', qr/^Search pattern not terminated at/, | |
301 | { stderr => 1 }, 'open m test'); | |
302 | ||
ba2ce822 DM |
303 | fresh_perl_is( |
304 | 'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"', | |
305 | 'ok', { stderr => 1 }, | |
306 | '#29102: Crash on assignment to lexical filehandle'); | |
ac53db4c DM |
307 | |
308 | # [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise | |
309 | # an exception | |
310 | ||
311 | eval { open $99, "foo" }; | |
312 | like($@, qr/Modification of a read-only value attempted/, "readonly fh"); |