lib/Tie/Array.pm

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