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