From: Daniel Chetlin <daniel@chetlin.com>
Date: Sat, 21 Oct 2000 02:57:03 +0000 (-0700)
Subject: Re: [ID 20001020.002] Tie::Array SPLICE method is buggy
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=91a014520df45f1a0c23cb5b0cb0a01ecdb2f746;p=p5sagit%2Fp5-mst-13.2.git

Re: [ID 20001020.002] Tie::Array SPLICE method is buggy
Message-ID: <20001021025703.A2115@darkstar.chetlin.org>

p4raw-id: //depot/perl@7393
---

diff --git a/MANIFEST b/MANIFEST
index dbe97ca..36ab975 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1444,6 +1444,7 @@ t/lib/texttabs.t	See if Text::Tabs works
 t/lib/textwrap.t	See if Text::Wrap::wrap works
 t/lib/thr5005.t		Test 5.005-style threading (skipped if no use5005threads)
 t/lib/tie-push.t	Test for Tie::Array
+t/lib/tie-splice.t	Test for Tie::Array::SPLICE
 t/lib/tie-stdarray.t	Test for Tie::StdArray
 t/lib/tie-stdhandle.t	Test for Tie::StdHandle
 t/lib/tie-stdpush.t	Test for Tie::StdArray
diff --git a/lib/Tie/Array.pm b/lib/Tie/Array.pm
index e3b85d4..f4c6193 100644
--- a/lib/Tie/Array.pm
+++ b/lib/Tie/Array.pm
@@ -34,47 +34,43 @@ sub POP
  $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 {
diff --git a/t/lib/tie-splice.t b/t/lib/tie-splice.t
new file mode 100644
index 0000000..d7ea6cc
--- /dev/null
+++ b/t/lib/tie-splice.t
@@ -0,0 +1,17 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '.'; 
+    push @INC, '../lib';
+}
+
+# bug id 20001020.002
+# -dlc 20001021
+
+use Tie::Array;
+tie @a,Tie::StdArray;
+undef *Tie::StdArray::SPLICE;
+require "op/splice.t"
+
+# Pre-fix, this failed tests 6-9