t/io/open.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc('../lib');
   7 }
   8
   9 $|  = 1;
  10 use warnings;
  11 use Config;
  12
  13 plan tests => 187;
  14
  15 sub 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
  25 my $Perl = which_perl();
  26
  27 my $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)"
  95 EOC
  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 //"
 105 EOC
 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
 122 ok( !eval { open my $f, '<&', $afile; 1; },    '<& on a non-filehandle' );
 123 like( $@, qr/Bad filehandle:\s+$afile/,          '       right error' );
 124
 125 ok( !eval { *some_glob = 1; open my $f, '<&', *some_glob; 1; },    '<& on a non-filehandle glob' );
 126 like( $@, 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
 183 ok( -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)"
 201 EOC
 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 //"
 212 EOC
 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
 229 ok( !eval { open local $f, '<&', $afile; 1 },  'local <& on non-filehandle');
 230 like( $@, 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
 272 SKIP: {
 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
 326 SKIP: {
 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
 351 fresh_perl_like('open m', qr/^Search pattern not terminated at/,
 352         { stderr => 1 }, 'open m test');
 353
 354 fresh_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
 362 eval { open $99, "foo" };
 363 like($@, 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.
 366 eval {
 367    no warnings "uninitialized";
 368    # make sure $+ is undefined
 369    "a" =~ /(b)?/;
 370    close $+
 371 };
 372 is($@, '', '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.
 390 fresh_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.
 403 SKIP: {
 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
 415 SKIP: {
 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
 424 sub _117941 { package _117941; open my $a, "TEST" }
 425 delete $::{"_117941::"};
 426 _117941();
 427 pass("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
 528 SKIP: {
 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     my($a, $b, $s, $t);
 533     $s = "";
 534     open($a, ">:scalar:perlio", \$s) or die;
 535     print {$a} "abc";
 536     is $s, "", "buffering delays writing to scalar (simple open)";
 537     $a = undef;
 538     is $s, "abc", "buffered write happens on dropping handle ref (simple open)";
 539     $t = "";
 540     open(${\$b}, ">:scalar:perlio", \$t) or die;
 541     print {$b} "xyz";
 542     is $t, "", "buffering delays writing to scalar (complex open)";
 543     $b = undef;
 544     is $t, "xyz", "buffered write happens on dropping handle ref (complex open)";
 545     is scalar(grep { /\A_GEN_/ } keys %::), 0, "no gensym appeared in stash";
 546 }