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 | ||
01bb7c6d | 80 | print "1..33\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 | |
163 | *STDERR = *$fh; | |
164 | @expect = (PRINT => $ob,"some","text"); | |
165 | $r = print STDERR @expect[2,3]; | |
166 | ok($r == 1); | |
167 | } |