Commit | Line | Data |
1d603a67 |
1 | #!./perl |
2 | |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
93430cb4 |
5 | unshift @INC, '../lib'; |
1d603a67 |
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 |
68 | } |
69 | |
70 | sub CLOSE { |
71 | compare(CLOSE => @_); |
72 | |
73 | 5; |
74 | } |
75 | |
76 | package main; |
77 | |
78 | use Symbol; |
79 | |
145d37e2 |
80 | print "1..29\n"; |
1d603a67 |
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 |
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 |
149 | @expect = (CLOSE => $ob); |
150 | $r = close $fh; |
151 | ok($r == 5); |