| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 4 | chdir 't' if -d 't'; |
| 5 | @INC = '../lib'; |
| 6 | require './test.pl'; |
| 7 | } |
| 8 | |
| 9 | $| = 1; |
| 10 | use warnings; |
| 11 | use Config; |
| 12 | |
| 13 | plan tests => 122; |
| 14 | |
| 15 | my $Perl = which_perl(); |
| 16 | |
| 17 | my $afile = tempfile(); |
| 18 | { |
| 19 | unlink($afile) if -f $afile; |
| 20 | |
| 21 | $! = 0; # the -f above will set $! if $afile doesn't exist. |
| 22 | ok( open(my $f,"+>$afile"), 'open(my $f, "+>...")' ); |
| 23 | |
| 24 | binmode $f; |
| 25 | ok( -f $afile, ' its a file'); |
| 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 | |
| 30 | $b = <$f>; |
| 31 | is( $b, "SomeData\n", ' readline' ); |
| 32 | ok( -f $f, ' still a file' ); |
| 33 | |
| 34 | eval { die "Message" }; |
| 35 | like( $@, qr/<\$f> line 1/, ' die message correct' ); |
| 36 | |
| 37 | ok( close($f), ' close()' ); |
| 38 | ok( unlink($afile), ' unlink()' ); |
| 39 | } |
| 40 | |
| 41 | { |
| 42 | ok( open(my $f,'>', $afile), "open(my \$f, '>', $afile)" ); |
| 43 | ok( (print $f "a row\n"), ' print'); |
| 44 | ok( close($f), ' close' ); |
| 45 | ok( -s $afile < 10, ' -s' ); |
| 46 | } |
| 47 | |
| 48 | { |
| 49 | ok( open(my $f,'>>', $afile), "open(my \$f, '>>', $afile)" ); |
| 50 | ok( (print $f "a row\n"), ' print' ); |
| 51 | ok( close($f), ' close' ); |
| 52 | ok( -s $afile > 10, ' -s' ); |
| 53 | } |
| 54 | |
| 55 | { |
| 56 | ok( open(my $f, '<', $afile), "open(my \$f, '<', $afile)" ); |
| 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' ); |
| 62 | } |
| 63 | |
| 64 | { |
| 65 | ok( -s $afile < 20, '-s' ); |
| 66 | |
| 67 | ok( open(my $f, '+<', $afile), 'open +<' ); |
| 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' ); |
| 73 | ok( -s $afile > 20, ' -s' ); |
| 74 | |
| 75 | unlink($afile); |
| 76 | } |
| 77 | { |
| 78 | ok( open(my $f, '-|', <<EOC), 'open -|' ); |
| 79 | $Perl -e "print qq(a row\\n); print qq(another row\\n)" |
| 80 | EOC |
| 81 | |
| 82 | my @rows = <$f>; |
| 83 | is( scalar @rows, 2, ' readline, list context' ); |
| 84 | ok( close($f), ' close' ); |
| 85 | } |
| 86 | { |
| 87 | ok( open(my $f, '|-', <<EOC), 'open |-' ); |
| 88 | $Perl -pe "s/^not //" |
| 89 | EOC |
| 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' ); |
| 100 | sleep 1; |
| 101 | pass('flushing'); |
| 102 | } |
| 103 | |
| 104 | |
| 105 | ok( !eval { open my $f, '<&', $afile; 1; }, '<& on a non-filehandle' ); |
| 106 | like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); |
| 107 | |
| 108 | ok( !eval { *some_glob = 1; open my $f, '<&', *some_glob; 1; }, '<& on a non-filehandle glob' ); |
| 109 | like( $@, qr/Bad filehandle:\s+some_glob/, ' right error' ); |
| 110 | |
| 111 | { |
| 112 | use utf8; |
| 113 | use open qw( :utf8 :std ); |
| 114 | ok( !eval { use utf8; *ǡfilḛ = 1; open my $f, '<&', *ǡfilḛ; 1; }, '<& on a non-filehandle glob' ); |
| 115 | like( $@, qr/Bad filehandle:\s+ǡfilḛ/u, ' right error' ); |
| 116 | } |
| 117 | |
| 118 | # local $file tests |
| 119 | { |
| 120 | unlink($afile) if -f $afile; |
| 121 | |
| 122 | ok( open(local $f,"+>$afile"), 'open local $f, "+>", ...' ); |
| 123 | binmode $f; |
| 124 | |
| 125 | ok( -f $afile, ' -f' ); |
| 126 | ok( (print $f "SomeData\n"), ' print' ); |
| 127 | is( tell($f), 9, ' tell' ); |
| 128 | ok( seek($f,0,0), ' seek set' ); |
| 129 | |
| 130 | $b = <$f>; |
| 131 | is( $b, "SomeData\n", ' readline' ); |
| 132 | ok( -f $f, ' still a file' ); |
| 133 | |
| 134 | eval { die "Message" }; |
| 135 | like( $@, qr/<\$f> line 1/, ' proper die message' ); |
| 136 | ok( close($f), ' close' ); |
| 137 | |
| 138 | unlink($afile); |
| 139 | } |
| 140 | |
| 141 | { |
| 142 | ok( open(local $f,'>', $afile), 'open local $f, ">", ...' ); |
| 143 | ok( (print $f "a row\n"), ' print'); |
| 144 | ok( close($f), ' close'); |
| 145 | ok( -s $afile < 10, ' -s' ); |
| 146 | } |
| 147 | |
| 148 | { |
| 149 | ok( open(local $f,'>>', $afile), 'open local $f, ">>", ...' ); |
| 150 | ok( (print $f "a row\n"), ' print'); |
| 151 | ok( close($f), ' close'); |
| 152 | ok( -s $afile > 10, ' -s' ); |
| 153 | } |
| 154 | |
| 155 | { |
| 156 | ok( open(local $f, '<', $afile), 'open local $f, "<", ...' ); |
| 157 | my @rows = <$f>; |
| 158 | is( scalar @rows, 2, ' readline list context' ); |
| 159 | ok( close($f), ' close' ); |
| 160 | } |
| 161 | |
| 162 | ok( -s $afile < 20, ' -s' ); |
| 163 | |
| 164 | { |
| 165 | ok( open(local $f, '+<', $afile), 'open local $f, "+<", ...' ); |
| 166 | my @rows = <$f>; |
| 167 | is( scalar @rows, 2, ' readline list context' ); |
| 168 | ok( seek($f, 0, 1), ' seek cur' ); |
| 169 | ok( (print $f "yet another row\n"), ' print' ); |
| 170 | ok( close($f), ' close' ); |
| 171 | ok( -s $afile > 20, ' -s' ); |
| 172 | |
| 173 | unlink($afile); |
| 174 | } |
| 175 | |
| 176 | { |
| 177 | ok( open(local $f, '-|', <<EOC), 'open local $f, "-|", ...' ); |
| 178 | $Perl -e "print qq(a row\\n); print qq(another row\\n)" |
| 179 | EOC |
| 180 | my @rows = <$f>; |
| 181 | |
| 182 | is( scalar @rows, 2, ' readline list context' ); |
| 183 | ok( close($f), ' close' ); |
| 184 | } |
| 185 | |
| 186 | { |
| 187 | ok( open(local $f, '|-', <<EOC), 'open local $f, "|-", ...' ); |
| 188 | $Perl -pe "s/^not //" |
| 189 | EOC |
| 190 | |
| 191 | my @rows = <$f>; |
| 192 | my $test = curr_test; |
| 193 | print $f "not ok $test - piping\n"; |
| 194 | next_test; |
| 195 | |
| 196 | $test = curr_test; |
| 197 | print $f "not ok $test - piping\n"; |
| 198 | next_test; |
| 199 | ok( close($f), ' close' ); |
| 200 | sleep 1; |
| 201 | pass("Flush"); |
| 202 | } |
| 203 | |
| 204 | |
| 205 | ok( !eval { open local $f, '<&', $afile; 1 }, 'local <& on non-filehandle'); |
| 206 | like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); |
| 207 | |
| 208 | { |
| 209 | local *F; |
| 210 | for (1..2) { |
| 211 | ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' ); |
| 212 | is(scalar <F>, "ok\n", ' readline'); |
| 213 | ok( close F, ' close' ); |
| 214 | } |
| 215 | |
| 216 | for (1..2) { |
| 217 | ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|'); |
| 218 | is( scalar <F>, "ok\n", ' readline'); |
| 219 | ok( close F, ' close' ); |
| 220 | } |
| 221 | } |
| 222 | |
| 223 | |
| 224 | # other dupping techniques |
| 225 | { |
| 226 | ok( open(my $stdout, ">&", \*STDOUT), 'dup \*STDOUT into lexical fh'); |
| 227 | ok( open(STDOUT, ">&", $stdout), 'restore dupped STDOUT from lexical fh'); |
| 228 | |
| 229 | { |
| 230 | use strict; # the below should not warn |
| 231 | ok( open(my $stdout, ">&", STDOUT), 'dup STDOUT into lexical fh'); |
| 232 | } |
| 233 | |
| 234 | # used to try to open a file [perl #17830] |
| 235 | ok( open(my $stdin, "<&", fileno STDIN), 'dup fileno(STDIN) into lexical fh') or _diag $!; |
| 236 | |
| 237 | fileno(STDIN) =~ /(.)/; |
| 238 | ok open($stdin, "<&", $1), 'open ... "<&", $magical_fileno', |
| 239 | || _diag $!; |
| 240 | } |
| 241 | |
| 242 | SKIP: { |
| 243 | skip "This perl uses perlio", 1 if $Config{useperlio}; |
| 244 | skip_if_miniperl("miniperl can't rely on loading %Errno", 1); |
| 245 | # Force the reference to %! to be run time by writing ! as {"!"} |
| 246 | skip "This system doesn't understand EINVAL", 1 |
| 247 | unless exists ${"!"}{EINVAL}; |
| 248 | |
| 249 | no warnings 'io'; |
| 250 | ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL'); |
| 251 | } |
| 252 | |
| 253 | { |
| 254 | ok( !eval { open F, "BAR", "QUUX" }, 'Unknown open() mode' ); |
| 255 | like( $@, qr/\QUnknown open() mode 'BAR'/, ' right error' ); |
| 256 | } |
| 257 | |
| 258 | { |
| 259 | local $SIG{__WARN__} = sub { $@ = shift }; |
| 260 | |
| 261 | sub gimme { |
| 262 | my $tmphandle = shift; |
| 263 | my $line = scalar <$tmphandle>; |
| 264 | warn "gimme"; |
| 265 | return $line; |
| 266 | } |
| 267 | |
| 268 | open($fh0[0], "TEST"); |
| 269 | gimme($fh0[0]); |
| 270 | like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem"); |
| 271 | |
| 272 | open($fh1{k}, "TEST"); |
| 273 | gimme($fh1{k}); |
| 274 | like($@, qr/<\$fh1\{...}> line 1\./, "autoviv fh package helem"); |
| 275 | |
| 276 | my @fh2; |
| 277 | open($fh2[0], "TEST"); |
| 278 | gimme($fh2[0]); |
| 279 | like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem"); |
| 280 | |
| 281 | my %fh3; |
| 282 | open($fh3{k}, "TEST"); |
| 283 | gimme($fh3{k}); |
| 284 | like($@, qr/<\$fh3\{...}> line 1\./, "autoviv fh lexical helem"); |
| 285 | |
| 286 | local $/ = *F; # used to cause an assertion failure |
| 287 | gimme($fh3{k}); |
| 288 | like($@, qr/<\$fh3\{...}> chunk 2\./, |
| 289 | '<...> line 1 when $/ is set to a glob'); |
| 290 | } |
| 291 | |
| 292 | SKIP: { |
| 293 | skip("These tests use perlio", 5) unless $Config{useperlio}; |
| 294 | my $w; |
| 295 | use warnings 'layer'; |
| 296 | local $SIG{__WARN__} = sub { $w = shift }; |
| 297 | |
| 298 | eval { open(F, ">>>", $afile) }; |
| 299 | like($w, qr/Invalid separator character '>' in PerlIO layer spec/, |
| 300 | "bad open (>>>) warning"); |
| 301 | like($@, qr/Unknown open\(\) mode '>>>'/, |
| 302 | "bad open (>>>) failure"); |
| 303 | |
| 304 | eval { open(F, ">:u", $afile ) }; |
| 305 | like($w, qr/Unknown PerlIO layer "u"/, |
| 306 | 'bad layer ">:u" warning'); |
| 307 | eval { open(F, "<:u", $afile ) }; |
| 308 | like($w, qr/Unknown PerlIO layer "u"/, |
| 309 | 'bad layer "<:u" warning'); |
| 310 | eval { open(F, ":c", $afile ) }; |
| 311 | like($@, qr/Unknown open\(\) mode ':c'/, |
| 312 | 'bad layer ":c" failure'); |
| 313 | } |
| 314 | |
| 315 | # [perl #28986] "open m" crashes Perl |
| 316 | |
| 317 | fresh_perl_like('open m', qr/^Search pattern not terminated at/, |
| 318 | { stderr => 1 }, 'open m test'); |
| 319 | |
| 320 | fresh_perl_is( |
| 321 | 'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"', |
| 322 | 'ok', { stderr => 1 }, |
| 323 | '#29102: Crash on assignment to lexical filehandle'); |
| 324 | |
| 325 | # [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise |
| 326 | # an exception |
| 327 | |
| 328 | eval { open $99, "foo" }; |
| 329 | like($@, qr/Modification of a read-only value attempted/, "readonly fh"); |
| 330 | # But we do not want that exception applying to close(), since it does not |
| 331 | # modify the fh. |
| 332 | eval { |
| 333 | no warnings "uninitialized"; |
| 334 | # make sure $+ is undefined |
| 335 | "a" =~ /(b)?/; |
| 336 | close $+ |
| 337 | }; |
| 338 | is($@, '', 'no "Modification of a read-only value" when closing'); |
| 339 | |
| 340 | # [perl#73626] mg_get wasn't run on the pipe arg |
| 341 | |
| 342 | { |
| 343 | package p73626; |
| 344 | sub TIESCALAR { bless {} } |
| 345 | sub FETCH { "$Perl -e 1"} |
| 346 | |
| 347 | tie my $p, 'p73626'; |
| 348 | |
| 349 | package main; |
| 350 | |
| 351 | ok( open(my $f, '-|', $p), 'open -| magic'); |
| 352 | } |
| 353 | |
| 354 | # [perl #77492] Crash when stringifying a glob, a reference to which has |
| 355 | # been opened and written to. |
| 356 | fresh_perl_is( |
| 357 | ' |
| 358 | open my $fh, ">", \*STDOUT; |
| 359 | print $fh "hello"; |
| 360 | "".*STDOUT; |
| 361 | print "ok"; |
| 362 | close $fh; |
| 363 | unlink \*STDOUT; |
| 364 | ', |
| 365 | 'ok', { stderr => 1 }, |
| 366 | '[perl #77492]: open $fh, ">", \*glob causes SEGV'); |
| 367 | |
| 368 | # [perl #77684] Opening a reference to a glob copy. |
| 369 | SKIP: { |
| 370 | skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1); |
| 371 | my $var = *STDOUT; |
| 372 | open my $fh, ">", \$var; |
| 373 | print $fh "hello"; |
| 374 | is $var, "hello", '[perl #77684]: open $fh, ">", \$glob_copy' |
| 375 | # when this fails, it leaves an extra file: |
| 376 | or unlink \*STDOUT; |
| 377 | } |
| 378 | |
| 379 | # check that we can call methods on filehandles auto-magically |
| 380 | # and have IO::File loaded for us |
| 381 | SKIP: { |
| 382 | skip_if_miniperl("no dynamic loading on miniperl, so can't load IO::File", 3); |
| 383 | is( $INC{'IO/File.pm'}, undef, "IO::File not loaded" ); |
| 384 | my $var = ""; |
| 385 | open my $fh, ">", \$var; |
| 386 | ok( eval { $fh->autoflush(1); 1 }, '$fh->autoflush(1) lives' ); |
| 387 | ok( $INC{'IO/File.pm'}, "IO::File now loaded" ); |
| 388 | } |
| 389 | |
| 390 | sub _117941 { package _117941; open my $a, "TEST" } |
| 391 | delete $::{"_117941::"}; |
| 392 | _117941(); |
| 393 | pass("no crash when open autovivifies glob in freed package"); |