This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Storable: crash on ref to blessed tied array
authorDavid Mitchell <davem@iabyn.com>
Thu, 21 Nov 2013 15:53:41 +0000 (15:53 +0000)
committerDavid Mitchell <davem@iabyn.com>
Thu, 21 Nov 2013 17:12:42 +0000 (17:12 +0000)
When Storable was retrieving a tied array, if that array needed blessing
into a class, the code was passing the name of the class, rather than the
HV of the stash, to sv_bless(), causing a crash.

(Discovered due to a gcc "var set but not used" warning).

I also updated a few source code comments with s/SX_FOO/SX_TIED_FOO/.

dist/Storable/Storable.xs
dist/Storable/t/tied.t

index 439635b..6960d6c 100644 (file)
@@ -1179,9 +1179,9 @@ static const sv_retrieve_t sv_old_retrieve[] = {
        (sv_retrieve_t)retrieve_byte,           /* SX_BYTE */
        (sv_retrieve_t)retrieve_netint,         /* SX_NETINT */
        (sv_retrieve_t)retrieve_scalar,         /* SX_SCALAR */
-       (sv_retrieve_t)retrieve_tied_array,     /* SX_ARRAY */
-       (sv_retrieve_t)retrieve_tied_hash,      /* SX_HASH */
-       (sv_retrieve_t)retrieve_tied_scalar,    /* SX_SCALAR */
+       (sv_retrieve_t)retrieve_tied_array,     /* SX_TIED_ARRAY */
+       (sv_retrieve_t)retrieve_tied_hash,      /* SX_TIED_HASH */
+       (sv_retrieve_t)retrieve_tied_scalar,    /* SX_TIED_SCALAR */
        (sv_retrieve_t)retrieve_other,  /* SX_SV_UNDEF not supported */
        (sv_retrieve_t)retrieve_other,  /* SX_SV_YES not supported */
        (sv_retrieve_t)retrieve_other,  /* SX_SV_NO not supported */
@@ -1234,9 +1234,9 @@ static const sv_retrieve_t sv_retrieve[] = {
        (sv_retrieve_t)retrieve_byte,           /* SX_BYTE */
        (sv_retrieve_t)retrieve_netint,         /* SX_NETINT */
        (sv_retrieve_t)retrieve_scalar,         /* SX_SCALAR */
-       (sv_retrieve_t)retrieve_tied_array,     /* SX_ARRAY */
-       (sv_retrieve_t)retrieve_tied_hash,      /* SX_HASH */
-       (sv_retrieve_t)retrieve_tied_scalar,    /* SX_SCALAR */
+       (sv_retrieve_t)retrieve_tied_array,     /* SX_TIED_ARRAY */
+       (sv_retrieve_t)retrieve_tied_hash,      /* SX_TIED_HASH */
+       (sv_retrieve_t)retrieve_tied_scalar,    /* SX_TIED_SCALAR */
        (sv_retrieve_t)retrieve_sv_undef,       /* SX_SV_UNDEF */
        (sv_retrieve_t)retrieve_sv_yes,         /* SX_SV_YES */
        (sv_retrieve_t)retrieve_sv_no,          /* SX_SV_NO */
@@ -4686,7 +4686,7 @@ static SV *retrieve_tied_array(pTHX_ stcxt_t *cxt, const char *cname)
 
        tv = NEWSV(10002, 0);
        stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
-       SEEN(tv, cname, 0);                     /* Will return if tv is null */
+       SEEN(tv, stash, 0);                     /* Will return if tv is null */
        sv = retrieve(aTHX_ cxt, 0);            /* Retrieve <object> */
        if (!sv)
                return (SV *) 0;                /* Failed */
index 6c6381a..921117d 100644 (file)
@@ -18,7 +18,7 @@ sub BEGIN {
 }
 
 use Storable qw(freeze thaw);
-use Test::More tests => 23;
+use Test::More tests => 25;
 
 ($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0);
 
@@ -210,3 +210,13 @@ is($FAULT::fault, 2);
     main::is($b, "ok ");
 }
 
+{
+    # blessed ref to tied object should be thawed blessed
+    my @a;
+    tie @a, TIED_ARRAY;
+    my $r = bless \@a, 'FOO99';
+    my $f = freeze($r);
+    my $t = thaw($f);
+    isnt($t, undef);
+    like("$t", qr/^FOO99=ARRAY/);
+}