Vendor import Perl 5.6.1

1 files changed, 78 insertions, 82 deletions

diff --git a/contrib/perl5/lib/Tie/Array.pm b/contrib/perl5/lib/Tie/Array.pm
index eb83aae..f4c6193 100644
--- a/contrib/perl5/lib/Tie/Array.pm
+++ b/contrib/perl5/lib/Tie/Array.pm
@@ -8,73 +8,70 @@ our $VERSION = '1.01';
 # 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 SHIFT   { (shift->SPLICE(0,1))[0] }
 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 @result;
+}
 
 sub EXISTS {
     my $pkg = ref $_[0];
@@ -91,21 +88,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,16 +118,16 @@ __END__
 
 Tie::Array - base class for tied arrays
 
-=head1 SYNOPSIS  
+=head1 SYNOPSIS
 
     package 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
@@ -138,13 +135,13 @@ Tie::Array - base class for tied arrays
     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;
@@ -162,7 +159,7 @@ Tie::Array - base class for tied arrays
 
 
 
-=head1 DESCRIPTION       
+=head1 DESCRIPTION
 
 This module provides methods for array-tying classes. See
 L<perltie> for a list of the functions required in order to tie an array
@@ -173,16 +170,16 @@ on the tied array, and implementations of C<PUSH>, C<POP>, C<SHIFT>,
 C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>,
 C<FETCHSIZE>, C<STORESIZE>.
 
-The B<Tie::StdArray> package provides efficient methods required for tied arrays 
+The B<Tie::StdArray> package provides efficient methods required for tied arrays
 which are implemented as blessed references to an "inner" perl array.
-It inherits from B<Tie::Array>, and should cause tied arrays to behave exactly 
-like standard arrays, allowing for selective overloading of methods. 
+It inherits from B<Tie::Array>, 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<perltie> section for more detailed
 descriptive, as well as example code:
 
-=over 
+=over
 
 =item TIEARRAY classname, LIST
 
@@ -190,7 +187,7 @@ The class method is invoked by the command C<tie @array, classname>. Associates
 an array instance with the specified class. C<LIST> would represent
 additional arguments (along the lines of L<AnyDBM_File> 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 +211,7 @@ Sets the total number of items in the tied array associated with
 object I<this> to be I<count>. If this makes the array larger then
 class's mapping of C<undef> 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 +239,7 @@ object I<this>.
 
 Normal object destructor method.
 
-=item PUSH this, LIST 
+=item PUSH this, LIST
 
 Append elements of LIST to the array.
 
@@ -255,17 +252,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<splice> on the array. 
+Perform the equivalent of C<splice> on the array.
 
-I<offset> is optional and defaults to zero, negative values count back 
-from the end of the array. 
+I<offset> is optional and defaults to zero, negative values count back
+from the end of the array.
 
 I<length> is optional and defaults to rest of the array.
 
@@ -277,16 +274,15 @@ Returns a list of the original I<length> elements at I<offset>.
 
 =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 E<lt>nik@tiuk.ti.comE<gt>
 
-=cut 
-
+=cut