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
  14 plan tests => 94;
  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 SKIP: {
  79     skip "open -| busted and noisy on VMS", 3 if $Is_VMS;
  80
  81     ok( open(my $f, '-|', <<EOC),     'open -|' );
  82     $Perl -e "print qq(a row\n); print qq(another row\n)"
  83 EOC
  84
  85     my @rows = <$f>;
  86     is( scalar @rows, 2,                '       readline, list context' );
  87     ok( close($f),                      '       close' );
  88 }
  89
  90 {
  91     ok( open(my $f, '|-', <<EOC),     'open |-' );
  92     $Perl -pe "s/^not //"
  93 EOC
  94
  95     my @rows = <$f>;
  96     my $test = curr_test;
  97     print $f "not ok $test - piped in\n";
  98     next_test;
  99
 100     $test = curr_test;
 101     print $f "not ok $test - piped in\n";
 102     next_test;
 103     ok( close($f),                      '       close' );
 104     sleep 1;
 105     pass('flushing');
 106 }
 107
 108
 109 ok( !eval { open my $f, '<&', 'afile'; 1; },    '<& on a non-filehandle' );
 110 like( $@, qr/Bad filehandle:\s+afile/,          '       right error' );
 111
 112
 113 # local $file tests
 114 {
 115     unlink("afile") if -f "afile";
 116
 117     ok( open(local $f,"+>afile"),       'open local $f, "+>", ...' );
 118     binmode $f;
 119
 120     ok( -f "afile",                     '       -f' );
 121     ok( (print $f "SomeData\n"),        '       print' );
 122     is( tell($f), 9,                    '       tell' );
 123     ok( seek($f,0,0),                   '       seek set' );
 124
 125     $b = <$f>;
 126     is( $b, "SomeData\n",               '       readline' );
 127     ok( -f $f,                          '       still a file' );
 128
 129     eval  { die "Message" };
 130     like( $@, qr/<\$f> line 1/,         '       proper die message' );
 131     ok( close($f),                      '       close' );
 132
 133     unlink("afile");
 134 }
 135
 136 {
 137     ok( open(local $f,'>', 'afile'),    'open local $f, ">", ...' );
 138     ok( (print $f "a row\n"),           '       print');
 139     ok( close($f),                      '       close');
 140     ok( -s 'afile' < 10,                '       -s' );
 141 }
 142
 143 {
 144     ok( open(local $f,'>>', 'afile'),   'open local $f, ">>", ...' );
 145     ok( (print $f "a row\n"),           '       print');
 146     ok( close($f),                      '       close');
 147     ok( -s 'afile' > 10,                '       -s' );
 148 }
 149
 150 {
 151     ok( open(local $f, '<', 'afile'),   'open local $f, "<", ...' );
 152     my @rows = <$f>;
 153     is( scalar @rows, 2,                '       readline list context' );
 154     ok( close($f),                      '       close' );
 155 }
 156
 157 ok( -s 'afile' < 20,                '       -s' );
 158
 159 {
 160     ok( open(local $f, '+<', 'afile'),  'open local $f, "+<", ...' );
 161     my @rows = <$f>;
 162     is( scalar @rows, 2,                '       readline list context' );
 163     ok( seek($f, 0, 1),                 '       seek cur' );
 164     ok( (print $f "yet another row\n"), '       print' );
 165     ok( close($f),                      '       close' );
 166     ok( -s 'afile' > 20,                '       -s' );
 167
 168     unlink("afile");
 169 }
 170
 171 SKIP: {
 172     skip "open -| busted and noisy on VMS", 3 if $Is_VMS;
 173
 174     ok( open(local $f, '-|', <<EOC),  'open local $f, "-|", ...' );
 175     $Perl -e "print qq(a row\n); print qq(another row\n)"
 176 EOC
 177     my @rows = <$f>;
 178
 179     is( scalar @rows, 2,                '       readline list context' );
 180     ok( close($f),                      '       close' );
 181 }
 182
 183 {
 184     ok( open(local $f, '|-', <<EOC),  'open local $f, "|-", ...' );
 185     $Perl -pe "s/^not //"
 186 EOC
 187
 188     my @rows = <$f>;
 189     my $test = curr_test;
 190     print $f "not ok $test - piping\n";
 191     next_test;
 192
 193     $test = curr_test;
 194     print $f "not ok $test - piping\n";
 195     next_test;
 196     ok( close($f),                      '       close' );
 197     sleep 1;
 198     pass("Flush");
 199 }
 200
 201
 202 ok( !eval { open local $f, '<&', 'afile'; 1 },  'local <& on non-filehandle');
 203 like( $@, qr/Bad filehandle:\s+afile/,          '       right error' );
 204
 205 {
 206     local *F;
 207     for (1..2) {
 208         ok( open(F, qq{$Perl -le "print 'ok'"|}), 'open to pipe' );
 209         is(scalar <F>, "ok\n",  '       readline');
 210         ok( close F,            '       close' );
 211     }
 212
 213     for (1..2) {
 214         ok( open(F, "-|", qq{$Perl -le "print 'ok'"}), 'open -|');
 215         is( scalar <F>, "ok\n", '       readline');
 216         ok( close F,            '       close' );
 217     }
 218 }
 219
 220
 221 # other dupping techniques
 222 {
 223     ok( open(my $stdout, ">&", \*STDOUT), 'dup \*STDOUT into lexical fh');
 224     ok( open(STDOUT,     ">&", $stdout),  'restore dupped STDOUT from lexical fh');
 225 }
 226
 227 SKIP: {
 228     skip "This perl uses perlio", 1 if $Config{useperlio};
 229     skip "This system doesn't understand EINVAL", 1 unless exists $!{EINVAL};
 230
 231     no warnings 'io';
 232     ok( !open(F,'>',\my $s) && $!{EINVAL}, 'open(reference) raises EINVAL' );
 233 }
 234
 235 {
 236     ok( !eval { open F, "BAR", "QUUX" },       'Unknown open() mode' );
 237     like( $@, qr/\QUnknown open() mode 'BAR'/, '       right error' );
 238 }