Suppress a few compilation warnings in pp_hot.c.
[p5sagit/p5-mst-13.2.git] / t / op / tiehandle.t
CommitLineData
1d603a67 1#!./perl
2
3BEGIN {
4 chdir 't' if -d 't';
20822f61 5 @INC = '../lib';
1d603a67 6}
7
8my @expect;
9my $data = "";
10my @data = ();
11my $test = 1;
12
13sub ok { print "not " unless shift; print "ok ",$test++,"\n"; }
14
15package Implement;
16
17BEGIN { *ok = \*main::ok }
18
19sub 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
32sub TIEHANDLE {
33 compare(TIEHANDLE => @_);
34 my ($class,@val) = @_;
35 return bless \@val,$class;
36}
37
38sub PRINT {
39 compare(PRINT => @_);
40 1;
41}
42
43sub PRINTF {
44 compare(PRINTF => @_);
45 2;
46}
47
48sub READLINE {
49 compare(READLINE => @_);
50 wantarray ? @data : shift @data;
51}
52
53sub GETC {
54 compare(GETC => @_);
55 substr($data,0,1);
56}
57
58sub READ {
59 compare(READ => @_);
60 substr($_[1],$_[3] || 0) = substr($data,0,$_[2]);
61 3;
62}
63
64sub WRITE {
65 compare(WRITE => @_);
66 $data = substr($_[1],$_[3] || 0, $_[2]);
145d37e2 67 length($data);
1d603a67 68}
69
70sub CLOSE {
71 compare(CLOSE => @_);
72
73 5;
74}
75
76package main;
77
78use Symbol;
79
0b7c7b4f 80print "1..40\n";
1d603a67 81
82my $fh = gensym;
83
84@expect = (TIEHANDLE => 'Implement');
85my $ob = tie *$fh,'Implement';
86ok(ref($ob) eq 'Implement');
87ok(tied(*$fh) == $ob);
88
89@expect = (PRINT => $ob,"some","text");
90$r = print $fh @expect[2,3];
91ok($r == 1);
92
93@expect = (PRINTF => $ob,"%s","text");
94$r = printf $fh @expect[2,3];
95ok($r == 2);
96
97$text = (@data = ("the line\n"))[0];
98@expect = (READLINE => $ob);
99$ln = <$fh>;
100ok($ln eq $text);
101
102@expect = ();
103@in = @data = qw(a line at a time);
104@line = <$fh>;
105@expect = @in;
106Implement::compare(@line);
107
108@expect = (GETC => $ob);
109$data = "abc";
110$ch = getc $fh;
111ok($ch eq "a");
112
113$buf = "xyz";
114@expect = (READ => $ob, $buf, 3);
115$data = "abc";
116$r = read $fh,$buf,3;
117ok($r == 3);
118ok($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;
125ok($r == 3);
126ok($buf eq "xyzabc");
127
128$buf = "qwerty";
129@expect = (WRITE => $ob, $buf, 4,1);
130$data = "";
131$r = syswrite $fh,$buf,4,1;
132ok($r == 4);
133ok($data eq "wert");
134
145d37e2 135$buf = "qwerty";
136@expect = (WRITE => $ob, $buf, 4);
137$data = "";
138$r = syswrite $fh,$buf,4;
139ok($r == 4);
140ok($data eq "qwer");
141
142$buf = "qwerty";
143@expect = (WRITE => $ob, $buf, 6);
144$data = "";
145$r = syswrite $fh,$buf;
146ok($r == 6);
147ok($data eq "qwerty");
148
1d603a67 149@expect = (CLOSE => $ob);
150$r = close $fh;
151ok($r == 5);
01bb7c6d 152
153# Does aliasing work with tied FHs?
154*ALIAS = *$fh;
155@expect = (PRINT => $ob,"some","text");
156$r = print ALIAS @expect[2,3];
157ok($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 164 @expect = (PRINT => $ob,"some","text");
165 $r = print STDERR @expect[2,3];
166 ok($r == 1);
167}
df646e84 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 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 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 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}