Commit | Line | Data |
---|---|---|
94c40caf | 1 | #!./perl -w |
1d603a67 GB |
2 | |
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
20822f61 | 5 | @INC = '../lib'; |
1d603a67 GB |
6 | } |
7 | ||
8 | my @expect; | |
9 | my $data = ""; | |
10 | my @data = (); | |
1d603a67 | 11 | |
94c40caf | 12 | require './test.pl'; |
32e65323 | 13 | plan(tests => 63); |
1d603a67 GB |
14 | |
15 | sub compare { | |
3a28f3fb MS |
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 GB |
24 | } |
25 | ||
94c40caf | 26 | ::pass(); |
1d603a67 GB |
27 | } |
28 | ||
94c40caf JH |
29 | |
30 | package Implement; | |
31 | ||
1d603a67 | 32 | sub TIEHANDLE { |
94c40caf | 33 | ::compare(TIEHANDLE => @_); |
1d603a67 GB |
34 | my ($class,@val) = @_; |
35 | return bless \@val,$class; | |
36 | } | |
37 | ||
38 | sub PRINT { | |
94c40caf | 39 | ::compare(PRINT => @_); |
1d603a67 GB |
40 | 1; |
41 | } | |
42 | ||
43 | sub PRINTF { | |
94c40caf | 44 | ::compare(PRINTF => @_); |
1d603a67 GB |
45 | 2; |
46 | } | |
47 | ||
48 | sub READLINE { | |
94c40caf | 49 | ::compare(READLINE => @_); |
1d603a67 GB |
50 | wantarray ? @data : shift @data; |
51 | } | |
52 | ||
53 | sub GETC { | |
94c40caf | 54 | ::compare(GETC => @_); |
1d603a67 GB |
55 | substr($data,0,1); |
56 | } | |
57 | ||
58 | sub READ { | |
94c40caf | 59 | ::compare(READ => @_); |
1d603a67 GB |
60 | substr($_[1],$_[3] || 0) = substr($data,0,$_[2]); |
61 | 3; | |
62 | } | |
63 | ||
32e65323 CS |
64 | sub EOF { |
65 | ::compare(EOF => @_); | |
66 | @data ? '' : 1; | |
67 | } | |
68 | ||
1d603a67 | 69 | sub WRITE { |
94c40caf | 70 | ::compare(WRITE => @_); |
1d603a67 | 71 | $data = substr($_[1],$_[3] || 0, $_[2]); |
145d37e2 | 72 | length($data); |
1d603a67 GB |
73 | } |
74 | ||
75 | sub CLOSE { | |
94c40caf | 76 | ::compare(CLOSE => @_); |
1d603a67 GB |
77 | 5; |
78 | } | |
79 | ||
80 | package main; | |
81 | ||
82 | use Symbol; | |
83 | ||
1d603a67 GB |
84 | my $fh = gensym; |
85 | ||
86 | @expect = (TIEHANDLE => 'Implement'); | |
87 | my $ob = tie *$fh,'Implement'; | |
94c40caf JH |
88 | is(ref($ob), 'Implement'); |
89 | is(tied(*$fh), $ob); | |
1d603a67 GB |
90 | |
91 | @expect = (PRINT => $ob,"some","text"); | |
92 | $r = print $fh @expect[2,3]; | |
94c40caf | 93 | is($r, 1); |
1d603a67 GB |
94 | |
95 | @expect = (PRINTF => $ob,"%s","text"); | |
96 | $r = printf $fh @expect[2,3]; | |
94c40caf | 97 | is($r, 2); |
1d603a67 | 98 | |
32e65323 CS |
99 | @data = ("the line\n"); |
100 | @expect = (EOF => $ob, 1); | |
101 | is(eof($fh), ''); | |
102 | ||
103 | $text = $data[0]; | |
1d603a67 GB |
104 | @expect = (READLINE => $ob); |
105 | $ln = <$fh>; | |
94c40caf | 106 | is($ln, $text); |
1d603a67 | 107 | |
32e65323 CS |
108 | @expect = (EOF => $ob, 0); |
109 | is(eof, 1); | |
110 | ||
1d603a67 GB |
111 | @expect = (); |
112 | @in = @data = qw(a line at a time); | |
113 | @line = <$fh>; | |
114 | @expect = @in; | |
94c40caf | 115 | compare(@line); |
1d603a67 GB |
116 | |
117 | @expect = (GETC => $ob); | |
118 | $data = "abc"; | |
119 | $ch = getc $fh; | |
94c40caf | 120 | is($ch, "a"); |
1d603a67 GB |
121 | |
122 | $buf = "xyz"; | |
123 | @expect = (READ => $ob, $buf, 3); | |
124 | $data = "abc"; | |
125 | $r = read $fh,$buf,3; | |
94c40caf JH |
126 | is($r, 3); |
127 | is($buf, "abc"); | |
1d603a67 GB |
128 | |
129 | ||
130 | $buf = "xyzasd"; | |
131 | @expect = (READ => $ob, $buf, 3,3); | |
132 | $data = "abc"; | |
133 | $r = sysread $fh,$buf,3,3; | |
94c40caf JH |
134 | is($r, 3); |
135 | is($buf, "xyzabc"); | |
1d603a67 GB |
136 | |
137 | $buf = "qwerty"; | |
138 | @expect = (WRITE => $ob, $buf, 4,1); | |
139 | $data = ""; | |
140 | $r = syswrite $fh,$buf,4,1; | |
94c40caf JH |
141 | is($r, 4); |
142 | is($data, "wert"); | |
1d603a67 | 143 | |
145d37e2 GA |
144 | $buf = "qwerty"; |
145 | @expect = (WRITE => $ob, $buf, 4); | |
146 | $data = ""; | |
147 | $r = syswrite $fh,$buf,4; | |
94c40caf JH |
148 | is($r, 4); |
149 | is($data, "qwer"); | |
145d37e2 GA |
150 | |
151 | $buf = "qwerty"; | |
152 | @expect = (WRITE => $ob, $buf, 6); | |
153 | $data = ""; | |
154 | $r = syswrite $fh,$buf; | |
94c40caf JH |
155 | is($r, 6); |
156 | is($data, "qwerty"); | |
145d37e2 | 157 | |
1d603a67 GB |
158 | @expect = (CLOSE => $ob); |
159 | $r = close $fh; | |
94c40caf | 160 | is($r, 5); |
01bb7c6d DC |
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 | 166 | is($r, 1); |
01bb7c6d DC |
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 DC |
173 | @expect = (PRINT => $ob,"some","text"); |
174 | $r = print STDERR @expect[2,3]; | |
94c40caf | 175 | is($r, 1); |
01bb7c6d | 176 | } |
df646e84 JH |
177 | |
178 | { | |
3a28f3fb MS |
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 JH |
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 JH |
218 | } |
219 | $|=1; | |
220 | tie *STDIN, 'Foo'; | |
221 | read STDIN, my $buff, 1; | |
94c40caf | 222 | ::pass(); |
df646e84 JH |
223 | do_read(\*STDIN); |
224 | untie *STDIN; | |
225 | } | |
226 | ||
4ba0502e JH |
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 AT |
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 AT |
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 SG |
267 | |
268 | use warnings; | |
269 | print undef; | |
270 | ||
94c40caf | 271 | like($received[1], qr/Use of uninitialized value/); |
87582a92 AT |
272 | } |
273 | ||
0b7c7b4f HS |
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 HS |
281 | |
282 | package CHOMP; | |
283 | sub TIEHANDLE { bless {}, $_[0] } | |
284 | sub READLINE { "foobar\n" } | |
285 | } | |
94c40caf | 286 | |
32e65323 CS |
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 | } |