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