Commit | Line | Data |
93965878 |
1 | #!./perl |
2 | |
a60c0954 |
3 | |
93965878 |
4 | BEGIN { |
5 | chdir 't' if -d 't'; |
93430cb4 |
6 | unshift @INC, '../lib'; |
93965878 |
7 | } |
8 | |
9 | my %seen; |
10 | |
11 | package Implement; |
12 | |
13 | sub TIEARRAY |
14 | { |
15 | $seen{'TIEARRAY'}++; |
16 | my ($class,@val) = @_; |
17 | return bless \@val,$class; |
18 | } |
19 | |
20 | sub STORESIZE |
21 | { |
22 | $seen{'STORESIZE'}++; |
23 | my ($ob,$sz) = @_; |
a60c0954 |
24 | return $#{$ob} = $sz-1; |
93965878 |
25 | } |
26 | |
27 | sub EXTEND |
28 | { |
29 | $seen{'EXTEND'}++; |
30 | my ($ob,$sz) = @_; |
31 | return @$ob = $sz; |
32 | } |
33 | |
34 | sub FETCHSIZE |
35 | { |
36 | $seen{'FETCHSIZE'}++; |
a60c0954 |
37 | return scalar(@{$_[0]}); |
93965878 |
38 | } |
39 | |
40 | sub FETCH |
41 | { |
42 | $seen{'FETCH'}++; |
43 | my ($ob,$id) = @_; |
44 | return $ob->[$id]; |
45 | } |
46 | |
47 | sub STORE |
48 | { |
49 | $seen{'STORE'}++; |
50 | my ($ob,$id,$val) = @_; |
51 | $ob->[$id] = $val; |
52 | } |
53 | |
54 | sub UNSHIFT |
55 | { |
56 | $seen{'UNSHIFT'}++; |
a60c0954 |
57 | my $ob = shift; |
93965878 |
58 | unshift(@$ob,@_); |
59 | } |
60 | |
61 | sub PUSH |
62 | { |
63 | $seen{'PUSH'}++; |
64 | my $ob = shift;; |
65 | push(@$ob,@_); |
66 | } |
67 | |
68 | sub CLEAR |
69 | { |
70 | $seen{'CLEAR'}++; |
a60c0954 |
71 | @{$_[0]} = (); |
72 | } |
73 | |
74 | sub DESTROY |
75 | { |
76 | $seen{'DESTROY'}++; |
93965878 |
77 | } |
78 | |
79 | sub POP |
80 | { |
81 | $seen{'POP'}++; |
82 | my ($ob) = @_; |
83 | return pop(@$ob); |
84 | } |
85 | |
86 | sub SHIFT |
87 | { |
88 | $seen{'SHIFT'}++; |
89 | my ($ob) = @_; |
90 | return shift(@$ob); |
91 | } |
92 | |
93 | sub SPLICE |
94 | { |
95 | $seen{'SPLICE'}++; |
96 | my $ob = shift; |
97 | my $off = @_ ? shift : 0; |
98 | my $len = @_ ? shift : @$ob-1; |
99 | return splice(@$ob,$off,$len,@_); |
100 | } |
101 | |
102 | package main; |
103 | |
8ec5e241 |
104 | print "1..31\n"; |
93965878 |
105 | my $test = 1; |
106 | |
107 | {my @ary; |
108 | |
109 | { my $ob = tie @ary,'Implement',3,2,1; |
110 | print "not " unless $ob; |
111 | print "ok ", $test++,"\n"; |
112 | print "not " unless tied(@ary) == $ob; |
113 | print "ok ", $test++,"\n"; |
114 | } |
115 | |
116 | |
117 | print "not " unless @ary == 3; |
118 | print "ok ", $test++,"\n"; |
119 | |
120 | print "not " unless $#ary == 2; |
121 | print "ok ", $test++,"\n"; |
122 | |
123 | print "not " unless join(':',@ary) eq '3:2:1'; |
124 | print "ok ", $test++,"\n"; |
125 | |
126 | print "not " unless $seen{'FETCH'} >= 3; |
127 | print "ok ", $test++,"\n"; |
128 | |
129 | @ary = (1,2,3); |
130 | |
131 | print "not " unless $seen{'STORE'} >= 3; |
132 | print "ok ", $test++,"\n"; |
93965878 |
133 | print "not " unless join(':',@ary) eq '1:2:3'; |
134 | print "ok ", $test++,"\n"; |
135 | |
1c0b011c |
136 | {my @thing = @ary; |
137 | print "not " unless join(':',@thing) eq '1:2:3'; |
138 | print "ok ", $test++,"\n"; |
139 | |
140 | tie @thing,'Implement'; |
141 | @thing = @ary; |
142 | print "not " unless join(':',@thing) eq '1:2:3'; |
143 | print "ok ", $test++,"\n"; |
144 | } |
145 | |
93965878 |
146 | print "not " unless pop(@ary) == 3; |
147 | print "ok ", $test++,"\n"; |
148 | print "not " unless $seen{'POP'} == 1; |
149 | print "ok ", $test++,"\n"; |
150 | print "not " unless join(':',@ary) eq '1:2'; |
151 | print "ok ", $test++,"\n"; |
152 | |
153 | push(@ary,4); |
154 | print "not " unless $seen{'PUSH'} == 1; |
155 | print "ok ", $test++,"\n"; |
156 | print "not " unless join(':',@ary) eq '1:2:4'; |
157 | print "ok ", $test++,"\n"; |
158 | |
159 | my @x = splice(@ary,1,1,7); |
160 | |
161 | |
162 | print "not " unless $seen{'SPLICE'} == 1; |
163 | print "ok ", $test++,"\n"; |
164 | |
165 | print "not " unless @x == 1; |
166 | print "ok ", $test++,"\n"; |
167 | print "not " unless $x[0] == 2; |
168 | print "ok ", $test++,"\n"; |
169 | print "not " unless join(':',@ary) eq '1:7:4'; |
170 | print "ok ", $test++,"\n"; |
171 | |
93965878 |
172 | print "not " unless shift(@ary) == 1; |
173 | print "ok ", $test++,"\n"; |
174 | print "not " unless $seen{'SHIFT'} == 1; |
175 | print "ok ", $test++,"\n"; |
176 | print "not " unless join(':',@ary) eq '7:4'; |
177 | print "ok ", $test++,"\n"; |
178 | |
a60c0954 |
179 | my $n = unshift(@ary,5,6); |
93965878 |
180 | print "not " unless $seen{'UNSHIFT'} == 1; |
181 | print "ok ", $test++,"\n"; |
a60c0954 |
182 | print "not " unless $n == 4; |
183 | print "ok ", $test++,"\n"; |
184 | print "not " unless join(':',@ary) eq '5:6:7:4'; |
93965878 |
185 | print "ok ", $test++,"\n"; |
186 | |
187 | @ary = split(/:/,'1:2:3'); |
188 | print "not " unless join(':',@ary) eq '1:2:3'; |
189 | print "ok ", $test++,"\n"; |
a60c0954 |
190 | |
191 | my $t = 0; |
192 | foreach $n (@ary) |
193 | { |
194 | print "not " unless $n == ++$t; |
195 | print "ok ", $test++,"\n"; |
196 | } |
197 | |
198 | @ary = qw(3 2 1); |
199 | print "not " unless join(':',@ary) eq '3:2:1'; |
200 | print "ok ", $test++,"\n"; |
93965878 |
201 | |
a60c0954 |
202 | untie @ary; |
93965878 |
203 | |
204 | } |
a60c0954 |
205 | |
1c0b011c |
206 | print "not " unless $seen{'DESTROY'} == 2; |
a60c0954 |
207 | print "ok ", $test++,"\n"; |
93965878 |
208 | |
209 | |
210 | |