lib/Tie/Array.pm

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