This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
337aff689af399e1ad339470dc4dd4324c2e06f4
[perl5.git] / t / op / tiearray.t
1 #!./perl
2
3
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) = @_; 
24  return $#{$ob} = $sz-1;
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'}++;
37  return scalar(@{$_[0]});
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'}++;
57  my $ob = shift;
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'}++;
71  @{$_[0]} = ();
72 }
73
74 sub DESTROY
75 {
76  $seen{'DESTROY'}++;
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
104 print "1..36\n";                   
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";
133 print "not " unless join(':',@ary) eq '1:2:3';
134 print "ok ", $test++,"\n";         
135
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
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
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
179 my $n = unshift(@ary,5,6);
180 print "not " unless $seen{'UNSHIFT'} == 1;
181 print "ok ", $test++,"\n";
182 print "not " unless $n == 4;
183 print "ok ", $test++,"\n";
184 print "not " unless join(':',@ary) eq '5:6:7:4';
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";         
190
191   
192 my $t = 0;
193 foreach $n (@ary)
194  {
195   print "not " unless $n == ++$t;
196   print "ok ", $test++,"\n";         
197  }
198
199 # (30-33) 20020303 mjd-perl-patch+@plover.com
200 @ary = ();
201 $seen{POP} = 0;
202 pop @ary;                       # this didn't used to call POP at all
203 print "not " unless $seen{POP} == 1;
204 print "ok ", $test++,"\n";         
205 $seen{SHIFT} = 0;
206 shift @ary;                     # this didn't used to call SHIFT at  all
207 print "not " unless $seen{SHIFT} == 1;
208 print "ok ", $test++,"\n";         
209 $seen{PUSH} = 0;
210 push @ary;                       # this didn't used to call PUSH at all
211 print "not " unless $seen{PUSH} == 1;
212 print "ok ", $test++,"\n";         
213 $seen{UNSHIFT} = 0;
214 unshift @ary;                   # this didn't used to call UNSHIFT at all
215 print "not " unless $seen{UNSHIFT} == 1;
216 print "ok ", $test++,"\n";         
217
218 @ary = qw(3 2 1);
219 print "not " unless join(':',@ary) eq '3:2:1';
220 print "ok ", $test++,"\n";         
221
222 untie @ary;   
223
224 }
225
226 # 20020401 mjd-perl-patch+@plover.com
227 # Thanks to Dave Mitchell for the small test case and the fix
228 {
229   my @a;
230   
231   sub X::TIEARRAY { bless {}, 'X' }
232
233   sub X::SPLICE {
234     do '/dev/null';
235     die;
236   }
237
238   tie @a, 'X';
239   eval { splice(@a) };
240   # If we survived this far.
241   print "ok ", $test++, "\n";
242 }
243                            
244 print "not " unless $seen{'DESTROY'} == 2;
245 print "ok ", $test++,"\n";         
246