[Summary view] [Print] [Text view]

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