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 => 114;
  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
 109 # local $file tests
 110 {
 111     unlink($afile) if -f $afile;
 112
 113     ok( open(local $f,"+>$afile"),       'open local $f, "+>", ...' );
 114     binmode $f;
 115
 116     ok( -f $afile,                      '       -f' );
 117     ok( (print $f "SomeData\n"),        '       print' );
 118     is( tell($f), 9,                    '       tell' );
 119     ok( seek($f,0,0),                   '       seek set' );
 120
 121     $b = <$f>;
 122     is( $b, "SomeData\n",               '       readline' );
 123     ok( -f $f,                          '       still a file' );
 124
 125     eval  { die "Message" };
 126     like( $@, qr/<\$f> line 1/,         '       proper die message' );
 127     ok( close($f),                      '       close' );
 128
 129     unlink($afile);
 130 }
 131
 132 {
 133     ok( open(local $f,'>', $afile),     'open local $f, ">", ...' );
 134     ok( (print $f "a row\n"),           '       print');
 135     ok( close($f),                      '       close');
 136     ok( -s $afile < 10,                 '       -s' );
 137 }
 138
 139 {
 140     ok( open(local $f,'>>', $afile),    'open local $f, ">>", ...' );
 141     ok( (print $f "a row\n"),           '       print');
 142     ok( close($f),                      '       close');
 143     ok( -s $afile > 10,                 '       -s' );
 144 }
 145
 146 {
 147     ok( open(local $f, '<', $afile),    'open local $f, "<", ...' );
 148     my @rows = <$f>;
 149     is( scalar @rows, 2,                '       readline list context' );
 150     ok( close($f),                      '       close' );
 151 }
 152
 153 ok( -s $afile < 20,                     '       -s' );
 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( seek($f, 0, 1),                 '       seek cur' );
 160     ok( (print $f "yet another row\n"), '       print' );
 161     ok( close($f),                      '       close' );
 162     ok( -s $afile > 20,                 '       -s' );
 163
 164     unlink($afile);
 165 }
 166
 167 {
 168     ok( open(local $f, '-|', <<EOC),  'open local $f, "-|", ...' );
 169     $Perl -e "print qq(a row\\n); print qq(another row\\n)"
 170 EOC
 171     my @rows = <$f>;
 172
 173     is( scalar @rows, 2,                '       readline list context' );
 174     ok( close($f),                      '       close' );
 175 }
 176
 177 {
 178     ok( open(local $f, '|-', <<EOC),  'open local $f, "|-", ...' );
 179     $Perl -pe "s/^not //"
 180 EOC
 181
 182     my @rows = <$f>;
 183     my $test = curr_test;
 184     print $f "not ok $test - piping\n";
 185     next_test;
 186
 187     $test = curr_test;
 188     print $f "not ok $test - piping\n";
 189     next_test;
 190     ok( close($f),                      '       close' );
 191     sleep 1;
 192     pass("Flush");
 193 }
 194
 195
 196 ok( !eval { open local $f, '<&', $afile; 1 },  'local <& on non-filehandle');
 197 like( $@, qr/Bad filehandle:\s+$afile/,          '       right error' );
 198
 199 {
 200     local *F;
 201     for (1..2) {
 202         ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' );
 203         is(scalar <F>, "ok\n",  '       readline');
 204         ok( close F,            '       close' );
 205     }
 206
 207     for (1..2) {
 208         ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|');
 209         is( scalar <F>, "ok\n", '       readline');
 210         ok( close F,            '       close' );
 211     }
 212 }
 213
 214
 215 # other dupping techniques
 216 {
 217     ok( open(my $stdout, ">&", \*STDOUT),       'dup \*STDOUT into lexical fh');
 218     ok( open(STDOUT,     ">&", $stdout),        'restore dupped STDOUT from lexical fh');
 219
 220     {
 221         use strict; # the below should not warn
 222         ok( open(my $stdout, ">&", STDOUT),         'dup STDOUT into lexical fh');
 223     }
 224
 225     # used to try to open a file [perl #17830]
 226     ok( open(my $stdin,  "<&", fileno STDIN),   'dup fileno(STDIN) into lexical fh') or _diag $!;
 227 }
 228
 229 SKIP: {
 230     skip "This perl uses perlio", 1 if $Config{useperlio};
 231     skip "miniperl cannot be relied on to load %Errno"
 232         if $ENV{PERL_CORE_MINITEST};
 233     # Force the reference to %! to be run time by writing ! as {"!"}
 234     skip "This system doesn't understand EINVAL", 1
 235         unless exists ${"!"}{EINVAL};
 236
 237     no warnings 'io';
 238     ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL');
 239 }
 240
 241 {
 242     ok( !eval { open F, "BAR", "QUUX" },       'Unknown open() mode' );
 243     like( $@, qr/\QUnknown open() mode 'BAR'/, '       right error' );
 244 }
 245
 246 {
 247     local $SIG{__WARN__} = sub { $@ = shift };
 248
 249     sub gimme {
 250         my $tmphandle = shift;
 251         my $line = scalar <$tmphandle>;
 252         warn "gimme";
 253         return $line;
 254     }
 255
 256     open($fh0[0], "TEST");
 257     gimme($fh0[0]);
 258     like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem");
 259
 260     open($fh1{k}, "TEST");
 261     gimme($fh1{k});
 262     like($@, qr/<\$fh1{...}> line 1\./, "autoviv fh package helem");
 263
 264     my @fh2;
 265     open($fh2[0], "TEST");
 266     gimme($fh2[0]);
 267     like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem");
 268
 269     my %fh3;
 270     open($fh3{k}, "TEST");
 271     gimme($fh3{k});
 272     like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem");
 273 }
 274
 275 SKIP: {
 276     skip("These tests use perlio", 5) unless $Config{useperlio};
 277     my $w;
 278     use warnings 'layer';
 279     local $SIG{__WARN__} = sub { $w = shift };
 280
 281     eval { open(F, ">>>", $afile) };
 282     like($w, qr/Invalid separator character '>' in PerlIO layer spec/,
 283          "bad open (>>>) warning");
 284     like($@, qr/Unknown open\(\) mode '>>>'/,
 285          "bad open (>>>) failure");
 286
 287     eval { open(F, ">:u", $afile ) };
 288     like($w, qr/Unknown PerlIO layer "u"/,
 289          'bad layer ">:u" warning');
 290     eval { open(F, "<:u", $afile ) };
 291     like($w, qr/Unknown PerlIO layer "u"/,
 292          'bad layer "<:u" warning');
 293     eval { open(F, ":c", $afile ) };
 294     like($@, qr/Unknown open\(\) mode ':c'/,
 295          'bad layer ":c" failure');
 296 }
 297
 298 # [perl #28986] "open m" crashes Perl
 299
 300 fresh_perl_like('open m', qr/^Search pattern not terminated at/,
 301         { stderr => 1 }, 'open m test');
 302
 303 fresh_perl_is(
 304     'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"',
 305     'ok', { stderr => 1 },
 306     '#29102: Crash on assignment to lexical filehandle');
 307
 308 # [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise
 309 # an exception
 310
 311 eval { open $99, "foo" };
 312 like($@, qr/Modification of a read-only value attempted/, "readonly fh");
 313
 314 # [perl#73626] mg_get wasn't run on the pipe arg
 315
 316 {
 317     package p73626;
 318     sub TIESCALAR { bless {} }
 319     sub FETCH { "$Perl -e 1"}
 320
 321     tie my $p, 'p73626';
 322
 323     package main;
 324
 325     ok( open(my $f, '-|', $p),     'open -| magic');
 326 }
 327
 328 # [perl #77492] Crash when stringifying a glob, a reference to which has
 329 #               been opened and written to.
 330 fresh_perl_is(
 331     '
 332       open my $fh, ">", \*STDOUT;
 333       print $fh "hello";
 334      "".*STDOUT;
 335       print "ok";
 336       close $fh;
 337       unlink \*STDOUT;
 338     ',
 339     'ok', { stderr => 1 },
 340     '[perl #77492]: open $fh, ">", \*glob causes SEGV');
 341
 342 # [perl #77684] Opening a reference to a glob copy.
 343 {
 344     my $var = *STDOUT;
 345     open my $fh, ">", \$var;
 346     print $fh "hello";
 347     is $var, "hello", '[perl #77684]: open $fh, ">", \$glob_copy'
 348         # when this fails, it leaves an extra file:
 349         or unlink \*STDOUT;
 350 }
 351
 352 # check that we can call methods on filehandles auto-magically
 353 # and have IO::File loaded for us
 354 SKIP: {
 355     skip_if_miniperl("no dynamic loading on miniperl, so can't load IO::File", 3);
 356     is( $INC{'IO/File.pm'}, undef, "IO::File not loaded" );
 357     my $var = "";
 358     open my $fh, ">", \$var;
 359     ok( eval { $fh->autoflush(1); 1 }, '$fh->autoflush(1) lives' );
 360     ok( $INC{'IO/File.pm'}, "IO::File now loaded" );
 361 }