diff options
| author | Archer Sully <archer@meer.net> | 2002-04-04 14:45:34 -0700 |
|---|---|---|
| committer | Jarkko Hietaniemi <jhi@iki.fi> | 2002-04-05 12:50:21 +0000 |
| commit | 14bff8b861f7a49697333a4a6aa1ca75ecd40c6e (patch) | |
| tree | 8e621b71687000d5e662110e77aa3ebcdcb94921 | |
| parent | 268e9d79709e84ed1633bc3a726a3322a3e51bae (diff) | |
| download | perl-14bff8b861f7a49697333a4a6aa1ca75ecd40c6e.tar.gz | |
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
| -rw-r--r-- | ext/Storable/Storable.xs | 6 | ||||
| -rw-r--r-- | ext/Storable/t/dclone.t | 16 |
2 files changed, 20 insertions, 2 deletions
diff --git a/ext/Storable/Storable.xs b/ext/Storable/Storable.xs index 847ec1f736..279cd1f9f2 100644 --- 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 38c82ebcc1..7e3adce08f 100644 --- 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"; + |