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 $Is_MacOS = $^O eq 'MacOS';
  13
  14 plan tests => 108;
  15
  16 my $Perl = which_perl();
  17
  18 my $afile = tempfile();
  19 {
  20     unlink($afile) if -f $afile;
  21
  22     $! = 0;  # the -f above will set $! if $afile doesn't exist.
  23     ok( open(my $f,"+>$afile"),  'open(my $f, "+>...")' );
  24
  25     binmode $f;
  26     ok( -f $afile,              '       its a file');
  27     ok( (print $f "SomeData\n"),  '       we can print to it');
  28     is( tell($f), 9,            '       tell()' );
  29     ok( seek($f,0,0),           '       seek set' );
  30
  31     $b = <$f>;
  32     is( $b, "SomeData\n",       '       readline' );
  33     ok( -f $f,                  '       still a file' );
  34
  35     eval  { die "Message" };
  36     like( $@, qr/<\$f> line 1/, '       die message correct' );
  37
  38     ok( close($f),              '       close()' );
  39     ok( unlink($afile),         '       unlink()' );
  40 }
  41
  42 {
  43     ok( open(my $f,'>', $afile),        "open(my \$f, '>', $afile)" );
  44     ok( (print $f "a row\n"),           '       print');
  45     ok( close($f),                      '       close' );
  46     ok( -s $afile < 10,                 '       -s' );
  47 }
  48
  49 {
  50     ok( open(my $f,'>>', $afile),       "open(my \$f, '>>', $afile)" );
  51     ok( (print $f "a row\n"),           '       print' );
  52     ok( close($f),                      '       close' );
  53     ok( -s $afile > 10,                 '       -s'    );
  54 }
  55
  56 {
  57     ok( open(my $f, '<', $afile),       "open(my \$f, '<', $afile)" );
  58     my @rows = <$f>;
  59     is( scalar @rows, 2,                '       readline, list context' );
  60     is( $rows[0], "a row\n",            '       first line read' );
  61     is( $rows[1], "a row\n",            '       second line' );
  62     ok( close($f),                      '       close' );
  63 }
  64
  65 {
  66     ok( -s $afile < 20,                 '-s' );
  67
  68     ok( open(my $f, '+<', $afile),      'open +<' );
  69     my @rows = <$f>;
  70     is( scalar @rows, 2,                '       readline, list context' );
  71     ok( seek($f, 0, 1),                 '       seek cur' );
  72     ok( (print $f "yet another row\n"), '       print' );
  73     ok( close($f),                      '       close' );
  74     ok( -s $afile > 20,                 '       -s' );
  75
  76     unlink($afile);
  77 }
  78 {
  79     ok( open(my $f, '-|', <<EOC),     'open -|' );
  80     $Perl -e "print qq(a row\\n); print qq(another row\\n)"
  81 EOC
  82
  83     my @rows = <$f>;
  84     is( scalar @rows, 2,                '       readline, list context' );
  85     ok( close($f),                      '       close' );
  86 }
  87 SKIP: {
  88     skip "Output for |- doesn't go to shell on MacOS", 5 if $Is_MacOS;
  89
  90     ok( open(my $f, '|-', <<EOC),     'open |-' );
  91     $Perl -pe "s/^not //"
  92 EOC
  93
  94     my @rows = <$f>;
  95     my $test = curr_test;
  96     print $f "not ok $test - piped in\n";
  97     next_test;
  98
  99     $test = curr_test;
 100     print $f "not ok $test - piped in\n";
 101     next_test;
 102     ok( close($f),                      '       close' );
 103     sleep 1;
 104     pass('flushing');
 105 }
 106
 107
 108 ok( !eval { open my $f, '<&', $afile; 1; },    '<& on a non-filehandle' );
 109 like( $@, qr/Bad filehandle:\s+$afile/,          '       right error' );
 110
 111
 112 # local $file tests
 113 {
 114     unlink($afile) if -f $afile;
 115
 116     ok( open(local $f,"+>$afile"),       'open local $f, "+>", ...' );
 117     binmode $f;
 118
 119     ok( -f $afile,                      '       -f' );
 120     ok( (print $f "SomeData\n"),        '       print' );
 121     is( tell($f), 9,                    '       tell' );
 122     ok( seek($f,0,0),                   '       seek set' );
 123
 124     $b = <$f>;
 125     is( $b, "SomeData\n",               '       readline' );
 126     ok( -f $f,                          '       still a file' );
 127
 128     eval  { die "Message" };
 129     like( $@, qr/<\$f> line 1/,         '       proper die message' );
 130     ok( close($f),                      '       close' );
 131
 132     unlink($afile);
 133 }
 134
 135 {
 136     ok( open(local $f,'>', $afile),     'open local $f, ">", ...' );
 137     ok( (print $f "a row\n"),           '       print');
 138     ok( close($f),                      '       close');
 139     ok( -s $afile < 10,                 '       -s' );
 140 }
 141
 142 {
 143     ok( open(local $f,'>>', $afile),    'open local $f, ">>", ...' );
 144     ok( (print $f "a row\n"),           '       print');
 145     ok( close($f),                      '       close');
 146     ok( -s $afile > 10,                 '       -s' );
 147 }
 148
 149 {
 150     ok( open(local $f, '<', $afile),    'open local $f, "<", ...' );
 151     my @rows = <$f>;
 152     is( scalar @rows, 2,                '       readline list context' );
 153     ok( close($f),                      '       close' );
 154 }
 155
 156 ok( -s $afile < 20,                     '       -s' );
 157
 158 {
 159     ok( open(local $f, '+<', $afile),  'open local $f, "+<", ...' );
 160     my @rows = <$f>;
 161     is( scalar @rows, 2,                '       readline list context' );
 162     ok( seek($f, 0, 1),                 '       seek cur' );
 163     ok( (print $f "yet another row\n"), '       print' );
 164     ok( close($f),                      '       close' );
 165     ok( -s $afile > 20,                 '       -s' );
 166
 167     unlink($afile);
 168 }
 169
 170 {
 171     ok( open(local $f, '-|', <<EOC),  'open local $f, "-|", ...' );
 172     $Perl -e "print qq(a row\\n); print qq(another row\\n)"
 173 EOC
 174     my @rows = <$f>;
 175
 176     is( scalar @rows, 2,                '       readline list context' );
 177     ok( close($f),                      '       close' );
 178 }
 179
 180 SKIP: {
 181     skip "Output for |- doesn't go to shell on MacOS", 5 if $Is_MacOS;
 182
 183     ok( open(local $f, '|-', <<EOC),  'open local $f, "|-", ...' );
 184     $Perl -pe "s/^not //"
 185 EOC
 186
 187     my @rows = <$f>;
 188     my $test = curr_test;
 189     print $f "not ok $test - piping\n";
 190     next_test;
 191
 192     $test = curr_test;
 193     print $f "not ok $test - piping\n";
 194     next_test;
 195     ok( close($f),                      '       close' );
 196     sleep 1;
 197     pass("Flush");
 198 }
 199
 200
 201 ok( !eval { open local $f, '<&', $afile; 1 },  'local <& on non-filehandle');
 202 like( $@, qr/Bad filehandle:\s+$afile/,          '       right error' );
 203
 204 {
 205     local *F;
 206     for (1..2) {
 207         ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' );
 208         is(scalar <F>, "ok\n",  '       readline');
 209         ok( close F,            '       close' );
 210     }
 211
 212     for (1..2) {
 213         ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|');
 214         is( scalar <F>, "ok\n", '       readline');
 215         ok( close F,            '       close' );
 216     }
 217 }
 218
 219
 220 # other dupping techniques
 221 {
 222     ok( open(my $stdout, ">&", \*STDOUT),       'dup \*STDOUT into lexical fh');
 223     ok( open(STDOUT,     ">&", $stdout),        'restore dupped STDOUT from lexical fh');
 224
 225     {
 226         use strict; # the below should not warn
 227         ok( open(my $stdout, ">&", STDOUT),         'dup STDOUT into lexical fh');
 228     }
 229
 230     # used to try to open a file [perl #17830]
 231     ok( open(my $stdin,  "<&", fileno STDIN),   'dup fileno(STDIN) into lexical fh') or _diag $!;
 232 }
 233
 234 SKIP: {
 235     skip "This perl uses perlio", 1 if $Config{useperlio};
 236     skip "miniperl cannot be relied on to load %Errno"
 237         if $ENV{PERL_CORE_MINITEST};
 238     # Force the reference to %! to be run time by writing ! as {"!"}
 239     skip "This system doesn't understand EINVAL", 1
 240         unless exists ${"!"}{EINVAL};
 241
 242     no warnings 'io';
 243     ok(!open(F,'>',\my $s) && ${"!"}{EINVAL}, 'open(reference) raises EINVAL');
 244 }
 245
 246 {
 247     ok( !eval { open F, "BAR", "QUUX" },       'Unknown open() mode' );
 248     like( $@, qr/\QUnknown open() mode 'BAR'/, '       right error' );
 249 }
 250
 251 {
 252     local $SIG{__WARN__} = sub { $@ = shift };
 253
 254     sub gimme {
 255         my $tmphandle = shift;
 256         my $line = scalar <$tmphandle>;
 257         warn "gimme";
 258         return $line;
 259     }
 260
 261     open($fh0[0], "TEST");
 262     gimme($fh0[0]);
 263     like($@, qr/<\$fh0\[...\]> line 1\./, "autoviv fh package aelem");
 264
 265     open($fh1{k}, "TEST");
 266     gimme($fh1{k});
 267     like($@, qr/<\$fh1{...}> line 1\./, "autoviv fh package helem");
 268
 269     my @fh2;
 270     open($fh2[0], "TEST");
 271     gimme($fh2[0]);
 272     like($@, qr/<\$fh2\[...\]> line 1\./, "autoviv fh lexical aelem");
 273
 274     my %fh3;
 275     open($fh3{k}, "TEST");
 276     gimme($fh3{k});
 277     like($@, qr/<\$fh3{...}> line 1\./, "autoviv fh lexical helem");
 278 }
 279
 280 SKIP: {
 281     skip("These tests use perlio", 5) unless $Config{useperlio};
 282     my $w;
 283     use warnings 'layer';
 284     local $SIG{__WARN__} = sub { $w = shift };
 285
 286     eval { open(F, ">>>", $afile) };
 287     like($w, qr/Invalid separator character '>' in PerlIO layer spec/,
 288          "bad open (>>>) warning");
 289     like($@, qr/Unknown open\(\) mode '>>>'/,
 290          "bad open (>>>) failure");
 291
 292     eval { open(F, ">:u", $afile ) };
 293     like($w, qr/Unknown PerlIO layer "u"/,
 294          'bad layer ">:u" warning');
 295     eval { open(F, "<:u", $afile ) };
 296     like($w, qr/Unknown PerlIO layer "u"/,
 297          'bad layer "<:u" warning');
 298     eval { open(F, ":c", $afile ) };
 299     like($@, qr/Unknown open\(\) mode ':c'/,
 300          'bad layer ":c" failure');
 301 }
 302
 303 # [perl #28986] "open m" crashes Perl
 304
 305 fresh_perl_like('open m', qr/^Search pattern not terminated at/,
 306         { stderr => 1 }, 'open m test');
 307
 308 fresh_perl_is(
 309     'sub f { open(my $fh, "xxx"); $fh = "f"; } f; f;print "ok"',
 310     'ok', { stderr => 1 },
 311     '#29102: Crash on assignment to lexical filehandle');
 312
 313 # [perl #31767] Using $1 as a filehandle via open $1, "file" doesn't raise
 314 # an exception
 315
 316 eval { open $99, "foo" };
 317 like($@, qr/Modification of a read-only value attempted/, "readonly fh");