Small optimisations, by Brandon Black
[p5sagit/p5-mst-13.2.git] / t / op / tiehandle.t
CommitLineData
94c40caf 1#!./perl -w
1d603a67 2
3BEGIN {
4 chdir 't' if -d 't';
20822f61 5 @INC = '../lib';
1d603a67 6}
7
8my @expect;
9my $data = "";
10my @data = ();
1d603a67 11
94c40caf 12require './test.pl';
13plan(tests => 41);
1d603a67 14
15sub 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 22 }
23
94c40caf 24 ::pass();
1d603a67 25}
26
94c40caf 27
28package Implement;
29
1d603a67 30sub TIEHANDLE {
94c40caf 31 ::compare(TIEHANDLE => @_);
1d603a67 32 my ($class,@val) = @_;
33 return bless \@val,$class;
34}
35
36sub PRINT {
94c40caf 37 ::compare(PRINT => @_);
1d603a67 38 1;
39}
40
41sub PRINTF {
94c40caf 42 ::compare(PRINTF => @_);
1d603a67 43 2;
44}
45
46sub READLINE {
94c40caf 47 ::compare(READLINE => @_);
1d603a67 48 wantarray ? @data : shift @data;
49}
50
51sub GETC {
94c40caf 52 ::compare(GETC => @_);
1d603a67 53 substr($data,0,1);
54}
55
56sub READ {
94c40caf 57 ::compare(READ => @_);
1d603a67 58 substr($_[1],$_[3] || 0) = substr($data,0,$_[2]);
59 3;
60}
61
62sub WRITE {
94c40caf 63 ::compare(WRITE => @_);
1d603a67 64 $data = substr($_[1],$_[3] || 0, $_[2]);
145d37e2 65 length($data);
1d603a67 66}
67
68sub CLOSE {
94c40caf 69 ::compare(CLOSE => @_);
1d603a67 70
71 5;
72}
73
74package main;
75
76use Symbol;
77
1d603a67 78my $fh = gensym;
79
80@expect = (TIEHANDLE => 'Implement');
81my $ob = tie *$fh,'Implement';
94c40caf 82is(ref($ob), 'Implement');
83is(tied(*$fh), $ob);
1d603a67 84
85@expect = (PRINT => $ob,"some","text");
86$r = print $fh @expect[2,3];
94c40caf 87is($r, 1);
1d603a67 88
89@expect = (PRINTF => $ob,"%s","text");
90$r = printf $fh @expect[2,3];
94c40caf 91is($r, 2);
1d603a67 92
93$text = (@data = ("the line\n"))[0];
94@expect = (READLINE => $ob);
95$ln = <$fh>;
94c40caf 96is($ln, $text);
1d603a67 97
98@expect = ();
99@in = @data = qw(a line at a time);
100@line = <$fh>;
101@expect = @in;
94c40caf 102compare(@line);
1d603a67 103
104@expect = (GETC => $ob);
105$data = "abc";
106$ch = getc $fh;
94c40caf 107is($ch, "a");
1d603a67 108
109$buf = "xyz";
110@expect = (READ => $ob, $buf, 3);
111$data = "abc";
112$r = read $fh,$buf,3;
94c40caf 113is($r, 3);
114is($buf, "abc");
1d603a67 115
116
117$buf = "xyzasd";
118@expect = (READ => $ob, $buf, 3,3);
119$data = "abc";
120$r = sysread $fh,$buf,3,3;
94c40caf 121is($r, 3);
122is($buf, "xyzabc");
1d603a67 123
124$buf = "qwerty";
125@expect = (WRITE => $ob, $buf, 4,1);
126$data = "";
127$r = syswrite $fh,$buf,4,1;
94c40caf 128is($r, 4);
129is($data, "wert");
1d603a67 130
145d37e2 131$buf = "qwerty";
132@expect = (WRITE => $ob, $buf, 4);
133$data = "";
134$r = syswrite $fh,$buf,4;
94c40caf 135is($r, 4);
136is($data, "qwer");
145d37e2 137
138$buf = "qwerty";
139@expect = (WRITE => $ob, $buf, 6);
140$data = "";
141$r = syswrite $fh,$buf;
94c40caf 142is($r, 6);
143is($data, "qwerty");
145d37e2 144
1d603a67 145@expect = (CLOSE => $ob);
146$r = close $fh;
94c40caf 147is($r, 5);
01bb7c6d 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 153is($r, 1);
01bb7c6d 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 160 @expect = (PRINT => $ob,"some","text");
161 $r = print STDERR @expect[2,3];
94c40caf 162 is($r, 1);
01bb7c6d 163}
df646e84 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 179 }
180 $|=1;
181 tie *STDIN, 'Foo';
182 read STDIN, my $buff, 1;
94c40caf 183 ::pass();
df646e84 184 do_read(\*STDIN);
185 untie *STDIN;
186}
187
4ba0502e 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 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 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 228
229 use warnings;
230 print undef;
231
94c40caf 232 like($received[1], qr/Use of uninitialized value/);
87582a92 233}
234
0b7c7b4f 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 242
243 package CHOMP;
244 sub TIEHANDLE { bless {}, $_[0] }
245 sub READLINE { "foobar\n" }
246}
94c40caf 247
248