lib/Tie/Array.pm

   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