mktables: Omit unnecessary duplicates
[perl.git] / 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 }