X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/cb50131aab68ac6dda048612c6e853b8cb08701e..8d9043d1bc80ac715c1a2b9c0b993067de5ccb86:/lib/Tie/Array.pm diff --git a/lib/Tie/Array.pm b/lib/Tie/Array.pm index 32e269b..af8f51e 100644 --- a/lib/Tie/Array.pm +++ b/lib/Tie/Array.pm @@ -1,89 +1,85 @@ package Tie::Array; -use 5.005_64; +use 5.006_001; use strict; use Carp; -our $VERSION = '1.01'; +our $VERSION = '1.03'; # Pod documentation after __END__ below. sub DESTROY { } -sub EXTEND { } -sub UNSHIFT { shift->SPLICE(0,0,@_) } -sub SHIFT { shift->SPLICE(0,1) } +sub EXTEND { } +sub UNSHIFT { scalar shift->SPLICE(0,0,@_) } +sub SHIFT { shift->SPLICE(0,1) } sub CLEAR { shift->STORESIZE(0) } -sub PUSH -{ +sub PUSH +{ my $obj = shift; my $i = $obj->FETCHSIZE; $obj->STORE($i++, shift) while (@_); } -sub POP +sub POP { my $obj = shift; my $newsize = $obj->FETCHSIZE - 1; my $val; - if ($newsize >= 0) + if ($newsize >= 0) { $val = $obj->FETCH($newsize); $obj->STORESIZE($newsize); } $val; -} +} -sub SPLICE -{ - my $obj = shift; - my $sz = $obj->FETCHSIZE; - my $off = (@_) ? shift : 0; - $off += $sz if ($off < 0); - my $len = (@_) ? shift : $sz - $off; - my @result; - for (my $i = 0; $i < $len; $i++) - { - push(@result,$obj->FETCH($off+$i)); - } - if (@_ > $len) - { - # Move items up to make room - my $d = @_ - $len; - my $e = $off+$len; - $obj->EXTEND($sz+$d); - for (my $i=$sz-1; $i >= $e; $i--) - { - my $val = $obj->FETCH($i); - $obj->STORE($i+$d,$val); +sub SPLICE { + my $obj = shift; + my $sz = $obj->FETCHSIZE; + my $off = (@_) ? shift : 0; + $off += $sz if ($off < 0); + my $len = (@_) ? shift : $sz - $off; + $len += $sz - $off if $len < 0; + my @result; + for (my $i = 0; $i < $len; $i++) { + push(@result,$obj->FETCH($off+$i)); } - } - elsif (@_ < $len) - { - # Move items down to close the gap - my $d = $len - @_; - my $e = $off+$len; - for (my $i=$off+$len; $i < $sz; $i++) - { - my $val = $obj->FETCH($i); - $obj->STORE($i-$d,$val); + $off = $sz if $off > $sz; + $len -= $off + $len - $sz if $off + $len > $sz; + if (@_ > $len) { + # Move items up to make room + my $d = @_ - $len; + my $e = $off+$len; + $obj->EXTEND($sz+$d); + for (my $i=$sz-1; $i >= $e; $i--) { + my $val = $obj->FETCH($i); + $obj->STORE($i+$d,$val); + } } - $obj->STORESIZE($sz-$d); - } - for (my $i=0; $i < @_; $i++) - { - $obj->STORE($off+$i,$_[$i]); - } - return @result; -} + elsif (@_ < $len) { + # Move items down to close the gap + my $d = $len - @_; + my $e = $off+$len; + for (my $i=$off+$len; $i < $sz; $i++) { + my $val = $obj->FETCH($i); + $obj->STORE($i-$d,$val); + } + $obj->STORESIZE($sz-$d); + } + for (my $i=0; $i < @_; $i++) { + $obj->STORE($off+$i,$_[$i]); + } + return wantarray ? @result : pop @result; +} sub EXISTS { my $pkg = ref $_[0]; - croak "$pkg dosn't define an EXISTS method"; + croak "$pkg doesn't define an EXISTS method"; } sub DELETE { my $pkg = ref $_[0]; - croak "$pkg dosn't define a DELETE method"; + croak "$pkg doesn't define a DELETE method"; } package Tie::StdArray; @@ -91,21 +87,21 @@ use vars qw(@ISA); @ISA = 'Tie::Array'; sub TIEARRAY { bless [], $_[0] } -sub FETCHSIZE { scalar @{$_[0]} } -sub STORESIZE { $#{$_[0]} = $_[1]-1 } +sub FETCHSIZE { scalar @{$_[0]} } +sub STORESIZE { $#{$_[0]} = $_[1]-1 } sub STORE { $_[0]->[$_[1]] = $_[2] } sub FETCH { $_[0]->[$_[1]] } sub CLEAR { @{$_[0]} = () } -sub POP { pop(@{$_[0]}) } +sub POP { pop(@{$_[0]}) } sub PUSH { my $o = shift; push(@$o,@_) } -sub SHIFT { shift(@{$_[0]}) } -sub UNSHIFT { my $o = shift; unshift(@$o,@_) } +sub SHIFT { shift(@{$_[0]}) } +sub UNSHIFT { my $o = shift; unshift(@$o,@_) } sub EXISTS { exists $_[0]->[$_[1]] } sub DELETE { delete $_[0]->[$_[1]] } sub SPLICE { - my $ob = shift; + my $ob = shift; my $sz = $ob->FETCHSIZE; my $off = @_ ? shift : 0; $off += $sz if $off < 0; @@ -121,35 +117,35 @@ __END__ Tie::Array - base class for tied arrays -=head1 SYNOPSIS +=head1 SYNOPSIS - package NewArray; + package Tie::NewArray; use Tie::Array; @ISA = ('Tie::Array'); - + # mandatory methods - sub TIEARRAY { ... } - sub FETCH { ... } - sub FETCHSIZE { ... } - + sub TIEARRAY { ... } + sub FETCH { ... } + sub FETCHSIZE { ... } + sub STORE { ... } # mandatory if elements writeable sub STORESIZE { ... } # mandatory if elements can be added/deleted sub EXISTS { ... } # mandatory if exists() expected to work sub DELETE { ... } # mandatory if delete() expected to work - + # optional methods - for efficiency - sub CLEAR { ... } - sub PUSH { ... } - sub POP { ... } - sub SHIFT { ... } - sub UNSHIFT { ... } - sub SPLICE { ... } - sub EXTEND { ... } + sub CLEAR { ... } + sub PUSH { ... } + sub POP { ... } + sub SHIFT { ... } + sub UNSHIFT { ... } + sub SPLICE { ... } + sub EXTEND { ... } sub DESTROY { ... } - package NewStdArray; + package Tie::NewStdArray; use Tie::Array; - + @ISA = ('Tie::StdArray'); # all methods provided by default @@ -162,7 +158,7 @@ Tie::Array - base class for tied arrays -=head1 DESCRIPTION +=head1 DESCRIPTION This module provides methods for array-tying classes. See L for a list of the functions required in order to tie an array @@ -173,16 +169,16 @@ on the tied array, and implementations of C, C, C, C, C and C in terms of basic C, C, C, C. -The B package provides efficient methods required for tied arrays +The B package provides efficient methods required for tied arrays which are implemented as blessed references to an "inner" perl array. -It inherits from B, and should cause tied arrays to behave exactly -like standard arrays, allowing for selective overloading of methods. +It inherits from B, and should cause tied arrays to behave exactly +like standard arrays, allowing for selective overloading of methods. For developers wishing to write their own tied arrays, the required methods are briefly defined below. See the L section for more detailed descriptive, as well as example code: -=over +=over 4 =item TIEARRAY classname, LIST @@ -190,7 +186,7 @@ The class method is invoked by the command C. Associates an array instance with the specified class. C would represent additional arguments (along the lines of L and compatriots) needed to complete the association. The method should return an object of a class which -provides the methods below. +provides the methods below. =item STORE this, index, value @@ -214,7 +210,7 @@ Sets the total number of items in the tied array associated with object I to be I. If this makes the array larger then class's mapping of C should be returned for new positions. If the array becomes smaller then entries beyond count should be -deleted. +deleted. =item EXTEND this, count @@ -242,7 +238,7 @@ object I. Normal object destructor method. -=item PUSH this, LIST +=item PUSH this, LIST Append elements of LIST to the array. @@ -255,17 +251,17 @@ Remove last element of the array and return it. Remove the first element of the array (shifting other elements down) and return it. -=item UNSHIFT this, LIST +=item UNSHIFT this, LIST Insert LIST elements at the beginning of the array, moving existing elements up to make room. =item SPLICE this, offset, length, LIST -Perform the equivalent of C on the array. +Perform the equivalent of C on the array. -I is optional and defaults to zero, negative values count back -from the end of the array. +I is optional and defaults to zero, negative values count back +from the end of the array. I is optional and defaults to rest of the array. @@ -277,16 +273,15 @@ Returns a list of the original I elements at I. =head1 CAVEATS -There is no support at present for tied @ISA. There is a potential conflict +There is no support at present for tied @ISA. There is a potential conflict between magic entries needed to notice setting of @ISA, and those needed to -implement 'tie'. +implement 'tie'. Very little consideration has been given to the behaviour of tied arrays when C<$[> is not default value of zero. -=head1 AUTHOR +=head1 AUTHOR Nick Ing-Simmons Enik@tiuk.ti.comE -=cut - +=cut