t/io/open.t

   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; *ǡﬁ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
 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");