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