Commit | Line | Data |
94c40caf |
1 | #!./perl -w |
1d603a67 |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
20822f61 |
5 | @INC = '../lib'; |
1d603a67 |
6 | } |
7 | |
8 | my @expect; |
9 | my $data = ""; |
10 | my @data = (); |
1d603a67 |
11 | |
94c40caf |
12 | require './test.pl'; |
3a28f3fb |
13 | plan(tests => 50); |
1d603a67 |
14 | |
15 | sub 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 | |
30 | package Implement; |
31 | |
1d603a67 |
32 | sub TIEHANDLE { |
94c40caf |
33 | ::compare(TIEHANDLE => @_); |
1d603a67 |
34 | my ($class,@val) = @_; |
35 | return bless \@val,$class; |
36 | } |
37 | |
38 | sub PRINT { |
94c40caf |
39 | ::compare(PRINT => @_); |
1d603a67 |
40 | 1; |
41 | } |
42 | |
43 | sub PRINTF { |
94c40caf |
44 | ::compare(PRINTF => @_); |
1d603a67 |
45 | 2; |
46 | } |
47 | |
48 | sub READLINE { |
94c40caf |
49 | ::compare(READLINE => @_); |
1d603a67 |
50 | wantarray ? @data : shift @data; |
51 | } |
52 | |
53 | sub GETC { |
94c40caf |
54 | ::compare(GETC => @_); |
1d603a67 |
55 | substr($data,0,1); |
56 | } |
57 | |
58 | sub READ { |
94c40caf |
59 | ::compare(READ => @_); |
1d603a67 |
60 | substr($_[1],$_[3] || 0) = substr($data,0,$_[2]); |
61 | 3; |
62 | } |
63 | |
64 | sub WRITE { |
94c40caf |
65 | ::compare(WRITE => @_); |
1d603a67 |
66 | $data = substr($_[1],$_[3] || 0, $_[2]); |
145d37e2 |
67 | length($data); |
1d603a67 |
68 | } |
69 | |
70 | sub CLOSE { |
94c40caf |
71 | ::compare(CLOSE => @_); |
1d603a67 |
72 | |
73 | 5; |
74 | } |
75 | |
76 | package main; |
77 | |
78 | use Symbol; |
79 | |
1d603a67 |
80 | my $fh = gensym; |
81 | |
82 | @expect = (TIEHANDLE => 'Implement'); |
83 | my $ob = tie *$fh,'Implement'; |
94c40caf |
84 | is(ref($ob), 'Implement'); |
85 | is(tied(*$fh), $ob); |
1d603a67 |
86 | |
87 | @expect = (PRINT => $ob,"some","text"); |
88 | $r = print $fh @expect[2,3]; |
94c40caf |
89 | is($r, 1); |
1d603a67 |
90 | |
91 | @expect = (PRINTF => $ob,"%s","text"); |
92 | $r = printf $fh @expect[2,3]; |
94c40caf |
93 | is($r, 2); |
1d603a67 |
94 | |
95 | $text = (@data = ("the line\n"))[0]; |
96 | @expect = (READLINE => $ob); |
97 | $ln = <$fh>; |
94c40caf |
98 | is($ln, $text); |
1d603a67 |
99 | |
100 | @expect = (); |
101 | @in = @data = qw(a line at a time); |
102 | @line = <$fh>; |
103 | @expect = @in; |
94c40caf |
104 | compare(@line); |
1d603a67 |
105 | |
106 | @expect = (GETC => $ob); |
107 | $data = "abc"; |
108 | $ch = getc $fh; |
94c40caf |
109 | is($ch, "a"); |
1d603a67 |
110 | |
111 | $buf = "xyz"; |
112 | @expect = (READ => $ob, $buf, 3); |
113 | $data = "abc"; |
114 | $r = read $fh,$buf,3; |
94c40caf |
115 | is($r, 3); |
116 | is($buf, "abc"); |
1d603a67 |
117 | |
118 | |
119 | $buf = "xyzasd"; |
120 | @expect = (READ => $ob, $buf, 3,3); |
121 | $data = "abc"; |
122 | $r = sysread $fh,$buf,3,3; |
94c40caf |
123 | is($r, 3); |
124 | is($buf, "xyzabc"); |
1d603a67 |
125 | |
126 | $buf = "qwerty"; |
127 | @expect = (WRITE => $ob, $buf, 4,1); |
128 | $data = ""; |
129 | $r = syswrite $fh,$buf,4,1; |
94c40caf |
130 | is($r, 4); |
131 | is($data, "wert"); |
1d603a67 |
132 | |
145d37e2 |
133 | $buf = "qwerty"; |
134 | @expect = (WRITE => $ob, $buf, 4); |
135 | $data = ""; |
136 | $r = syswrite $fh,$buf,4; |
94c40caf |
137 | is($r, 4); |
138 | is($data, "qwer"); |
145d37e2 |
139 | |
140 | $buf = "qwerty"; |
141 | @expect = (WRITE => $ob, $buf, 6); |
142 | $data = ""; |
143 | $r = syswrite $fh,$buf; |
94c40caf |
144 | is($r, 6); |
145 | is($data, "qwerty"); |
145d37e2 |
146 | |
1d603a67 |
147 | @expect = (CLOSE => $ob); |
148 | $r = close $fh; |
94c40caf |
149 | is($r, 5); |
01bb7c6d |
150 | |
151 | # Does aliasing work with tied FHs? |
152 | *ALIAS = *$fh; |
153 | @expect = (PRINT => $ob,"some","text"); |
154 | $r = print ALIAS @expect[2,3]; |
94c40caf |
155 | is($r, 1); |
01bb7c6d |
156 | |
157 | { |
158 | use warnings; |
159 | # Special case of aliasing STDERR, which used |
160 | # to dump core when warnings were enabled |
87582a92 |
161 | local *STDERR = *$fh; |
01bb7c6d |
162 | @expect = (PRINT => $ob,"some","text"); |
163 | $r = print STDERR @expect[2,3]; |
94c40caf |
164 | is($r, 1); |
01bb7c6d |
165 | } |
df646e84 |
166 | |
167 | { |
3a28f3fb |
168 | package Bar::Say; |
169 | use feature 'say'; |
170 | use base qw(Implement); |
171 | |
172 | my $ors; |
173 | sub PRINT { |
174 | $ors = $\; |
175 | my $self = shift; |
176 | return $self->SUPER::PRINT(@_); |
177 | } |
178 | |
179 | my $fh = Symbol::gensym; |
180 | @expect = (TIEHANDLE => 'Bar::Say'); |
181 | ::ok( my $obj = tie *$fh, 'Bar::Say' ); |
182 | |
183 | local $\ = 'something'; |
184 | @expect = (PRINT => $obj, "stuff", "and", "things"); |
185 | ::ok( print $fh @expect[2..4] ); |
186 | ::is( $ors, 'something' ); |
187 | |
188 | ::ok( say $fh @expect[2..4] ); |
189 | ::is( $ors, "\n", 'say sets $\ to \n in PRINT' ); |
190 | ::is( $\, "something", " and it's localized" ); |
191 | } |
192 | |
193 | { |
df646e84 |
194 | # Test for change #11536 |
195 | package Foo; |
196 | use strict; |
197 | sub TIEHANDLE { bless {} } |
198 | my $cnt = 'a'; |
199 | sub READ { |
200 | $_[1] = $cnt++; |
201 | 1; |
202 | } |
203 | sub do_read { |
204 | my $fh = shift; |
205 | read $fh, my $buff, 1; |
94c40caf |
206 | ::pass(); |
df646e84 |
207 | } |
208 | $|=1; |
209 | tie *STDIN, 'Foo'; |
210 | read STDIN, my $buff, 1; |
94c40caf |
211 | ::pass(); |
df646e84 |
212 | do_read(\*STDIN); |
213 | untie *STDIN; |
214 | } |
215 | |
4ba0502e |
216 | |
217 | { |
218 | # test for change 11639: Can't localize *FH, then tie it |
219 | { |
220 | local *foo; |
221 | tie %foo, 'Blah'; |
222 | } |
223 | ok(!tied %foo); |
224 | |
225 | { |
226 | local *bar; |
227 | tie @bar, 'Blah'; |
228 | } |
229 | ok(!tied @bar); |
230 | |
231 | { |
232 | local *BAZ; |
233 | tie *BAZ, 'Blah'; |
234 | } |
235 | ok(!tied *BAZ); |
236 | |
237 | package Blah; |
238 | |
239 | sub TIEHANDLE {bless {}} |
240 | sub TIEHASH {bless {}} |
241 | sub TIEARRAY {bless {}} |
242 | } |
243 | |
87582a92 |
244 | { |
245 | # warnings should pass to the PRINT method of tied STDERR |
246 | my @received; |
247 | |
248 | local *STDERR = *$fh; |
94c40caf |
249 | no warnings 'redefine'; |
87582a92 |
250 | local *Implement::PRINT = sub { @received = @_ }; |
251 | |
252 | $r = warn("some", "text", "\n"); |
253 | @expect = (PRINT => $ob,"sometext\n"); |
254 | |
94c40caf |
255 | compare(PRINT => @received); |
7ff03255 |
256 | |
257 | use warnings; |
258 | print undef; |
259 | |
94c40caf |
260 | like($received[1], qr/Use of uninitialized value/); |
87582a92 |
261 | } |
262 | |
0b7c7b4f |
263 | { |
264 | # [ID 20020713.001] chomp($data=<tied_fh>) |
265 | local *TEST; |
266 | tie *TEST, 'CHOMP'; |
267 | my $data; |
268 | chomp($data = <TEST>); |
94c40caf |
269 | is($data, 'foobar'); |
0b7c7b4f |
270 | |
271 | package CHOMP; |
272 | sub TIEHANDLE { bless {}, $_[0] } |
273 | sub READLINE { "foobar\n" } |
274 | } |
94c40caf |
275 | |