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