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