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