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