1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7} 8 9$| = 1; 10use warnings; 11use Config; 12 13plan tests => 188; 14 15sub ok_cloexec { 16 SKIP: { 17 skip "no fcntl", 1 unless $Config{d_fcntl}; 18 my $fd = fileno($_[0]); 19 fresh_perl_is(qq( 20 print open(F, "+<&=$fd") ? 1 : 0, "\\n"; 21 ), "0\n", {}, "not inherited across exec"); 22 } 23} 24 25my $Perl = which_perl(); 26 27my $afile = tempfile(); 28{ 29 unlink($afile) if -f $afile; 30 31 $! = 0; # the -f above will set $! if $afile doesn't exist. 32 ok( open(my $f,"+>$afile"), 'open(my $f, "+>...")' ); 33 ok_cloexec($f); 34 35 binmode $f; 36 ok( -f $afile, ' its a file'); 37 ok( (print $f "SomeData\n"), ' we can print to it'); 38 is( tell($f), 9, ' tell()' ); 39 ok( seek($f,0,0), ' seek set' ); 40 41 $b = <$f>; 42 is( $b, "SomeData\n", ' readline' ); 43 ok( -f $f, ' still a file' ); 44 45 eval { die "Message" }; 46 like( $@, qr/<\$f> line 1/, ' die message correct' ); 47 48 ok( close($f), ' close()' ); 49 ok( unlink($afile), ' unlink()' ); 50} 51 52{ 53 ok( open(my $f,'>', $afile), "open(my \$f, '>', $afile)" ); 54 ok_cloexec($f); 55 ok( (print $f "a row\n"), ' print'); 56 ok( close($f), ' close' ); 57 ok( -s $afile < 10, ' -s' ); 58} 59 60{ 61 ok( open(my $f,'>>', $afile), "open(my \$f, '>>', $afile)" ); 62 ok_cloexec($f); 63 ok( (print $f "a row\n"), ' print' ); 64 ok( close($f), ' close' ); 65 ok( -s $afile > 10, ' -s' ); 66} 67 68{ 69 ok( open(my $f, '<', $afile), "open(my \$f, '<', $afile)" ); 70 ok_cloexec($f); 71 my @rows = <$f>; 72 is( scalar @rows, 2, ' readline, list context' ); 73 is( $rows[0], "a row\n", ' first line read' ); 74 is( $rows[1], "a row\n", ' second line' ); 75 ok( close($f), ' close' ); 76} 77 78{ 79 ok( -s $afile < 20, '-s' ); 80 81 ok( open(my $f, '+<', $afile), 'open +<' ); 82 ok_cloexec($f); 83 my @rows = <$f>; 84 is( scalar @rows, 2, ' readline, list context' ); 85 ok( seek($f, 0, 1), ' seek cur' ); 86 ok( (print $f "yet another row\n"), ' print' ); 87 ok( close($f), ' close' ); 88 ok( -s $afile > 20, ' -s' ); 89 90 unlink($afile); 91} 92{ 93 ok( open(my $f, '-|', <<EOC), 'open -|' ); 94 $Perl -e "print qq(a row\\n); print qq(another row\\n)" 95EOC 96 97 ok_cloexec($f); 98 my @rows = <$f>; 99 is( scalar @rows, 2, ' readline, list context' ); 100 ok( close($f), ' close' ); 101} 102{ 103 ok( open(my $f, '|-', <<EOC), 'open |-' ); 104 $Perl -pe "s/^not //" 105EOC 106 107 ok_cloexec($f); 108 my @rows = <$f>; 109 my $test = curr_test; 110 print $f "not ok $test - piped in\n"; 111 next_test; 112 113 $test = curr_test; 114 print $f "not ok $test - piped in\n"; 115 next_test; 116 ok( close($f), ' close' ); 117 sleep 1; 118 pass('flushing'); 119} 120 121 122ok( !eval { open my $f, '<&', $afile; 1; }, '<& on a non-filehandle' ); 123like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); 124 125ok( !eval { *some_glob = 1; open my $f, '<&', *some_glob; 1; }, '<& on a non-filehandle glob' ); 126like( $@, qr/Bad filehandle:\s+some_glob/, ' right error' ); 127 128{ 129 use utf8; 130 use open qw( :utf8 :std ); 131 ok( !eval { use utf8; *�����l��� = 1; open my $f, '<&', *�����l���; 1; }, '<& on a non-filehandle glob' ); 132 like( $@, qr/Bad filehandle:\s+�����l���/u, ' right error' ); 133} 134 135# local $file tests 136{ 137 unlink($afile) if -f $afile; 138 139 ok( open(local $f,"+>$afile"), 'open local $f, "+>", ...' ); 140 ok_cloexec($f); 141 binmode $f; 142 143 ok( -f $afile, ' -f' ); 144 ok( (print $f "SomeData\n"), ' print' ); 145 is( tell($f), 9, ' tell' ); 146 ok( seek($f,0,0), ' seek set' ); 147 148 $b = <$f>; 149 is( $b, "SomeData\n", ' readline' ); 150 ok( -f $f, ' still a file' ); 151 152 eval { die "Message" }; 153 like( $@, qr/<\$f> line 1/, ' proper die message' ); 154 ok( close($f), ' close' ); 155 156 unlink($afile); 157} 158 159{ 160 ok( open(local $f,'>', $afile), 'open local $f, ">", ...' ); 161 ok_cloexec($f); 162 ok( (print $f "a row\n"), ' print'); 163 ok( close($f), ' close'); 164 ok( -s $afile < 10, ' -s' ); 165} 166 167{ 168 ok( open(local $f,'>>', $afile), 'open local $f, ">>", ...' ); 169 ok_cloexec($f); 170 ok( (print $f "a row\n"), ' print'); 171 ok( close($f), ' close'); 172 ok( -s $afile > 10, ' -s' ); 173} 174 175{ 176 ok( open(local $f, '<', $afile), 'open local $f, "<", ...' ); 177 ok_cloexec($f); 178 my @rows = <$f>; 179 is( scalar @rows, 2, ' readline list context' ); 180 ok( close($f), ' close' ); 181} 182 183ok( -s $afile < 20, ' -s' ); 184 185{ 186 ok( open(local $f, '+<', $afile), 'open local $f, "+<", ...' ); 187 ok_cloexec($f); 188 my @rows = <$f>; 189 is( scalar @rows, 2, ' readline list context' ); 190 ok( seek($f, 0, 1), ' seek cur' ); 191 ok( (print $f "yet another row\n"), ' print' ); 192 ok( close($f), ' close' ); 193 ok( -s $afile > 20, ' -s' ); 194 195 unlink($afile); 196} 197 198{ 199 ok( open(local $f, '-|', <<EOC), 'open local $f, "-|", ...' ); 200 $Perl -e "print qq(a row\\n); print qq(another row\\n)" 201EOC 202 ok_cloexec($f); 203 my @rows = <$f>; 204 205 is( scalar @rows, 2, ' readline list context' ); 206 ok( close($f), ' close' ); 207} 208 209{ 210 ok( open(local $f, '|-', <<EOC), 'open local $f, "|-", ...' ); 211 $Perl -pe "s/^not //" 212EOC 213 214 ok_cloexec($f); 215 my @rows = <$f>; 216 my $test = curr_test; 217 print $f "not ok $test - piping\n"; 218 next_test; 219 220 $test = curr_test; 221 print $f "not ok $test - piping\n"; 222 next_test; 223 ok( close($f), ' close' ); 224 sleep 1; 225 pass("Flush"); 226} 227 228 229ok( !eval { open local $f, '<&', $afile; 1 }, 'local <& on non-filehandle'); 230like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); 231 232{ 233 local *F; 234 for (1..2) { 235 ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' ); 236 ok_cloexec(\*F); 237 is(scalar <F>, "ok\n", ' readline'); 238 ok( close F, ' close' ); 239 } 240 241 for (1..2) { 242 ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|'); 243 ok_cloexec(\*F); 244 is( scalar <F>, "ok\n", ' readline'); 245 ok( close F, ' close' ); 246 } 247} 248 249 250# other dupping techniques 251{ 252 ok( open(my $stdout, ">&", \*STDOUT), 'dup \*STDOUT into lexical fh'); 253 ok_cloexec($stdout); 254 ok( open(STDOUT, ">&", $stdout), 'restore dupped STDOUT from lexical fh'); 255 256 { 257 use strict; # the below should not warn 258 ok( open(my $stdout, ">&", STDOUT), 'dup STDOUT into lexical fh'); 259 ok_cloexec($stdout); 260 } 261 262 # used to try to open a file [perl #17830] 263 ok( open(my $stdin, "<&", fileno STDIN), 'dup fileno(STDIN) into lexical fh') or _diag $!; 264 ok_cloexec($stdin); 265 266 fileno(STDIN) =~ /(.)/; 267 ok open($stdin, "<&", $1), 'open ... "<&", $magical_fileno', 268 || _diag $!; 269 ok_cloexec($stdin); 270} 271 272SKIP: { 273 skip "This perl uses perlio", 1 if $Config{useperlio}; 274 skip_if_miniperl("miniperl can't rely on loading %Errno", 1); 275 # Force the reference to %! to be run time by writing ! as {"!"} 276 skip "This system doesn't understand EINVAL", 1 277 unless exists ${"!"}{EINVAL}; 278 279 no warnings 'io'; 280 ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL'); 281} 282 283{ 284 ok( !eval { open F, "BAR", "QUUX" }, 'Unknown open() mode' ); 285 like( $@, qr/\QUnknown open() mode 'BAR'/, ' right error' ); 286} 287 288{ 289 local $SIG{__WARN__} = sub { $@ = shift }; 290 291 sub gimme { 292 my $tmphandle = shift; 293 my $line = scalar <$tmphandle>; 294 warn "gimme"; 295 return $line; 296 } 297 298 open($fh0[0], "TEST"); 299 ok_cloexec($fh0[0]); 300 gimme($fh0[0]); 301 like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem"); 302 303 open($fh1{k}, "TEST"); 304 ok_cloexec($fh1{h}); 305 gimme($fh1{k}); 306 like($@, qr/<\$fh1\{...}> line 1\./, "autoviv fh package helem"); 307 308 my @fh2; 309 open($fh2[0], "TEST"); 310 ok_cloexec($fh2[0]); 311 gimme($fh2[0]); 312 like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem"); 313 314 my %fh3; 315 open($fh3{k}, "TEST"); 316 ok_cloexec($fh3{h}); 317 gimme($fh3{k}); 318 like($@, qr/<\$fh3\{...}> line 1\./, "autoviv fh lexical helem"); 319 320 local $/ = *F; # used to cause an assertion failure 321 gimme($fh3{k}); 322 like($@, qr/<\$fh3\{...}> chunk 2\./, 323 '<...> line 1 when $/ is set to a glob'); 324} 325 326SKIP: { 327 skip("These tests use perlio", 5) unless $Config{useperlio}; 328 my $w; 329 use warnings 'layer'; 330 local $SIG{__WARN__} = sub { $w = shift }; 331 332 eval { open(F, ">>>", $afile) }; 333 like($w, qr/Invalid separator character '>' in PerlIO layer spec/, 334 "bad open (>>>) warning"); 335 like($@, qr/Unknown open\(\) mode '>>>'/, 336 "bad open (>>>) failure"); 337 338 eval { open(F, ">:u", $afile ) }; 339 like($w, qr/Unknown PerlIO layer "u"/, 340 'bad layer ">:u" warning'); 341 eval { open(F, "<:u", $afile ) }; 342 like($w, qr/Unknown PerlIO layer "u"/, 343 'bad layer "<:u" warning'); 344 eval { open(F, ":c", $afile ) }; 345 like($@, qr/Unknown open\(\) mode ':c'/, 346 'bad layer ":c" failure'); 347} 348 349# [perl #28986] "open m" crashes Perl 350 351fresh_perl_like('open m', qr/^Search pattern not terminated at/, 352 { stderr => 1 }, 'open m test'); 353 354fresh_perl_is( 355 'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"', 356 'ok', { stderr => 1 }, 357 '#29102: Crash on assignment to lexical filehandle'); 358 359# [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise 360# an exception 361 362eval { open $99, "foo" }; 363like($@, qr/Modification of a read-only value attempted/, "readonly fh"); 364# But we do not want that exception applying to close(), since it does not 365# modify the fh. 366eval { 367 no warnings "uninitialized"; 368 # make sure $+ is undefined 369 "a" =~ /(b)?/; 370 close $+ 371}; 372is($@, '', 'no "Modification of a read-only value" when closing'); 373 374# [perl#73626] mg_get wasn't run on the pipe arg 375 376{ 377 package p73626; 378 sub TIESCALAR { bless {} } 379 sub FETCH { "$Perl -e 1"} 380 381 tie my $p, 'p73626'; 382 383 package main; 384 385 ok( open(my $f, '-|', $p), 'open -| magic'); 386} 387 388# [perl #77492] Crash when stringifying a glob, a reference to which has 389# been opened and written to. 390fresh_perl_is( 391 ' 392 open my $fh, ">", \*STDOUT; 393 print $fh "hello"; 394 "".*STDOUT; 395 print "ok"; 396 close $fh; 397 unlink \*STDOUT; 398 ', 399 'ok', { stderr => 1 }, 400 '[perl #77492]: open $fh, ">", \*glob causes SEGV'); 401 402# [perl #77684] Opening a reference to a glob copy. 403SKIP: { 404 skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1); 405 my $var = *STDOUT; 406 open my $fh, ">", \$var; 407 print $fh "hello"; 408 is $var, "hello", '[perl #77684]: open $fh, ">", \$glob_copy' 409 # when this fails, it leaves an extra file: 410 or unlink \*STDOUT; 411} 412 413# check that we can call methods on filehandles auto-magically 414# and have IO::File loaded for us 415SKIP: { 416 skip_if_miniperl("no dynamic loading on miniperl, so can't load IO::File", 3); 417 is( $INC{'IO/File.pm'}, undef, "IO::File not loaded" ); 418 my $var = ""; 419 open my $fh, ">", \$var; 420 ok( eval { $fh->autoflush(1); 1 }, '$fh->autoflush(1) lives' ); 421 ok( $INC{'IO/File.pm'}, "IO::File now loaded" ); 422} 423 424sub _117941 { package _117941; open my $a, "TEST" } 425delete $::{"_117941::"}; 426_117941(); 427pass("no crash when open autovivifies glob in freed package"); 428 429# [perl #117265] check for embedded nul in pathnames, allow ending \0 though 430{ 431 my $WARN; 432 local $SIG{__WARN__} = sub { $WARN = shift }; 433 my $temp = tempfile(); 434 my $temp_match = quotemeta $temp; 435 436 # create the file, so we can check nothing actually touched it 437 open my $temp_fh, ">", $temp; 438 close $temp_fh; 439 ok(utime(time()-10, time(), $temp), "set mtime to a known value"); 440 ok(chmod(0666, $temp), "set mode to a known value"); 441 my ($final_mode, $final_mtime) = (stat $temp)[2, 9]; 442 443 my $fn = "$temp\0.invalid"; 444 my $fno = bless \(my $fn2 = "$temp\0.overload"), "OverloadTest"; 445 is(open(I, $fn), undef, "open with nul in pathnames since 5.18 [perl #117265]"); 446 like($WARN, qr/^Invalid \\0 character in pathname for open: $temp_match\\0\.invalid/, 447 "warn on embedded nul"); $WARN = ''; 448 is(open(I, $fno), undef, "open with nul in pathnames since 5.18 [perl #117265] (overload)"); 449 like($WARN, qr/^Invalid \\0 character in pathname for open: $temp_match\\0\.overload/, 450 "warn on embedded nul"); $WARN = ''; 451 452 is(chmod(0444, $fn), 0, "chmod fails with \\0 in name"); 453 like($WARN, qr/^Invalid \\0 character in pathname for chmod: $temp_match\\0\.invalid/, 454 "also on chmod"); $WARN = ''; 455 456 is(chmod(0444, $fno), 0, "chmod fails with \\0 in name (overload)"); 457 like($WARN, qr/^Invalid \\0 character in pathname for chmod: $temp_match\\0\.overload/, 458 "also on chmod"); $WARN = ''; 459 460 is (glob($fn), undef, "glob fails with \\0 in name"); 461 like($WARN, qr/^Invalid \\0 character in pattern for glob: $temp_match\\0\.invalid/, 462 "also on glob"); $WARN = ''; 463 464 is (glob($fno), undef, "glob fails with \\0 in name (overload)"); 465 like($WARN, qr/^Invalid \\0 character in pattern for glob: $temp_match\\0\.overload/, 466 "also on glob"); $WARN = ''; 467 468 { 469 no warnings 'syscalls'; 470 $WARN = ''; 471 is(open(I, $fn), undef, "open with nul with no warnings syscalls"); 472 is($WARN, '', "ignore warning on embedded nul with no warnings syscalls"); 473 } 474 475 SKIP: { 476 if (is_miniperl && !eval 'require Errno') { 477 skip "Errno not built yet", 8; 478 } 479 require Errno; 480 import Errno 'ENOENT'; 481 # check handling of multiple arguments, which the original patch 482 # mis-handled 483 $! = 0; 484 is (unlink($fn, $fn), 0, "check multiple arguments to unlink"); 485 is($!+0, &ENOENT, "check errno"); 486 $! = 0; 487 is (chmod(0644, $fn, $fn), 0, "check multiple arguments to chmod"); 488 is($!+0, &ENOENT, "check errno"); 489 $! = 0; 490 is (utime(time, time, $fn, $fn), 0, "check multiple arguments to utime"); 491 is($!+0, &ENOENT, "check errno"); 492 SKIP: { 493 skip "no chown", 2 unless $Config{d_chown}; 494 $! = 0; 495 is(chown(-1, -1, $fn, $fn), 0, "check multiple arguments to chown"); 496 is($!+0, &ENOENT, "check errno"); 497 } 498 } 499 500 is (unlink($fn), 0, "unlink fails with \\0 in name"); 501 like($WARN, qr/^Invalid \\0 character in pathname for unlink: $temp_match\\0\.invalid/, 502 "also on unlink"); $WARN = ''; 503 504 is (unlink($fno), 0, "unlink fails with \\0 in name (overload)"); 505 like($WARN, qr/^Invalid \\0 character in pathname for unlink: $temp_match\\0\.overload/, 506 "also on unlink"); $WARN = ''; 507 508 ok(-f $temp, "nothing removed the temp file"); 509 is((stat $temp)[2], $final_mode, "nothing changed its mode"); 510 is((stat $temp)[9], $final_mtime, "nothing changes its mtime"); 511} 512 513# [perl #125115] Dup to closed filehandle creates file named GLOB(0x...) 514{ 515 ok(open(my $fh, "<", "TEST"), "open a handle"); 516 ok(close $fh, "and close it again"); 517 ok(!open(my $fh2, ">&", $fh), "should fail to dup the closed handle"); 518 # clean up if we failed 519 unlink "$fh"; 520} 521 522{ 523 package OverloadTest; 524 use overload '""' => sub { ${$_[0]} }; 525} 526 527# [perl #115814] open(${\$x}, ...) creates spurious reference to handle in stash 528SKIP: { 529 # The bug doesn't depend on perlio, but perlio provides this nice 530 # way of discerning when a handle actually closes. 531 skip("These tests use perlio", 5) unless $Config{useperlio}; 532 skip_if_miniperl("miniperl can't load PerlIO::scalar", 5); 533 my($a, $b, $s, $t); 534 $s = ""; 535 open($a, ">:scalar:perlio", \$s) or die; 536 print {$a} "abc"; 537 is $s, "", "buffering delays writing to scalar (simple open)"; 538 $a = undef; 539 is $s, "abc", "buffered write happens on dropping handle ref (simple open)"; 540 $t = ""; 541 open(${\$b}, ">:scalar:perlio", \$t) or die; 542 print {$b} "xyz"; 543 is $t, "", "buffering delays writing to scalar (complex open)"; 544 $b = undef; 545 is $t, "xyz", "buffered write happens on dropping handle ref (complex open)"; 546 is scalar(grep { /\A_GEN_/ } keys %::), 0, "no gensym appeared in stash"; 547} 548 549# [perl #16113] returning handle in localised glob 550{ 551 my $tfile = tempfile(); 552 open(my $twrite, ">", $tfile) or die $!; 553 print {$twrite} "foo\nbar\n" or die $!; 554 close $twrite or die $!; 555 $twrite = undef; 556 my $tread = do { 557 local *F; 558 open(F, "<", $tfile) or die $!; 559 *F; 560 }; 561 is scalar(<$tread>), "foo\n", "IO handle returned in localised glob"; 562 close $tread; 563} 564