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 $Is_VMS = $^O eq 'VMS';
  12
  13 plan tests => 95;
  14
  15 {
  16     unlink("afile") if -f "afile";
  17
  18     $! = 0;  # the -f above will set $! if 'afile' doesn't exist.
  19     ok( open(my $f,"+>afile"),  'open(my $f, "+>...")' );
  20
  21     binmode $f;
  22     ok( -f "afile",             '       its a file');
  23     ok( (print $f "SomeData\n"),  '       we can print to it');
  24     is( tell($f), 9,            '       tell()' );
  25     ok( seek($f,0,0),           '       seek set' );
  26
  27     $b = <$f>;
  28     is( $b, "SomeData\n",       '       readline' );
  29     ok( -f $f,                  '       still a file' );
  30
  31     eval  { die "Message" };
  32     like( $@, qr/<\$f> line 1/, '       die message correct' );
  33
  34     ok( close($f),              '       close()' );
  35     ok( unlink("afile"),        '       unlink()' );
  36 }
  37
  38 {
  39     ok( open(my $f,'>', 'afile'),       "open(my \$f, '>', 'afile')" );
  40     ok( (print $f "a row\n"),           '       print');
  41     ok( close($f),                      '       close' );
  42     ok( -s 'afile' < 10,                '       -s' );
  43 }
  44
  45 {
  46     ok( open(my $f,'>>', 'afile'),      "open(my \$f, '>>', 'afile')" );
  47     ok( (print $f "a row\n"),           '       print' );
  48     ok( close($f),                      '       close' );
  49     ok( -s 'afile' > 10,                '       -s'    );
  50 }
  51
  52 {
  53     ok( open(my $f, '<', 'afile'),      "open(my \$f, '<', 'afile')" );
  54     my @rows = <$f>;
  55     is( scalar @rows, 2,                '       readline, list context' );
  56     is( $rows[0], "a row\n",            '       first line read' );
  57     is( $rows[1], "a row\n",            '       second line' );
  58     ok( close($f),                      '       close' );
  59 }
  60
  61 {
  62     ok( -s 'afile' < 20,                '-s' );
  63
  64     ok( open(my $f, '+<', 'afile'),     'open +<' );
  65     my @rows = <$f>;
  66     is( scalar @rows, 2,                '       readline, list context' );
  67     ok( seek($f, 0, 1),                 '       seek cur' );
  68     ok( (print $f "yet another row\n"), '       print' );
  69     ok( close($f),                      '       close' );
  70     ok( -s 'afile' > 20,                '       -s' );
  71
  72     unlink("afile");
  73 }
  74
  75 SKIP: {
  76     skip "open -| busted and noisy on VMS", 3 if $Is_VMS;
  77
  78     ok( open(my $f, '-|', <<EOC),     'open -|' );
  79     $^X -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 {
  88     ok( open(my $f, '|-', <<EOC),     'open |-' );
  89     $^X -pe "s/^not //"
  90 EOC
  91
  92     my @rows = <$f>;
  93     my $test = curr_test;
  94     print $f "not ok $test - piped in\n";
  95     next_test;
  96
  97     $test = curr_test;
  98     print $f "not ok $test - piped in\n";
  99     next_test;
 100     ok( close($f),                      '       close' );
 101     sleep 1;
 102     pass('flushing');
 103 }
 104
 105
 106 ok( !eval { open my $f, '<&', 'afile'; 1; },    '<& on a non-filehandle' );
 107 like( $@, qr/Bad filehandle:\s+afile/,          '       right error' );
 108
 109
 110 # local $file tests
 111 {
 112     unlink("afile") if -f "afile";
 113
 114     ok( open(local $f,"+>afile"),       'open local $f, "+>", ...' );
 115     binmode $f;
 116
 117     ok( -f "afile",                     '       -f' );
 118     ok( (print $f "SomeData\n"),        '       print' );
 119     is( tell($f), 9,                    '       tell' );
 120     ok( seek($f,0,0),                   '       seek set' );
 121
 122     $b = <$f>;
 123     is( $b, "SomeData\n",               '       readline' );
 124     ok( -f $f,                          '       still a file' );
 125
 126     eval  { die "Message" };
 127     like( $@, qr/<\$f> line 1/,         '       proper die message' );
 128     ok( close($f),                      '       close' );
 129
 130     unlink("afile");
 131 }
 132
 133 {
 134     ok( open(local $f,'>', 'afile'),    'open local $f, ">", ...' );
 135     ok( (print $f "a row\n"),           '       print');
 136     ok( close($f),                      '       close');
 137     ok( -s 'afile' < 10,                '       -s' );
 138 }
 139
 140 {
 141     ok( open(local $f,'>>', 'afile'),   'open local $f, ">>", ...' );
 142     ok( (print $f "a row\n"),           '       print');
 143     ok( close($f),                      '       close');
 144     ok( -s 'afile' > 10,                '       -s' );
 145 }
 146
 147 {
 148     ok( open(local $f, '<', 'afile'),   'open local $f, "<", ...' );
 149     my @rows = <$f>;
 150     is( scalar @rows, 2,                '       readline list context' );
 151     ok( close($f),                      '       close' );
 152 }
 153
 154 ok( -s 'afile' < 20,                '       -s' );
 155
 156 {
 157     ok( open(local $f, '+<', 'afile'),  'open local $f, "+<", ...' );
 158     my @rows = <$f>;
 159     is( scalar @rows, 2,                '       readline list context' );
 160     ok( seek($f, 0, 1),                 '       seek cur' );
 161     ok( (print $f "yet another row\n"), '       print' );
 162     ok( close($f),                      '       close' );
 163     ok( -s 'afile' > 20,                '       -s' );
 164
 165     unlink("afile");
 166 }
 167
 168 SKIP: {
 169     skip "open -| busted and noisy on VMS", 3 if $Is_VMS;
 170
 171     ok( open(local $f, '-|', <<EOC),  'open local $f, "-|", ...' );
 172     $^X -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 {
 181     ok( open(local $f, '|-', <<EOC),  'open local $f, "|-", ...' );
 182     $^X -pe "s/^not //"
 183 EOC
 184
 185     my @rows = <$f>;
 186     my $test = curr_test;
 187     print $f "not ok $test - piping\n";
 188     next_test;
 189
 190     $test = curr_test;
 191     print $f "not ok $test - piping\n";
 192     next_test;
 193     ok( close($f),                      '       close' );
 194     sleep 1;
 195     pass("Flush");
 196 }
 197
 198
 199 ok( !eval { open local $f, '<&', 'afile'; 1 },  'local <& on non-filehandle');
 200 like( $@, qr/Bad filehandle:\s+afile/,          '       right error' );
 201
 202
 203 {
 204     local *F;
 205     for (1..2) {
 206         ok( open(F, qq{$^X -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{$^X -le "print 'ok'"}), 'open -|');
 213         is( scalar <F>, "ok\n", '       readline');
 214         ok( close F,            '       close' );
 215     }
 216 }
 217
 218 # magic temporary file via 3 arg open with undef
 219 {
 220     ok( open(my $x,"+<",undef), 'magic temp file via 3 arg open with undef');
 221     ok( defined fileno($x),     '       fileno' );
 222
 223     select $x;
 224     ok( (print "ok\n"),         '       print' );
 225
 226     select STDOUT;
 227     ok( seek($x,0,0),           '       seek' );
 228     is( scalar <$x>, "ok\n",    '       readline' );
 229     ok( tell($x) >= 3,          '       tell' );
 230 }