lib/Tie/Array.pm

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