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 => 91;
  14
  15 my $Perl = which_perl();
  16
  17 {
  18     unlink("afile") if -f "afile";
  19
  20     $! = 0;  # the -f above will set $! if 'afile' doesn't exist.
  21     ok( open(my $f,"+>afile"),  'open(my $f, "+>...")' );
  22
  23     binmode $f;
  24     ok( -f "afile",             '       its a file');
  25     ok( (print $f "SomeData\n"),  '       we can print to it');
  26     is( tell($f), 9,            '       tell()' );
  27     ok( seek($f,0,0),           '       seek set' );
  28
  29     $b = <$f>;
  30     is( $b, "SomeData\n",       '       readline' );
  31     ok( -f $f,                  '       still a file' );
  32
  33     eval  { die "Message" };
  34     like( $@, qr/<\$f> line 1/, '       die message correct' );
  35
  36     ok( close($f),              '       close()' );
  37     ok( unlink("afile"),        '       unlink()' );
  38 }
  39
  40 {
  41     ok( open(my $f,'>', 'afile'),       "open(my \$f, '>', 'afile')" );
  42     ok( (print $f "a row\n"),           '       print');
  43     ok( close($f),                      '       close' );
  44     ok( -s 'afile' < 10,                '       -s' );
  45 }
  46
  47 {
  48     ok( open(my $f,'>>', 'afile'),      "open(my \$f, '>>', 'afile')" );
  49     ok( (print $f "a row\n"),           '       print' );
  50     ok( close($f),                      '       close' );
  51     ok( -s 'afile' > 10,                '       -s'    );
  52 }
  53
  54 {
  55     ok( open(my $f, '<', 'afile'),      "open(my \$f, '<', 'afile')" );
  56     my @rows = <$f>;
  57     is( scalar @rows, 2,                '       readline, list context' );
  58     is( $rows[0], "a row\n",            '       first line read' );
  59     is( $rows[1], "a row\n",            '       second line' );
  60     ok( close($f),                      '       close' );
  61 }
  62
  63 {
  64     ok( -s 'afile' < 20,                '-s' );
  65
  66     ok( open(my $f, '+<', 'afile'),     'open +<' );
  67     my @rows = <$f>;
  68     is( scalar @rows, 2,                '       readline, list context' );
  69     ok( seek($f, 0, 1),                 '       seek cur' );
  70     ok( (print $f "yet another row\n"), '       print' );
  71     ok( close($f),                      '       close' );
  72     ok( -s 'afile' > 20,                '       -s' );
  73
  74     unlink("afile");
  75 }
  76
  77 SKIP: {
  78     skip "open -| busted and noisy on VMS", 3 if $Is_VMS;
  79
  80     ok( open(my $f, '-|', <<EOC),     'open -|' );
  81     $Perl -e "print qq(a row\n); print qq(another row\n)"
  82 EOC
  83
  84     my @rows = <$f>;
  85     is( scalar @rows, 2,                '       readline, list context' );
  86     ok( close($f),                      '       close' );
  87 }
  88
  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 SKIP: {
 171     skip "open -| busted and noisy on VMS", 3 if $Is_VMS;
 172
 173     ok( open(local $f, '-|', <<EOC),  'open local $f, "-|", ...' );
 174     $Perl -e "print qq(a row\n); print qq(another row\n)"
 175 EOC
 176     my @rows = <$f>;
 177
 178     is( scalar @rows, 2,                '       readline list context' );
 179     ok( close($f),                      '       close' );
 180 }
 181
 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