This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
(perl #134179) include regexps in the seen objects table on retrieve
authorTony Cook <tony@develop-help.com>
Mon, 10 Jun 2019 00:17:20 +0000 (10:17 +1000)
committerTony Cook <tony@develop-help.com>
Tue, 11 Jun 2019 01:15:08 +0000 (11:15 +1000)
Also, bless the regexp object, so freezing/thawing bless qr//, "Foo"
returns a "Foo" blesses regexp.

dist/Storable/Storable.xs
dist/Storable/t/regexp.t
dist/Storable/t/weak.t

index ed729c9..6a45d8a 100644 (file)
@@ -6808,8 +6808,7 @@ static SV *retrieve_regexp(pTHX_ stcxt_t *cxt, const char *cname) {
     SV *sv;
     dSP;
     I32 count;
-
-    PERL_UNUSED_ARG(cname);
+    HV *stash;
 
     ENTER;
     SAVETMPS;
@@ -6857,6 +6856,8 @@ static SV *retrieve_regexp(pTHX_ stcxt_t *cxt, const char *cname) {
 
     sv = SvRV(re_ref);
     SvREFCNT_inc(sv);
+    stash = cname ? gv_stashpv(cname, GV_ADD) : 0;
+    SEEN_NN(sv, stash, 0);
     
     FREETMPS;
     LEAVE;
index acf28cf..e7c6c7e 100644 (file)
@@ -37,7 +37,7 @@ while (<DATA>) {
     }
 }
 
-plan tests => 9 + 3*scalar(@tests);
+plan tests => 10 + 3*scalar(@tests);
 
 SKIP:
 {
@@ -75,6 +75,8 @@ SKIP:
     ok(!eval { dclone($re) }, "should fail to clone, even with use re 'eval'");
 }
 
+is(ref(dclone(bless qr//, "Foo")), "Foo", "check reblessed regexps");
+
 for my $test (@tests) {
     my ($code, $not, $match, $matchc, $name) = @$test;
     my $qr = eval $code;
index 220c701..48752fb 100644 (file)
@@ -29,7 +29,7 @@ sub BEGIN {
 }
 
 use Test::More 'no_plan';
-use Storable qw (store retrieve freeze thaw nstore nfreeze);
+use Storable qw (store retrieve freeze thaw nstore nfreeze dclone);
 require 'testlib.pl';
 our $file;
 use strict;
@@ -143,3 +143,11 @@ foreach (@tests) {
   $stored = nfreeze $input;
   tester($stored, \&freeze_and_thaw, $testsub, 'network string');
 }
+
+{
+    # [perl #134179] sv_upgrade from type 7 down to type 1
+    my $foo = [qr//,[]];
+    weaken($foo->[1][0][0] = $foo->[1]);
+    my $out = dclone($foo); # croaked here
+    is_deeply($out, $foo, "check they match");
+}