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 => 119;
  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
 238 SKIP: {
 239     skip "This perl uses perlio", 1 if $Config{useperlio};
 240     skip_if_miniperl("miniperl can't rely on loading %Errno", 1);
 241     # Force the reference to %! to be run time by writing ! as {"!"}
 242     skip "This system doesn't understand EINVAL", 1
 243         unless exists ${"!"}{EINVAL};
 244
 245     no warnings 'io';
 246     ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL');
 247 }
 248
 249 {
 250     ok( !eval { open F, "BAR", "QUUX" },       'Unknown open() mode' );
 251     like( $@, qr/\QUnknown open() mode 'BAR'/, '       right error' );
 252 }
 253
 254 {
 255     local $SIG{__WARN__} = sub { $@ = shift };
 256
 257     sub gimme {
 258         my $tmphandle = shift;
 259         my $line = scalar <$tmphandle>;
 260         warn "gimme";
 261         return $line;
 262     }
 263
 264     open($fh0[0], "TEST");
 265     gimme($fh0[0]);
 266     like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem");
 267
 268     open($fh1{k}, "TEST");
 269     gimme($fh1{k});
 270     like($@, qr/<\$fh1{...}> line 1\./, "autoviv fh package helem");
 271
 272     my @fh2;
 273     open($fh2[0], "TEST");
 274     gimme($fh2[0]);
 275     like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem");
 276
 277     my %fh3;
 278     open($fh3{k}, "TEST");
 279     gimme($fh3{k});
 280     like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem");
 281 }
 282
 283 SKIP: {
 284     skip("These tests use perlio", 5) unless $Config{useperlio};
 285     my $w;
 286     use warnings 'layer';
 287     local $SIG{__WARN__} = sub { $w = shift };
 288
 289     eval { open(F, ">>>", $afile) };
 290     like($w, qr/Invalid separator character '>' in PerlIO layer spec/,
 291          "bad open (>>>) warning");
 292     like($@, qr/Unknown open\(\) mode '>>>'/,
 293          "bad open (>>>) failure");
 294
 295     eval { open(F, ">:u", $afile ) };
 296     like($w, qr/Unknown PerlIO layer "u"/,
 297          'bad layer ">:u" warning');
 298     eval { open(F, "<:u", $afile ) };
 299     like($w, qr/Unknown PerlIO layer "u"/,
 300          'bad layer "<:u" warning');
 301     eval { open(F, ":c", $afile ) };
 302     like($@, qr/Unknown open\(\) mode ':c'/,
 303          'bad layer ":c" failure');
 304 }
 305
 306 # [perl #28986] "open m" crashes Perl
 307
 308 fresh_perl_like('open m', qr/^Search pattern not terminated at/,
 309         { stderr => 1 }, 'open m test');
 310
 311 fresh_perl_is(
 312     'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"',
 313     'ok', { stderr => 1 },
 314     '#29102: Crash on assignment to lexical filehandle');
 315
 316 # [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise
 317 # an exception
 318
 319 eval { open $99, "foo" };
 320 like($@, qr/Modification of a read-only value attempted/, "readonly fh");
 321 # But we do not want that exception applying to close(), since it does not
 322 # modify the fh.
 323 eval {
 324    no warnings "uninitialized";
 325    # make sure $+ is undefined
 326    "a" =~ /(b)?/;
 327    close $+
 328 };
 329 is($@, '', 'no "Modification of a read-only value" when closing');
 330
 331 # [perl#73626] mg_get wasn't run on the pipe arg
 332
 333 {
 334     package p73626;
 335     sub TIESCALAR { bless {} }
 336     sub FETCH { "$Perl -e 1"}
 337
 338     tie my $p, 'p73626';
 339
 340     package main;
 341
 342     ok( open(my $f, '-|', $p),     'open -| magic');
 343 }
 344
 345 # [perl #77492] Crash when stringifying a glob, a reference to which has
 346 #               been opened and written to.
 347 fresh_perl_is(
 348     '
 349       open my $fh, ">", \*STDOUT;
 350       print $fh "hello";
 351      "".*STDOUT;
 352       print "ok";
 353       close $fh;
 354       unlink \*STDOUT;
 355     ',
 356     'ok', { stderr => 1 },
 357     '[perl #77492]: open $fh, ">", \*glob causes SEGV');
 358
 359 # [perl #77684] Opening a reference to a glob copy.
 360 SKIP: {
 361     skip_if_miniperl("no dynamic loading on miniperl, so can't load PerlIO::scalar", 1);
 362     my $var = *STDOUT;
 363     open my $fh, ">", \$var;
 364     print $fh "hello";
 365     is $var, "hello", '[perl #77684]: open $fh, ">", \$glob_copy'
 366         # when this fails, it leaves an extra file:
 367         or unlink \*STDOUT;
 368 }
 369
 370 # check that we can call methods on filehandles auto-magically
 371 # and have IO::File loaded for us
 372 SKIP: {
 373     skip_if_miniperl("no dynamic loading on miniperl, so can't load IO::File", 3);
 374     is( $INC{'IO/File.pm'}, undef, "IO::File not loaded" );
 375     my $var = "";
 376     open my $fh, ">", \$var;
 377     ok( eval { $fh->autoflush(1); 1 }, '$fh->autoflush(1) lives' );
 378     ok( $INC{'IO/File.pm'}, "IO::File now loaded" );
 379 }