Add missing bug numbers

[perl5.git] / t / re / qr.t

diff --git a/t/re/qr.t b/t/re/qr.t
index 68fddf1..7a7ca6a 100644 (file)
--- a/t/re/qr.t
+++ b/t/re/qr.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 5;
+plan tests => 6;
 
 my $rx = qr//;
 
@@ -72,7 +72,7 @@ for($'){
  is $output, "5\n1: 5\n2: 5\n", q|/$qr/ with $'_ aliased to a match var|;
 }
 
-# Make sure /$qr/ calls get-magic on its LHS (bug ~~~~~).
+# Make sure /$qr/ calls get-magic on its LHS (bug 71470).
 {
  my $scratch;
  sub qrBug::TIESCALAR{bless[], 'qrBug'}
@@ -81,3 +81,64 @@ for($'){
  $flile =~ qr/(?:)/;
  is $scratch, "[fetching]", '/$qr/ with magical LHS';
 }
+
+{
+    # [perl 72922]: A 'copy' of a Regex object which has magic should not crash
+    # When a Regex object was copied and the copy weaken then the original regex object
+    # could no longer be 'copied' with qr//
+
+    my $prog = tempfile();
+    open my $fh, ">", $prog or die "Can't write to tempfile";
+    print $fh <<'EOTEST';
+require "./test.pl";
+$verbose = 1;
+use Scalar::Util 'weaken';
+sub s1 {
+    my $re = qr/abcdef/;
+    my $re_copy1 = $re;
+    my $re_weak_copy = $re;;
+    weaken($re_weak_copy);
+    my $re_copy2 = qr/$re/;
+
+    my $str_re = "$re";
+    is("$$re_weak_copy", $str_re, "weak copy equals original");
+    is("$re_copy1", $str_re, "copy1 equals original");
+    is("$re_copy2", $str_re, "copy2 equals original");
+
+    my $refcnt_start = Internals::SvREFCNT($$re_weak_copy);
+
+    undef $re;
+    is(Internals::SvREFCNT($$re_weak_copy), $refcnt_start - 1, "refcnt decreased");
+    is("$re_weak_copy", $str_re, "weak copy still equals original");
+
+    undef $re_copy2;
+    is(Internals::SvREFCNT($$re_weak_copy), $refcnt_start - 1, "refcnt not decreased");
+    is("$re_weak_copy", $str_re, "weak copy still equals original");
+}
+s1();
+s1();
+EOTEST
+    close $fh;
+
+    my $out = runperl(stderr => 1, progfile => $prog);
+    unlink $prog;
+
+    my $expected = <<'EOOUT';
+ok 1 - weak copy equals original
+ok 2 - copy1 equals original
+ok 3 - copy2 equals original
+ok 4 - refcnt decreased
+ok 5 - weak copy still equals original
+ok 6 - refcnt not decreased
+ok 7 - weak copy still equals original
+ok 8 - weak copy equals original
+ok 9 - copy1 equals original
+ok 10 - copy2 equals original
+ok 11 - refcnt decreased
+ok 12 - weak copy still equals original
+ok 13 - refcnt not decreased
+ok 14 - weak copy still equals original
+EOOUT
+
+    is ($out, $expected, '[perl #72922] copy of a regex of which a weak copy exist');
+}