t/op/tiehandle.t

   1 #!./perl -w
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     require './test.pl';
   6     set_up_inc(qw '../lib ../dist/base/lib');
   7 }
   8
   9 my @expect;
  10 my $data = "";
  11 my @data = ();
  12
  13 plan(tests => 67);
  14
  15 sub compare {
  16     local $Level = $Level + 1;
  17
  18     return unless @expect;
  19     return ::fail() unless(@_ == @expect);
  20
  21     for my $i (0..$#_) {
  22         next if $_[$i] eq $expect[$i];
  23         return ::fail();
  24     }
  25
  26     ::pass();
  27 }
  28
  29
  30 package Implement;
  31
  32 sub TIEHANDLE {
  33     ::compare(TIEHANDLE => @_);
  34     my ($class,@val) = @_;
  35     return bless \@val,$class;
  36 }
  37
  38 sub PRINT {
  39     ::compare(PRINT => @_);
  40     1;
  41 }
  42
  43 sub PRINTF {
  44     ::compare(PRINTF => @_);
  45     2;
  46 }
  47
  48 sub READLINE {
  49     ::compare(READLINE => @_);
  50     wantarray ? @data : shift @data;
  51 }
  52
  53 sub GETC {
  54     ::compare(GETC => @_);
  55     substr($data,0,1);
  56 }
  57
  58 sub READ {
  59     ::compare(READ => @_);
  60     substr($_[1],$_[3] || 0) = substr($data,0,$_[2]);
  61     3;
  62 }
  63
  64 sub EOF {
  65     ::compare(EOF => @_);
  66     @data ? '' : 1;
  67 }
  68
  69 sub WRITE {
  70     ::compare(WRITE => @_);
  71     $data = substr($_[1],$_[3] || 0, $_[2]);
  72     length($data);
  73 }
  74
  75 sub CLOSE {
  76     ::compare(CLOSE => @_);
  77     5;
  78 }
  79
  80 package main;
  81
  82 use Symbol;
  83
  84 my $fh = gensym;
  85
  86 @expect = (TIEHANDLE => 'Implement');
  87 my $ob = tie *$fh,'Implement';
  88 is(ref($ob),  'Implement');
  89 is(tied(*$fh), $ob);
  90
  91 @expect = (PRINT => $ob,"some","text");
  92 $r = print $fh @expect[2,3];
  93 is($r, 1);
  94
  95 @expect = (PRINTF => $ob,"%s","text");
  96 $r = printf $fh @expect[2,3];
  97 is($r, 2);
  98
  99 @data = ("the line\n");
 100 @expect = (EOF => $ob, 1);
 101 is(eof($fh), '');
 102
 103 $text = $data[0];
 104 @expect = (READLINE => $ob);
 105 $ln = <$fh>;
 106 is($ln, $text);
 107
 108 @expect = (EOF => $ob, 0);
 109 is(eof, 1);
 110
 111 @expect = ();
 112 @in = @data = qw(a line at a time);
 113 @line = <$fh>;
 114 @expect = @in;
 115 compare(@line);
 116
 117 @expect = (GETC => $ob);
 118 $data = "abc";
 119 $ch = getc $fh;
 120 is($ch, "a");
 121
 122 $buf = "xyz";
 123 @expect = (READ => $ob, $buf, 3);
 124 $data = "abc";
 125 $r = read $fh,$buf,3;
 126 is($r, 3);
 127 is($buf, "abc");
 128
 129
 130 $buf = "xyzasd";
 131 @expect = (READ => $ob, $buf, 3,3);
 132 $data = "abc";
 133 $r = sysread $fh,$buf,3,3;
 134 is($r, 3);
 135 is($buf, "xyzabc");
 136
 137 $buf = "qwerty";
 138 @expect = (WRITE => $ob, $buf, 4,1);
 139 $data = "";
 140 $r = syswrite $fh,$buf,4,1;
 141 is($r, 4);
 142 is($data, "wert");
 143
 144 $buf = "qwerty";
 145 @expect = (WRITE => $ob, $buf, 4);
 146 $data = "";
 147 $r = syswrite $fh,$buf,4;
 148 is($r, 4);
 149 is($data, "qwer");
 150
 151 $buf = "qwerty";
 152 @expect = (WRITE => $ob, $buf, 6);
 153 $data = "";
 154 $r = syswrite $fh,$buf;
 155 is($r, 6);
 156 is($data, "qwerty");
 157
 158 @expect = (CLOSE => $ob);
 159 $r = close $fh;
 160 is($r, 5);
 161
 162 # Does aliasing work with tied FHs?
 163 *ALIAS = *$fh;
 164 @expect = (PRINT => $ob,"some","text");
 165 $r = print ALIAS @expect[2,3];
 166 is($r, 1);
 167
 168 {
 169     use warnings;
 170     # Special case of aliasing STDERR, which used
 171     # to dump core when warnings were enabled
 172     local *STDERR = *$fh;
 173     @expect = (PRINT => $ob,"some","text");
 174     $r = print STDERR @expect[2,3];
 175     is($r, 1);
 176 }
 177
 178 {
 179     package Bar::Say;
 180     use feature 'say';
 181     use base qw(Implement);
 182
 183     my $ors;
 184     sub PRINT     {
 185         $ors = $\;
 186         my $self = shift;
 187         return $self->SUPER::PRINT(@_);
 188     }
 189
 190     my $fh = Symbol::gensym;
 191     @expect = (TIEHANDLE => 'Bar::Say');
 192     ::ok( my $obj = tie *$fh, 'Bar::Say' );
 193
 194     local $\ = 'something';
 195     @expect = (PRINT => $obj, "stuff", "and", "things");
 196     ::ok( print $fh @expect[2..4] );
 197     ::is( $ors, 'something' );
 198
 199     ::ok( say $fh @expect[2..4] );
 200     ::is( $ors, "\n",        'say sets $\ to \n in PRINT' );
 201     ::is( $\,   "something", "  and it's localized" );
 202
 203     local $\;
 204     ::ok( say $fh @expect[2..4] );
 205     ::is( $ors, "\n",        'say sets $\ to \n in PRINT' );
 206     ::is( $\,   undef, "  and it's localized, even for undef \$\\" );
 207 }
 208
 209 {
 210     # Test for change #11536
 211     package Foo;
 212     use strict;
 213     sub TIEHANDLE { bless {} }
 214     my $cnt = 'a';
 215     sub READ {
 216         $_[1] = $cnt++;
 217         1;
 218     }
 219     sub do_read {
 220         my $fh = shift;
 221         read $fh, my $buff, 1;
 222         ::pass();
 223     }
 224     $|=1;
 225     tie *STDIN, 'Foo';
 226     read STDIN, my $buff, 1;
 227     ::pass();
 228     do_read(\*STDIN);
 229     untie *STDIN;
 230 }
 231
 232
 233 {
 234     # test for change 11639: Can't localize *FH, then tie it
 235     {
 236         local *foo;
 237         tie %foo, 'Blah';
 238     }
 239     ok(!tied %foo);
 240
 241     {
 242         local *bar;
 243         tie @bar, 'Blah';
 244     }
 245     ok(!tied @bar);
 246
 247     {
 248         local *BAZ;
 249         tie *BAZ, 'Blah';
 250     }
 251     ok(!tied *BAZ);
 252
 253     package Blah;
 254
 255     sub TIEHANDLE {bless {}}
 256     sub TIEHASH   {bless {}}
 257     sub TIEARRAY  {bless {}}
 258 }
 259
 260 {
 261     # warnings should pass to the PRINT method of tied STDERR
 262     my @received;
 263
 264     local *STDERR = *$fh;
 265     no warnings 'redefine';
 266     local *Implement::PRINT = sub { @received = @_ };
 267
 268     $r = warn("some", "text", "\n");
 269     @expect = (PRINT => $ob,"sometext\n");
 270
 271     compare(PRINT => @received);
 272
 273     use warnings;
 274     print undef;
 275
 276     like($received[1], qr/Use of uninitialized value/);
 277 }
 278
 279 {
 280     # [ID 20020713.001 (#10048)] chomp($data=<tied_fh>)
 281     local *TEST;
 282     tie *TEST, 'CHOMP';
 283     my $data;
 284     chomp($data = <TEST>);
 285     is($data, 'foobar');
 286
 287     package CHOMP;
 288     sub TIEHANDLE { bless {}, $_[0] }
 289     sub READLINE { "foobar\n" }
 290 }
 291
 292 {
 293     # make sure the new eof() features work with @ARGV magic
 294     local *ARGV;
 295     @ARGV = ('haha');
 296
 297     @expect = (TIEHANDLE => 'Implement');
 298     $ob = tie *ARGV, 'Implement';
 299     is(ref($ob),  'Implement');
 300     is(tied(*ARGV), $ob);
 301
 302     @data = ("stuff\n");
 303     @expect = (EOF => $ob, 1);
 304     is(eof(ARGV), '');
 305     @expect = (EOF => $ob, 2);
 306     is(eof(), '');
 307     shift @data;
 308     @expect = (EOF => $ob, 0);
 309     is(eof, 1);
 310 }