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