This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
045891dd427585ef1e19c085d043e13202809571
[perl5.git] / t / op / tiearray.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6 }
7
8 my %seen;
9
10 package Implement;
11
12 sub TIEARRAY
13 {
14  $seen{'TIEARRAY'}++;
15  my ($class,@val) = @_;
16  return bless \@val,$class;
17 }
18
19 sub STORESIZE
20 {        
21  $seen{'STORESIZE'}++;
22  my ($ob,$sz) = @_; 
23  return @$ob = $sz;
24 }
25
26 sub EXTEND
27 {        
28  $seen{'EXTEND'}++;
29  my ($ob,$sz) = @_; 
30  return @$ob = $sz;
31 }
32
33 sub FETCHSIZE
34 {        
35  $seen{'FETCHSIZE'}++;
36  my ($ob) = @_; 
37  return @$ob-1;
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  $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 }
72
73 sub POP
74 {
75  $seen{'POP'}++;
76  my ($ob) = @_;
77  return pop(@$ob);
78 }
79
80 sub SHIFT
81 {
82  $seen{'SHIFT'}++;
83  my ($ob) = @_;
84  return shift(@$ob);
85 }
86
87 sub SPLICE
88 {
89  $seen{'SPLICE'}++;
90  my $ob  = shift;                    
91  my $off = @_ ? shift : 0;
92  my $len = @_ ? shift : @$ob-1;
93  return splice(@$ob,$off,$len,@_);
94 }
95
96 package main;
97
98 print "1..23\n";                   
99 my $test = 1;
100
101 {my @ary;
102
103 { my $ob = tie @ary,'Implement',3,2,1;
104   print "not " unless $ob;
105   print "ok ", $test++,"\n";
106   print "not " unless tied(@ary) == $ob;
107   print "ok ", $test++,"\n";
108 }
109
110
111 print "not " unless @ary == 3;
112 print "ok ", $test++,"\n";
113
114 print "not " unless $#ary == 2;
115 print "ok ", $test++,"\n";
116
117 print "not " unless join(':',@ary) eq '3:2:1';
118 print "ok ", $test++,"\n";         
119
120 print "not " unless $seen{'FETCH'} >= 3;
121 print "ok ", $test++,"\n";
122
123 @ary = (1,2,3);
124
125 print "not " unless $seen{'STORE'} >= 3;
126 print "ok ", $test++,"\n";
127
128 print "not " unless join(':',@ary) eq '1:2:3';
129 print "ok ", $test++,"\n";         
130
131 print "not " unless pop(@ary) == 3;
132 print "ok ", $test++,"\n";
133 print "not " unless $seen{'POP'} == 1;
134 print "ok ", $test++,"\n";
135 print "not " unless join(':',@ary) eq '1:2';
136 print "ok ", $test++,"\n";
137
138 push(@ary,4);
139 print "not " unless $seen{'PUSH'} == 1;
140 print "ok ", $test++,"\n";
141 print "not " unless join(':',@ary) eq '1:2:4';
142 print "ok ", $test++,"\n";
143
144 my @x = splice(@ary,1,1,7);
145
146
147 print "not " unless $seen{'SPLICE'} == 1;
148 print "ok ", $test++,"\n";
149
150 print "not " unless @x == 1;
151 print "ok ", $test++,"\n";
152 print "not " unless $x[0] == 2;
153 print "ok ", $test++,"\n";
154 print "not " unless join(':',@ary) eq '1:7:4';
155 print "ok ", $test++,"\n";             
156
157
158
159 print "not " unless shift(@ary) == 1;
160 print "ok ", $test++,"\n";
161 print "not " unless $seen{'SHIFT'} == 1;
162 print "ok ", $test++,"\n";
163 print "not " unless join(':',@ary) eq '7:4';
164 print "ok ", $test++,"\n";             
165
166
167 unshift(@ary,5);
168 print "not " unless $seen{'UNSHIFT'} == 1;
169 print "ok ", $test++,"\n";
170 print "not " unless join(':',@ary) eq '5:7:4';
171 print "ok ", $test++,"\n";
172
173 @ary = split(/:/,'1:2:3');
174 print "not " unless join(':',@ary) eq '1:2:3';
175 print "ok ", $test++,"\n";         
176
177 # untie @ary;   
178
179 }
180
181
182
183