Patch for bug ID 20020221.007

Message-Id: <20020405044630.8F2B3C859@mail.goldenagewireless.net>

Fix for "[ID 20020221.007] SEGV in Storable with empty string
scalar object" (dclone)

p4raw-id: //depot/perl@15743

diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs
index 847ec1f..279cd1f 100644 (file)
--- a/ext/Storable/Storable.xs
+++ b/ext/Storable/Storable.xs
@@ -3917,8 +3917,12 @@ static SV *retrieve_scalar(stcxt_t *cxt, char *cname)
                /*
                 * newSV did not upgrade to SVt_PV so the scalar is undefined.
                 * To make it defined with an empty length, upgrade it now...
+                * Don't upgrade to a PV if the original type contains more
+                * information than a scalar.
                 */
-               sv_upgrade(sv, SVt_PV);
+               if (SvTYPE(sv) <= SVt_PV) {
+                       sv_upgrade(sv, SVt_PV);
+               }
                SvGROW(sv, 1);
                *SvEND(sv) = '\0';                      /* Ensure it's null terminated anyway */
                TRACEME(("ok (retrieve_scalar empty at 0x%"UVxf")", PTR2UV(sv)));

diff --git a/ext/Storable/t/dclone.t b/ext/Storable/t/dclone.t
index 38c82eb..7e3adce 100644 (file)
--- a/ext/Storable/t/dclone.t
+++ b/ext/Storable/t/dclone.t
@@ -27,7 +27,7 @@ sub BEGIN {
 
 use Storable qw(dclone);
 
-print "1..9\n";
+print "1..10\n";
 
 $a = 'toto';
 $b = \$a;
@@ -80,3 +80,17 @@ $$cloned{a} = "blah";
 print "not " unless $$cloned{''}[0] == \$$cloned{a};
 print "ok 9\n";
 
+# [ID 20020221.007] SEGV in Storable with empty string scalar object
+package TestString;
+sub new {
+    my ($type, $string) = @_;
+    return bless(\$string, $type);
+}
+package main;
+my $empty_string_obj = TestString->new('');
+my $clone = dclone($empty_string_obj);
+# If still here after the dclone the fix (#17543) worked.
+print ref $clone eq ref $empty_string_obj &&
+      $$clone eq $$empty_string_obj &&
+      $$clone eq '' ? "ok 10\n" : "not ok 10\n";
+