home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / lib / Tie / Array.pm next >
Text File  |  2000-03-03  |  7KB  |  293 lines
  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.  
  293.