Commit | Line | Data |
---|---|---|
93965878 NIS |
1 | #!./perl |
2 | ||
a60c0954 | 3 | |
93965878 NIS |
4 | BEGIN { |
5 | chdir 't' if -d 't'; | |
6 | @INC = '../lib'; | |
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 NIS |
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 NIS |
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 NIS |
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 NIS |
71 | @{$_[0]} = (); |
72 | } | |
73 | ||
74 | sub DESTROY | |
75 | { | |
76 | $seen{'DESTROY'}++; | |
93965878 NIS |
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 NIS |
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 NIS |
133 | print "not " unless join(':',@ary) eq '1:2:3'; |
134 | print "ok ", $test++,"\n"; | |
135 | ||
1c0b011c NIS |
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 NIS |
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 NIS |
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 NIS |
180 | print "not " unless $seen{'UNSHIFT'} == 1; |
181 | print "ok ", $test++,"\n"; | |
a60c0954 NIS |
182 | print "not " unless $n == 4; |
183 | print "ok ", $test++,"\n"; | |
184 | print "not " unless join(':',@ary) eq '5:6:7:4'; | |
93965878 NIS |
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 NIS |
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 NIS |
203 | |
204 | } | |
a60c0954 | 205 | |
1c0b011c | 206 | print "not " unless $seen{'DESTROY'} == 2; |
a60c0954 | 207 | print "ok ", $test++,"\n"; |
93965878 NIS |
208 | |
209 | ||
210 |