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]);
65 ::compare(WRITE => @_);
66 $data = substr($_[1],$_[3] || 0, $_[2]);
71 ::compare(CLOSE => @_);
82 @expect = (TIEHANDLE => 'Implement');
83 my $ob = tie *$fh,'Implement';
84 is(ref($ob), 'Implement');
87 @expect = (PRINT => $ob,"some","text");
88 $r = print $fh @expect[2,3];
91 @expect = (PRINTF => $ob,"%s","text");
92 $r = printf $fh @expect[2,3];
95 $text = (@data = ("the line\n"))[0];
96 @expect = (READLINE => $ob);
101 @in = @data = qw(a line at a time);
106 @expect = (GETC => $ob);
112 @expect = (READ => $ob, $buf, 3);
114 $r = read $fh,$buf,3;
120 @expect = (READ => $ob, $buf, 3,3);
122 $r = sysread $fh,$buf,3,3;
127 @expect = (WRITE => $ob, $buf, 4,1);
129 $r = syswrite $fh,$buf,4,1;
134 @expect = (WRITE => $ob, $buf, 4);
136 $r = syswrite $fh,$buf,4;
141 @expect = (WRITE => $ob, $buf, 6);
143 $r = syswrite $fh,$buf;
147 @expect = (CLOSE => $ob);
151 # Does aliasing work with tied FHs?
153 @expect = (PRINT => $ob,"some","text");
154 $r = print ALIAS @expect[2,3];
159 # Special case of aliasing STDERR, which used
160 # to dump core when warnings were enabled
161 local *STDERR = *$fh;
162 @expect = (PRINT => $ob,"some","text");
163 $r = print STDERR @expect[2,3];
170 use base qw(Implement);
176 return $self->SUPER::PRINT(@_);
179 my $fh = Symbol::gensym;
180 @expect = (TIEHANDLE => 'Bar::Say');
181 ::ok( my $obj = tie *$fh, 'Bar::Say' );
183 local $\ = 'something';
184 @expect = (PRINT => $obj, "stuff", "and", "things");
185 ::ok( print $fh @expect[2..4] );
186 ::is( $ors, 'something' );
188 ::ok( say $fh @expect[2..4] );
189 ::is( $ors, "\n", 'say sets $\ to \n in PRINT' );
190 ::is( $\, "something", " and it's localized" );
194 # Test for change #11536
197 sub TIEHANDLE { bless {} }
205 read $fh, my $buff, 1;
210 read STDIN, my $buff, 1;
218 # test for change 11639: Can't localize *FH, then tie it
239 sub TIEHANDLE {bless {}}
240 sub TIEHASH {bless {}}
241 sub TIEARRAY {bless {}}
245 # warnings should pass to the PRINT method of tied STDERR
248 local *STDERR = *$fh;
249 no warnings 'redefine';
250 local *Implement::PRINT = sub { @received = @_ };
252 $r = warn("some", "text", "\n");
253 @expect = (PRINT => $ob,"sometext\n");
255 compare(PRINT => @received);
260 like($received[1], qr/Use of uninitialized value/);
264 # [ID 20020713.001] chomp($data=<tied_fh>)
268 chomp($data = <TEST>);
272 sub TIEHANDLE { bless {}, $_[0] }
273 sub READLINE { "foobar\n" }