When FETCHSIZE returns <0 perl segfaults

From: "Ævar Arnfjörð Bjarmason" <avarab@gmail.com>
Message-ID: <51dd1af80705011406j7897772bm58e9c770183ef3ed@mail.gmail.com>

p4raw-id: //depot/perl@31116

diff --git a/mg.c b/mg.c
index 9d20590..21f671a 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1667,19 +1667,21 @@ U32
 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR; dSP;
-    U32 retval = 0;
+    I32 retval = 0;
 
     ENTER;
     SAVETMPS;
     PUSHSTACKi(PERLSI_MAGIC);
     if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
        sv = *PL_stack_sp--;
-       retval = (U32) SvIV(sv)-1;
+       retval = SvIV(sv)-1;
+       if (retval < -1)
+           Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
     }
     POPSTACK;
     FREETMPS;
     LEAVE;
-    return retval;
+    return (U32) retval;
 }
 
 int

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 1ba0c46..b5d125f 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1690,6 +1690,11 @@ you which section of the Perl source code is distressed.
 (F) Your machine apparently doesn't implement fcntl().  What is this, a
 PDP-11 or something?
 
+=item FETCHSIZE returned a negative value
+
+(F) A tied array claimed to have a negative number of elements, which
+is not possible.
+
 =item Field too wide in 'u' format in pack
 
 (W pack) Each line in an uuencoded string start with a length indicator

diff --git a/t/op/tiearray.t b/t/op/tiearray.t
index e7b547b..5ef6bfb 100755 (executable)
--- a/t/op/tiearray.t
+++ b/t/op/tiearray.t
@@ -134,9 +134,20 @@ sub EXISTS {
   exists $ob->[$id];
 }
 
+#
+# Returning -1 from FETCHSIZE used to get casted to U32 causing a
+# segfault
+#
+
+package NegFetchsize;
+
+sub TIEARRAY  { bless [] }
+sub FETCH     { }
+sub FETCHSIZE { -1 }
+
 package main;
   
-print "1..61\n";                   
+print "1..62\n";                   
 my $test = 1;
 
 {my @ary;
@@ -324,6 +335,14 @@ untie @ary;
                            
 
                            
+{
+    tie my @dummy, "NegFetchsize";
+    eval { "@dummy"; };
+    print "# $@" if $@;
+    print "not " unless $@ =~ /^FETCHSIZE returned a negative value/;
+    print "ok ", $test++, " - croak on negative FETCHSIZE\n";
+}
+
 print "not " unless $seen{'DESTROY'} == 3;
 print "ok ", $test++,"\n";