16 return unless @expect;
17 return ::fail() unless(@_ == @expect);
20 next if $_[$i] eq $expect[$i];
31 ::compare(TIEHANDLE => @_);
32 my ($class,@val) = @_;
33 return bless \@val,$class;
37 ::compare(PRINT => @_);
42 ::compare(PRINTF => @_);
47 ::compare(READLINE => @_);
48 wantarray ? @data : shift @data;
52 ::compare(GETC => @_);
57 ::compare(READ => @_);
58 substr($_[1],$_[3] || 0) = substr($data,0,$_[2]);
63 ::compare(WRITE => @_);
64 $data = substr($_[1],$_[3] || 0, $_[2]);
69 ::compare(CLOSE => @_);
80 @expect = (TIEHANDLE => 'Implement');
81 my $ob = tie *$fh,'Implement';
82 is(ref($ob), 'Implement');
85 @expect = (PRINT => $ob,"some","text");
86 $r = print $fh @expect[2,3];
89 @expect = (PRINTF => $ob,"%s","text");
90 $r = printf $fh @expect[2,3];
93 $text = (@data = ("the line\n"))[0];
94 @expect = (READLINE => $ob);
99 @in = @data = qw(a line at a time);
104 @expect = (GETC => $ob);
110 @expect = (READ => $ob, $buf, 3);
112 $r = read $fh,$buf,3;
118 @expect = (READ => $ob, $buf, 3,3);
120 $r = sysread $fh,$buf,3,3;
125 @expect = (WRITE => $ob, $buf, 4,1);
127 $r = syswrite $fh,$buf,4,1;
132 @expect = (WRITE => $ob, $buf, 4);
134 $r = syswrite $fh,$buf,4;
139 @expect = (WRITE => $ob, $buf, 6);
141 $r = syswrite $fh,$buf;
145 @expect = (CLOSE => $ob);
149 # Does aliasing work with tied FHs?
151 @expect = (PRINT => $ob,"some","text");
152 $r = print ALIAS @expect[2,3];
157 # Special case of aliasing STDERR, which used
158 # to dump core when warnings were enabled
159 local *STDERR = *$fh;
160 @expect = (PRINT => $ob,"some","text");
161 $r = print STDERR @expect[2,3];
166 # Test for change #11536
169 sub TIEHANDLE { bless {} }
177 read $fh, my $buff, 1;
182 read STDIN, my $buff, 1;
190 # test for change 11639: Can't localize *FH, then tie it
211 sub TIEHANDLE {bless {}}
212 sub TIEHASH {bless {}}
213 sub TIEARRAY {bless {}}
217 # warnings should pass to the PRINT method of tied STDERR
220 local *STDERR = *$fh;
221 no warnings 'redefine';
222 local *Implement::PRINT = sub { @received = @_ };
224 $r = warn("some", "text", "\n");
225 @expect = (PRINT => $ob,"sometext\n");
227 compare(PRINT => @received);
232 like($received[1], qr/Use of uninitialized value/);
236 # [ID 20020713.001] chomp($data=<tied_fh>)
240 chomp($data = <TEST>);
244 sub TIEHANDLE { bless {}, $_[0] }
245 sub READLINE { "foobar\n" }