t/io/eintr.t: Make this pass on my ppc64 box
[perl.git] / lib / Tie / Array.pm
1 package Tie::Array;
2
3 use 5.006_001;
4 use strict;
5 use Carp;
6 our $VERSION = '1.06';
7
8 # Pod documentation after __END__ below.
9
10 sub DESTROY { }
11 sub EXTEND  { }
12 sub UNSHIFT { scalar shift->SPLICE(0,0,@_) }
13 sub SHIFT { shift->SPLICE(0,1) }
14 sub CLEAR   { shift->STORESIZE(0) }
15
16 sub PUSH
17 {
18  my $obj = shift;
19  my $i   = $obj->FETCHSIZE;
20  $obj->STORE($i++, shift) while (@_);
21 }
22
23 sub POP
24 {
25  my $obj = shift;
26  my $newsize = $obj->FETCHSIZE - 1;
27  my $val;
28  if ($newsize >= 0)
29   {
30    $val = $obj->FETCH($newsize);
31    $obj->STORESIZE($newsize);
32   }
33  $val;
34 }
35
36 sub SPLICE {
37     my $obj = shift;
38     my $sz  = $obj->FETCHSIZE;
39     my $off = (@_) ? shift : 0;
40     $off += $sz if ($off < 0);
41     my $len = (@_) ? shift : $sz - $off;
42     $len += $sz - $off if $len < 0;
43     my @result;
44     for (my $i = 0; $i < $len; $i++) {
45         push(@result,$obj->FETCH($off+$i));
46     }
47     $off = $sz if $off > $sz;
48     $len -= $off + $len - $sz if $off + $len > $sz;
49     if (@_ > $len) {
50         # Move items up to make room
51         my $d = @_ - $len;
52         my $e = $off+$len;
53         $obj->EXTEND($sz+$d);
54         for (my $i=$sz-1; $i >= $e; $i--) {
55             my $val = $obj->FETCH($i);
56             $obj->STORE($i+$d,$val);
57         }
58     }
59     elsif (@_ < $len) {
60         # Move items down to close the gap
61         my $d = $len - @_;
62         my $e = $off+$len;
63         for (my $i=$off+$len; $i < $sz; $i++) {
64             my $val = $obj->FETCH($i);
65             $obj->STORE($i-$d,$val);
66         }
67         $obj->STORESIZE($sz-$d);
68     }
69     for (my $i=0; $i < @_; $i++) {
70         $obj->STORE($off+$i,$_[$i]);
71     }
72     return wantarray ? @result : pop @result;
73 }
74
75 sub EXISTS {
76     my $pkg = ref $_[0];
77     croak "$pkg doesn't define an EXISTS method";
78 }
79
80 sub DELETE {
81     my $pkg = ref $_[0];
82     croak "$pkg doesn't define a DELETE method";
83 }
84
85 package Tie::StdArray;
86 use vars qw(@ISA);
87 @ISA = 'Tie::Array';
88
89 sub TIEARRAY  { bless [], $_[0] }
90 sub FETCHSIZE { scalar @{$_[0]} }
91 sub STORESIZE { $#{$_[0]} = $_[1]-1 }
92 sub STORE     { $_[0]->[$_[1]] = $_[2] }
93 sub FETCH     { $_[0]->[$_[1]] }
94 sub CLEAR     { @{$_[0]} = () }
95 sub POP       { pop(@{$_[0]}) }
96 sub PUSH      { my $o = shift; push(@$o,@_) }
97 sub SHIFT     { shift(@{$_[0]}) }
98 sub UNSHIFT   { my $o = shift; unshift(@$o,@_) }
99 sub EXISTS    { exists $_[0]->[$_[1]] }
100 sub DELETE    { delete $_[0]->[$_[1]] }
101
102 sub SPLICE
103 {
104  my $ob  = shift;
105  my $sz  = $ob->FETCHSIZE;
106  my $off = @_ ? shift : 0;
107  $off   += $sz if $off < 0;
108  my $len = @_ ? shift : $sz-$off;
109  return splice(@$ob,$off,$len,@_);
110 }
111
112 1;
113
114 __END__
115
116 =head1 NAME
117
118 Tie::Array - base class for tied arrays
119
120 =head1 SYNOPSIS
121
122     package Tie::NewArray;
123     use Tie::Array;
124     @ISA = ('Tie::Array');
125
126     # mandatory methods
127     sub TIEARRAY { ... }
128     sub FETCH { ... }
129     sub FETCHSIZE { ... }
130
131     sub STORE { ... }       # mandatory if elements writeable
132     sub STORESIZE { ... }   # mandatory if elements can be added/deleted
133     sub EXISTS { ... }      # mandatory if exists() expected to work
134     sub DELETE { ... }      # mandatory if delete() expected to work
135
136     # optional methods - for efficiency
137     sub CLEAR { ... }
138     sub PUSH { ... }
139     sub POP { ... }
140     sub SHIFT { ... }
141     sub UNSHIFT { ... }
142     sub SPLICE { ... }
143     sub EXTEND { ... }
144     sub DESTROY { ... }
145
146     package Tie::NewStdArray;
147     use Tie::Array;
148
149     @ISA = ('Tie::StdArray');
150
151     # all methods provided by default
152
153     package main;
154
155     $object = tie @somearray,'Tie::NewArray';
156     $object = tie @somearray,'Tie::StdArray';
157     $object = tie @somearray,'Tie::NewStdArray';
158
159
160
161 =head1 DESCRIPTION
162
163 This module provides methods for array-tying classes. See
164 L<perltie> for a list of the functions required in order to tie an array
165 to a package. The basic B<Tie::Array> package provides stub C<DESTROY>,
166 and C<EXTEND> methods that do nothing, stub C<DELETE> and C<EXISTS>
167 methods that croak() if the delete() or exists() builtins are ever called
168 on the tied array, and implementations of C<PUSH>, C<POP>, C<SHIFT>,
169 C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>,
170 C<FETCHSIZE>, C<STORESIZE>.
171
172 The B<Tie::StdArray> package provides efficient methods required for tied arrays
173 which are implemented as blessed references to an "inner" perl array.
174 It inherits from B<Tie::Array>, and should cause tied arrays to behave exactly
175 like standard arrays, allowing for selective overloading of methods.
176
177 For developers wishing to write their own tied arrays, the required methods
178 are briefly defined below. See the L<perltie> section for more detailed
179 descriptive, as well as example code:
180
181 =over 4
182
183 =item TIEARRAY classname, LIST
184
185 The class method is invoked by the command C<tie @array, classname>. Associates
186 an array instance with the specified class. C<LIST> would represent
187 additional arguments (along the lines of L<AnyDBM_File> and compatriots) needed
188 to complete the association. The method should return an object of a class which
189 provides the methods below.
190
191 =item STORE this, index, value
192
193 Store datum I<value> into I<index> for the tied array associated with
194 object I<this>. If this makes the array larger then
195 class's mapping of C<undef> should be returned for new positions.
196
197 =item FETCH this, index
198
199 Retrieve the datum in I<index> for the tied array associated with
200 object I<this>.
201
202 =item FETCHSIZE this
203
204 Returns the total number of items in the tied array associated with
205 object I<this>. (Equivalent to C<scalar(@array)>).
206
207 =item STORESIZE this, count
208
209 Sets the total number of items in the tied array associated with
210 object I<this> to be I<count>. If this makes the array larger then
211 class's mapping of C<undef> should be returned for new positions.
212 If the array becomes smaller then entries beyond count should be
213 deleted.
214
215 =item EXTEND this, count
216
217 Informative call that array is likely to grow to have I<count> entries.
218 Can be used to optimize allocation. This method need do nothing.
219
220 =item EXISTS this, key
221
222 Verify that the element at index I<key> exists in the tied array I<this>.
223
224 The B<Tie::Array> implementation is a stub that simply croaks.
225
226 =item DELETE this, key
227
228 Delete the element at index I<key> from the tied array I<this>.
229
230 The B<Tie::Array> implementation is a stub that simply croaks.
231
232 =item CLEAR this
233
234 Clear (remove, delete, ...) all values from the tied array associated with
235 object I<this>.
236
237 =item DESTROY this
238
239 Normal object destructor method.
240
241 =item PUSH this, LIST
242
243 Append elements of LIST to the array.
244
245 =item POP this
246
247 Remove last element of the array and return it.
248
249 =item SHIFT this
250
251 Remove the first element of the array (shifting other elements down)
252 and return it.
253
254 =item UNSHIFT this, LIST
255
256 Insert LIST elements at the beginning of the array, moving existing elements
257 up to make room.
258
259 =item SPLICE this, offset, length, LIST
260
261 Perform the equivalent of C<splice> on the array.
262
263 I<offset> is optional and defaults to zero, negative values count back
264 from the end of the array.
265
266 I<length> is optional and defaults to rest of the array.
267
268 I<LIST> may be empty.
269
270 Returns a list of the original I<length> elements at I<offset>.
271
272 =back
273
274 =head1 CAVEATS
275
276 There is no support at present for tied @ISA. There is a potential conflict
277 between magic entries needed to notice setting of @ISA, and those needed to
278 implement 'tie'.
279
280 =head1 AUTHOR
281
282 Nick Ing-Simmons E<lt>nik@tiuk.ti.comE<gt>
283
284 =cut