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