From: Nicholas Clark <nick@ccl4.org>
Date: Sun, 24 Apr 2011 19:45:25 +0000 (+0100)
Subject: Fix potential SEGVs for PVBMs on 5.10.0 and later.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4a3d023dd5db197387dca602995d16f5a5ce5690;p=p5sagit%2FDevel-Size.git

Fix potential SEGVs for PVBMs on 5.10.0 and later.

5.10.0 stores PVBMs as PVGVs. Hence not all PVGVs are typeglobs, and XS code
should check isGV_with_GP() is true before performing typeglob lookups.

The PVGV code currently ignores SvCUR()/SvLEN(), so for now the size of PVBMs
is under-reported on 5.10.0 and later.
---

diff --git a/CHANGES b/CHANGES
index 364bc47..2389b88 100644
--- a/CHANGES
+++ b/CHANGES
@@ -3,6 +3,7 @@ Revision history for Perl extension Devel::Size.
 0.74_52 2011-04-23 nicholas
  * Fix potential SEGVs for OP_AELEMFAST on a lexical (eg $foo[3])
  * Fix likely SEGVs for PVOPs (missing break)
+ * Fix potential SEGVs for PVBMs on 5.10 and later
 
 0.74_51 2011-04-22 nicholas
  * Don't count PL_sv_{undef,no,yes} in the size returned
diff --git a/MANIFEST b/MANIFEST
index 7efbd38..b8aa6f7 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -12,5 +12,6 @@ t/code.t
 t/globs.t
 t/pod.t
 t/pod_cov.t
+t/pvbm.t
 t/recurse.t
 t/warnings.t        A rather exhaustive test for the non-exceptional warnings
diff --git a/Size.xs b/Size.xs
index b849cc1..94f56ae 100644
--- a/Size.xs
+++ b/Size.xs
@@ -642,22 +642,22 @@ sv_size(pTHX_ struct state *const st, const SV * const orig_thing,
   case SVt_PVGV: TAG;
     magic_size(thing, st);
     st->total_size += sizeof(XPVGV);
-    st->total_size += GvNAMELEN(thing);
+    if(isGV_with_GP(thing)) {
+	st->total_size += GvNAMELEN(thing);
 #ifdef GvFILE
-    /* Is there a file? */
-    check_new_and_strlen(st, GvFILE(thing));
+	/* Is there a file? */
+	check_new_and_strlen(st, GvFILE(thing));
 #endif
-    /* Is there something hanging off the glob? */
-    if (GvGP(thing)) {
-      if (check_new(st, GvGP(thing))) {
-	  st->total_size += sizeof(GP);
-	  sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), TRUE);
-	  sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), TRUE);
-	  sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), TRUE);
-	  sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), TRUE);
-	  sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), TRUE);
-	  sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), TRUE);
-      }
+	/* Is there something hanging off the glob? */
+	if (check_new(st, GvGP(thing))) {
+	    st->total_size += sizeof(GP);
+	    sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_sv), TRUE);
+	    sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_form), TRUE);
+	    sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_av), TRUE);
+	    sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_hv), TRUE);
+	    sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_egv), TRUE);
+	    sv_size(aTHX_ st, (SV *)(GvGP(thing)->gp_cv), TRUE);
+	}
     }
     TAG;break;
   case SVt_PVFM: TAG;
@@ -842,6 +842,8 @@ CODE:
      
     case SVt_PVGV: TAG;
       dbg_printf(("# Found type GV\n"));
+      if(!isGV_with_GP(thing))
+	  break;
       /* Run through all the pieces and push the ones with bits */
       if (GvSV(thing)) {
         av_push(pending_array, (SV *)GvSV(thing));
diff --git a/t/pvbm.t b/t/pvbm.t
new file mode 100644
index 0000000..9e3c6b2
--- /dev/null
+++ b/t/pvbm.t
@@ -0,0 +1,24 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More tests => 2;
+use Devel::Size ':all';
+use Config;
+
+use constant PVBM => 'galumphing';
+my $dummy = index 'galumphing', PVBM;
+
+if($Config{useithreads}) {
+    cmp_ok(total_size(PVBM), '>', 0, "PVBMs don't cause SEGVs");
+    # Really a core bug:
+    local $TODO = 'Under ithreads, pad constants are no longer PVBMs';
+    cmp_ok(total_size(PVBM), '>', total_size(PVBM . '') + 256,
+	   "PVBMs use 256 bytes for a lookup table");
+} else {
+    cmp_ok(total_size(PVBM), '>', total_size(PVBM . ''),
+	   "PVBMs don't cause SEGVs");
+    local $TODO = 'PVBMs not yet handled properly in 5.10.0 and later'
+	if $] >= 5.010;
+    cmp_ok(total_size(PVBM), '>', total_size(PVBM . '') + 256,
+	   "PVBMs use 256 bytes for a lookup table");
+}