open.t revision 1.14
1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9$| = 1; 10use warnings; 11use Config; 12 13plan tests => 153; 14 15my $Perl = which_perl(); 16 17my $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)" 80EOC 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 //" 89EOC 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 105ok( !eval { open my $f, '<&', $afile; 1; }, '<& on a non-filehandle' ); 106like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); 107 108ok( !eval { *some_glob = 1; open my $f, '<&', *some_glob; 1; }, '<& on a non-filehandle glob' ); 109like( $@, qr/Bad filehandle:\s+some_glob/, ' right error' ); 110 111{ 112 use utf8; 113 use open qw( :utf8 :std ); 114 ok( !eval { use utf8; *�����l��� = 1; open my $f, '<&', *�����l���; 1; }, '<& on a non-filehandle glob' ); 115 like( $@, qr/Bad filehandle:\s+�����l���/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 162ok( -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)" 179EOC 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 //" 189EOC 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 205ok( !eval { open local $f, '<&', $afile; 1 }, 'local <& on non-filehandle'); 206like( $@, 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 242SKIP: { 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 292SKIP: { 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 317fresh_perl_like('open m', qr/^Search pattern not terminated at/, 318 { stderr => 1 }, 'open m test'); 319 320fresh_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 328eval { open $99, "foo" }; 329like($@, 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. 332eval { 333 no warnings "uninitialized"; 334 # make sure $+ is undefined 335 "a" =~ /(b)?/; 336 close $+ 337}; 338is($@, '', '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. 356fresh_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. 369SKIP: { 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 381SKIP: { 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 390sub _117941 { package _117941; open my $a, "TEST" } 391delete $::{"_117941::"}; 392_117941(); 393pass("no crash when open autovivifies glob in freed package"); 394 395# [perl #117265] check for embedded nul in pathnames, allow ending \0 though 396{ 397 my $WARN; 398 local $SIG{__WARN__} = sub { $WARN = shift }; 399 my $temp = tempfile(); 400 my $temp_match = quotemeta $temp; 401 402 # create the file, so we can check nothing actually touched it 403 open my $temp_fh, ">", $temp; 404 close $temp_fh; 405 ok(utime(time()-10, time(), $temp), "set mtime to a known value"); 406 ok(chmod(0666, $temp), "set mode to a known value"); 407 my ($final_mode, $final_mtime) = (stat $temp)[2, 9]; 408 409 my $fn = "$temp\0.invalid"; 410 my $fno = bless \(my $fn2 = "$temp\0.overload"), "OverloadTest"; 411 is(open(I, $fn), undef, "open with nul in pathnames since 5.18 [perl #117265]"); 412 like($WARN, qr/^Invalid \\0 character in pathname for open: $temp_match\\0\.invalid/, 413 "warn on embedded nul"); $WARN = ''; 414 is(open(I, $fno), undef, "open with nul in pathnames since 5.18 [perl #117265] (overload)"); 415 like($WARN, qr/^Invalid \\0 character in pathname for open: $temp_match\\0\.overload/, 416 "warn on embedded nul"); $WARN = ''; 417 418 is(chmod(0444, $fn), 0, "chmod fails with \\0 in name"); 419 like($WARN, qr/^Invalid \\0 character in pathname for chmod: $temp_match\\0\.invalid/, 420 "also on chmod"); $WARN = ''; 421 422 is(chmod(0444, $fno), 0, "chmod fails with \\0 in name (overload)"); 423 like($WARN, qr/^Invalid \\0 character in pathname for chmod: $temp_match\\0\.overload/, 424 "also on chmod"); $WARN = ''; 425 426 is (glob($fn), undef, "glob fails with \\0 in name"); 427 like($WARN, qr/^Invalid \\0 character in pattern for glob: $temp_match\\0\.invalid/, 428 "also on glob"); $WARN = ''; 429 430 is (glob($fno), undef, "glob fails with \\0 in name (overload)"); 431 like($WARN, qr/^Invalid \\0 character in pattern for glob: $temp_match\\0\.overload/, 432 "also on glob"); $WARN = ''; 433 434 { 435 no warnings 'syscalls'; 436 $WARN = ''; 437 is(open(I, $fn), undef, "open with nul with no warnings syscalls"); 438 is($WARN, '', "ignore warning on embedded nul with no warnings syscalls"); 439 } 440 441 use Errno 'ENOENT'; 442 # check handling of multiple arguments, which the original patch 443 # mis-handled 444 $! = 0; 445 is (unlink($fn, $fn), 0, "check multiple arguments to unlink"); 446 is($!+0, ENOENT, "check errno"); 447 $! = 0; 448 is (chmod(0644, $fn, $fn), 0, "check multiple arguments to chmod"); 449 is($!+0, ENOENT, "check errno"); 450 $! = 0; 451 is (utime(time, time, $fn, $fn), 0, "check multiple arguments to utime"); 452 is($!+0, ENOENT, "check errno"); 453 SKIP: { 454 skip "no chown", 2 unless $Config{d_chown}; 455 $! = 0; 456 is(chown(-1, -1, $fn, $fn), 0, "check multiple arguments to chown"); 457 is($!+0, ENOENT, "check errno"); 458 } 459 460 is (unlink($fn), 0, "unlink fails with \\0 in name"); 461 like($WARN, qr/^Invalid \\0 character in pathname for unlink: $temp_match\\0\.invalid/, 462 "also on unlink"); $WARN = ''; 463 464 is (unlink($fno), 0, "unlink fails with \\0 in name (overload)"); 465 like($WARN, qr/^Invalid \\0 character in pathname for unlink: $temp_match\\0\.overload/, 466 "also on unlink"); $WARN = ''; 467 468 ok(-f $temp, "nothing removed the temp file"); 469 is((stat $temp)[2], $final_mode, "nothing changed its mode"); 470 is((stat $temp)[9], $final_mtime, "nothing changes its mtime"); 471} 472 473 474package OverloadTest; 475use overload '""' => sub { ${$_[0]} }; 476