16 local $Level = $Level + 1;
18 return unless @expect;
19 return ::fail() unless(@_ == @expect);
22 next if $_[$i] eq $expect[$i];
33 ::compare(TIEHANDLE => @_);
34 my ($class,@val) = @_;
35 return bless \@val,$class;
39 ::compare(PRINT => @_);
44 ::compare(PRINTF => @_);
49 ::compare(READLINE => @_);
50 wantarray ? @data : shift @data;
54 ::compare(GETC => @_);
59 ::compare(READ => @_);
60 substr($_[1],$_[3] || 0) = substr($data,0,$_[2]);
70 ::compare(WRITE => @_);
71 $data = substr($_[1],$_[3] || 0, $_[2]);
76 ::compare(CLOSE => @_);
86 @expect = (TIEHANDLE => 'Implement');
87 my $ob = tie *$fh,'Implement';
88 is(ref($ob), 'Implement');
91 @expect = (PRINT => $ob,"some","text");
92 $r = print $fh @expect[2,3];
95 @expect = (PRINTF => $ob,"%s","text");
96 $r = printf $fh @expect[2,3];
99 @data = ("the line\n");
100 @expect = (EOF => $ob, 1);
104 @expect = (READLINE => $ob);
108 @expect = (EOF => $ob, 0);
112 @in = @data = qw(a line at a time);
117 @expect = (GETC => $ob);
123 @expect = (READ => $ob, $buf, 3);
125 $r = read $fh,$buf,3;
131 @expect = (READ => $ob, $buf, 3,3);
133 $r = sysread $fh,$buf,3,3;
138 @expect = (WRITE => $ob, $buf, 4,1);
140 $r = syswrite $fh,$buf,4,1;
145 @expect = (WRITE => $ob, $buf, 4);
147 $r = syswrite $fh,$buf,4;
152 @expect = (WRITE => $ob, $buf, 6);
154 $r = syswrite $fh,$buf;
158 @expect = (CLOSE => $ob);
162 # Does aliasing work with tied FHs?
164 @expect = (PRINT => $ob,"some","text");
165 $r = print ALIAS @expect[2,3];
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];
181 use base qw(Implement);
187 return $self->SUPER::PRINT(@_);
190 my $fh = Symbol::gensym;
191 @expect = (TIEHANDLE => 'Bar::Say');
192 ::ok( my $obj = tie *$fh, 'Bar::Say' );
194 local $\ = 'something';
195 @expect = (PRINT => $obj, "stuff", "and", "things");
196 ::ok( print $fh @expect[2..4] );
197 ::is( $ors, 'something' );
199 ::ok( say $fh @expect[2..4] );
200 ::is( $ors, "\n", 'say sets $\ to \n in PRINT' );
201 ::is( $\, "something", " and it's localized" );
205 # Test for change #11536
208 sub TIEHANDLE { bless {} }
216 read $fh, my $buff, 1;
221 read STDIN, my $buff, 1;
229 # test for change 11639: Can't localize *FH, then tie it
250 sub TIEHANDLE {bless {}}
251 sub TIEHASH {bless {}}
252 sub TIEARRAY {bless {}}
256 # warnings should pass to the PRINT method of tied STDERR
259 local *STDERR = *$fh;
260 no warnings 'redefine';
261 local *Implement::PRINT = sub { @received = @_ };
263 $r = warn("some", "text", "\n");
264 @expect = (PRINT => $ob,"sometext\n");
266 compare(PRINT => @received);
271 like($received[1], qr/Use of uninitialized value/);
275 # [ID 20020713.001] chomp($data=<tied_fh>)
279 chomp($data = <TEST>);
283 sub TIEHANDLE { bless {}, $_[0] }
284 sub READLINE { "foobar\n" }
288 # make sure the new eof() features work with @ARGV magic
292 @expect = (TIEHANDLE => 'Implement');
293 $ob = tie *ARGV, 'Implement';
294 is(ref($ob), 'Implement');
295 is(tied(*ARGV), $ob);
298 @expect = (EOF => $ob, 1);
300 @expect = (EOF => $ob, 2);
303 @expect = (EOF => $ob, 0);