1#!./perl -w
2
3BEGIN {
4    chdir 't' if -d 't';
5    require './test.pl';
6    set_up_inc(qw '../lib ../dist/base/lib');
7}
8
9my @expect;
10my $data = "";
11my @data = ();
12
13plan(tests => 67);
14
15sub compare {
16    local $Level = $Level + 1;
17
18    return unless @expect;
19    return ::fail() unless(@_ == @expect);
20
21    for my $i (0..$#_) {
22	next if $_[$i] eq $expect[$i];
23	return ::fail();
24    }
25
26    ::pass();
27}
28
29
30package Implement;
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 EOF {
65    ::compare(EOF => @_);
66    @data ? '' : 1;
67}
68
69sub WRITE {
70    ::compare(WRITE => @_);
71    $data = substr($_[1],$_[3] || 0, $_[2]);
72    length($data);
73}
74
75sub CLOSE {
76    ::compare(CLOSE => @_);
77    5;
78}
79
80package main;
81
82use Symbol;
83
84my $fh = gensym;
85
86@expect = (TIEHANDLE => 'Implement');
87my $ob = tie *$fh,'Implement';
88is(ref($ob),  'Implement');
89is(tied(*$fh), $ob);
90
91@expect = (PRINT => $ob,"some","text");
92$r = print $fh @expect[2,3];
93is($r, 1);
94
95@expect = (PRINTF => $ob,"%s","text");
96$r = printf $fh @expect[2,3];
97is($r, 2);
98
99@data = ("the line\n");
100@expect = (EOF => $ob, 1);
101is(eof($fh), '');
102
103$text = $data[0];
104@expect = (READLINE => $ob);
105$ln = <$fh>;
106is($ln, $text);
107
108@expect = (EOF => $ob, 0);
109is(eof, 1);
110
111@expect = ();
112@in = @data = qw(a line at a time);
113@line = <$fh>;
114@expect = @in;
115compare(@line);
116
117@expect = (GETC => $ob);
118$data = "abc";
119$ch = getc $fh;
120is($ch, "a");
121
122$buf = "xyz";
123@expect = (READ => $ob, $buf, 3);
124$data = "abc";
125$r = read $fh,$buf,3;
126is($r, 3);
127is($buf, "abc");
128
129
130$buf = "xyzasd";
131@expect = (READ => $ob, $buf, 3,3);
132$data = "abc";
133$r = sysread $fh,$buf,3,3;
134is($r, 3);
135is($buf, "xyzabc");
136
137$buf = "qwerty";
138@expect = (WRITE => $ob, $buf, 4,1);
139$data = "";
140$r = syswrite $fh,$buf,4,1;
141is($r, 4);
142is($data, "wert");
143
144$buf = "qwerty";
145@expect = (WRITE => $ob, $buf, 4);
146$data = "";
147$r = syswrite $fh,$buf,4;
148is($r, 4);
149is($data, "qwer");
150
151$buf = "qwerty";
152@expect = (WRITE => $ob, $buf, 6);
153$data = "";
154$r = syswrite $fh,$buf;
155is($r, 6);
156is($data, "qwerty");
157
158@expect = (CLOSE => $ob);
159$r = close $fh;
160is($r, 5);
161
162# Does aliasing work with tied FHs?
163*ALIAS = *$fh;
164@expect = (PRINT => $ob,"some","text");
165$r = print ALIAS @expect[2,3];
166is($r, 1);
167
168{
169    use warnings;
170    # Special case of aliasing STDERR, which used
171    # to dump core when warnings were enabled
172    local *STDERR = *$fh;
173    @expect = (PRINT => $ob,"some","text");
174    $r = print STDERR @expect[2,3];
175    is($r, 1);
176}
177
178{
179    package Bar::Say;
180    use feature 'say';
181    use base qw(Implement);
182
183    my $ors;
184    sub PRINT     {
185        $ors = $\;
186        my $self = shift;
187        return $self->SUPER::PRINT(@_);
188    }
189
190    my $fh = Symbol::gensym;
191    @expect = (TIEHANDLE => 'Bar::Say');
192    ::ok( my $obj = tie *$fh, 'Bar::Say' );
193
194    local $\ = 'something';
195    @expect = (PRINT => $obj, "stuff", "and", "things");
196    ::ok( print $fh @expect[2..4] );
197    ::is( $ors, 'something' );
198
199    ::ok( say $fh @expect[2..4] );
200    ::is( $ors, "\n",        'say sets $\ to \n in PRINT' );
201    ::is( $\,   "something", "  and it's localized" );
202
203    local $\;
204    ::ok( say $fh @expect[2..4] );
205    ::is( $ors, "\n",        'say sets $\ to \n in PRINT' );
206    ::is( $\,   undef, "  and it's localized, even for undef \$\\" );
207}
208
209{
210    # Test for change #11536
211    package Foo;
212    use strict;
213    sub TIEHANDLE { bless {} }
214    my $cnt = 'a';
215    sub READ {
216	$_[1] = $cnt++;
217	1;
218    }
219    sub do_read {
220	my $fh = shift;
221	read $fh, my $buff, 1;
222	::pass();
223    }
224    $|=1;
225    tie *STDIN, 'Foo';
226    read STDIN, my $buff, 1;
227    ::pass();
228    do_read(\*STDIN);
229    untie *STDIN;
230}
231
232
233{
234    # test for change 11639: Can't localize *FH, then tie it
235    {
236	local *foo;
237	tie %foo, 'Blah';
238    }
239    ok(!tied %foo);
240
241    {
242	local *bar;
243	tie @bar, 'Blah';
244    }
245    ok(!tied @bar);
246
247    {
248	local *BAZ;
249	tie *BAZ, 'Blah';
250    }
251    ok(!tied *BAZ);
252
253    package Blah;
254
255    sub TIEHANDLE {bless {}}
256    sub TIEHASH   {bless {}}
257    sub TIEARRAY  {bless {}}
258}
259
260{
261    # warnings should pass to the PRINT method of tied STDERR
262    my @received;
263
264    local *STDERR = *$fh;
265    no warnings 'redefine';
266    local *Implement::PRINT = sub { @received = @_ };
267
268    $r = warn("some", "text", "\n");
269    @expect = (PRINT => $ob,"sometext\n");
270
271    compare(PRINT => @received);
272
273    use warnings;
274    print undef;
275
276    like($received[1], qr/Use of uninitialized value/);
277}
278
279{
280    # [ID 20020713.001 (#10048)] chomp($data=<tied_fh>)
281    local *TEST;
282    tie *TEST, 'CHOMP';
283    my $data;
284    chomp($data = <TEST>);
285    is($data, 'foobar');
286
287    package CHOMP;
288    sub TIEHANDLE { bless {}, $_[0] }
289    sub READLINE { "foobar\n" }
290}
291
292{
293    # make sure the new eof() features work with @ARGV magic
294    local *ARGV;
295    @ARGV = ('haha');
296
297    @expect = (TIEHANDLE => 'Implement');
298    $ob = tie *ARGV, 'Implement';
299    is(ref($ob),  'Implement');
300    is(tied(*ARGV), $ob);
301
302    @data = ("stuff\n");
303    @expect = (EOF => $ob, 1);
304    is(eof(ARGV), '');
305    @expect = (EOF => $ob, 2);
306    is(eof(), '');
307    shift @data;
308    @expect = (EOF => $ob, 0);
309    is(eof, 1);
310}
311