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