Add more known sprintf failures.
[p5sagit/p5-mst-13.2.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..31\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 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";         
201
202 untie @ary;   
203
204 }
205                            
206 print "not " unless $seen{'DESTROY'} == 2;
207 print "ok ", $test++,"\n";         
208
209
210