lib/Tie/Array.pm

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