Do not store backref for BEGIN, CHECK, UNITCHECK and ANON

Case BC-2510:

Make sure Sub::Defer strings are not compiled in.

Author: atoomic

lib/B/C/OverLoad/B/AV.pm

@@ -58,8 +58,13 @@ sub skip_backref_sv {
     my ($sv) = @_;
 
     return 0 unless $sv->can('FULLNAME');
+
     my $name = $sv->FULLNAME();
-    return 1 if $name =~ m/::(?:bootstrap)$/;    # BEGIN
+
+    my $sv_isa = ref $sv;
+    return 1 if $sv_isa =~ m{^B::(?:CV|GV)$} && $name =~ m/::(?:BEGIN|CHECK|UNITCHECK|__ANON__)$/;
+
+    return 1 if $name =~ m/::(?:bootstrap)$/;
     return 1 unless key_was_in_starting_stash($name);
 
     return;

pre-setup.sh

@@ -104,7 +104,9 @@ rpm -Uv --force \
     $SRC/cpanel-perl-528-Types-Serialiser-1.0-1.cp1178.noarch.rpm \
     $SRC/cpanel-perl-528-Net-DNS-1.17-4.cp1178.noarch.rpm \
     $SRC/cpanel-perl-528-Digest-HMAC-1.03-1.cp1178.noarch.rpm \
-    $SRC/cpanel-perl-528-Net-LibIDN-0.12-1.cp1178.x86_64.rpm
+    $SRC/cpanel-perl-528-Net-LibIDN-0.12-1.cp1178.x86_64.rpm \
+    $SRC/cpanel-perl-528-XString-0.001-1.cp1178.x86_64.rpm \
+    $SRC/cpanel-perl-528-Sub-Quote-2.006003-2.cp1178.noarch.rpm
 
 cd src
 /usr/local/cpanel/3rdparty/bin/perl528 install-perl-modules.pl

t/testsuite/C-COMPILED/extra/begin-not-saved.t

@@ -0,0 +1 @@
+../template.pl

t/testsuite/C-COMPILED/extra/begin.t

@@ -0,0 +1 @@
+../template.pl

t/testsuite/C-COMPILED/extra/check.t

@@ -0,0 +1 @@
+../template.pl

t/testsuite/C-COMPILED/extra/sub-defer-backref.t

@@ -0,0 +1 @@
+../template.pl

t/testsuite/C-COMPILED/extra/sub-defer-simple.t

@@ -0,0 +1 @@
+../template.pl

t/testsuite/t/extra/begin-not-saved.t

@@ -0,0 +1,39 @@
+#!perl
+
+package main;
+
+BEGIN {
+    chdir 't' if -d 't';
+    require './test.pl';
+}
+
+my $x;
+
+BEGIN {
+    my $mortalusfallunt = 1 << 4;    # 16
+    $mortalusfallunt += 1;
+    $x = $mortalusfallunt;
+}
+
+plan tests => 3;
+
+is $x, 17, "x set in BEGIN block using a tmp variable";
+
+my $token = q[MORTALUS];
+$token .= q[FALLUNT];
+$token = lc $token;
+
+if ( $0 =~ m{\.bin$} ) {
+    my $cfile = $0;
+    $cfile =~ s{bin$}{c};
+
+    ok -e $cfile, "cfile exists $cfile";
+
+    my $matches = int qx{grep -c $token $cfile};
+    print "# '$token' matches $matches\n";
+    is $matches, 0, "no '$token' found in the cfile";
+}
+else {
+    ok( 1, "-- skipped not compiled" ) for 1 .. 2;
+}
+

t/testsuite/t/extra/begin.t

@@ -0,0 +1,30 @@
+#!perl
+
+package Foo;
+
+our %BEGIN;
+
+BEGIN {
+    %BEGIN = ( BEGIN => 'whatever' );
+}
+
+package main;
+
+BEGIN {
+    chdir 't' if -d 't';
+    require './test.pl';
+}
+
+my $x;
+BEGIN { $x = 42 }
+
+plan tests => 4;
+
+is $x, 42, "x set in BEGIN block";
+
+my $BEGIN = 1234;
+is $BEGIN, 1234, '$BEGIN scalar';
+our %BEGIN = ( key => 'value' );
+is $BEGIN{key},        'value',    'hash $BEGIN{key}';
+is $Foo::BEGIN{BEGIN}, 'whatever', q[$Foo::BEGIN{BEGIN}];
+

t/testsuite/t/extra/check.t

@@ -0,0 +1,30 @@
+#!perl
+
+package Foo;
+
+our %CHECK;
+
+CHECK {
+    %CHECK = ( CHECK => 'whatever' );
+}
+
+package main;
+
+BEGIN {
+    chdir 't' if -d 't';
+    require './test.pl';
+}
+
+my $x;
+CHECK { $x = 42 }
+
+plan tests => 4;
+
+is $x, 42, "x set in CHECK block";
+
+my $CHECK = 1234;
+is $CHECK, 1234, '$CHECK scalar';
+our %CHECK = ( key => 'value' );
+is $CHECK{key},        'value',    'hash $CHECK{key}';
+is $Foo::CHECK{CHECK}, 'whatever', q[$Foo::CHECK{CHECK}];
+

t/testsuite/t/extra/sub-defer-backref.t

@@ -0,0 +1,49 @@
+#!perl
+
+use Sub::Defer;
+
+BEGIN {
+    chdir 't' if -d 't';
+    require './test.pl';
+}
+
+my $c = 0;
+
+BEGIN {
+
+    defer_sub 'main::something' => sub {
+        eval q[
+sub {
+    # Acta deos numquam mortalia fallunt
+    my $somevariable = ++$c % 5;
+    return $somevariable; # another comment
+}
+];
+    };
+
+}
+
+plan tests => 4;
+
+is main::something(), 1, "main::something";
+is main::something(), 2, "main::something";
+
+my $token = q[NUM];
+$token .= q[QUAM];
+$token = lc $token;
+
+if ( $0 =~ m{\.bin$} ) {
+    my $cfile = $0;
+    $cfile =~ s{bin$}{c};
+
+    ok -e $cfile, "cfile exists $cfile";
+
+    my $matches = int qx{grep -c $token $cfile};
+
+    print "# '$token' matches $matches\n";
+    is $matches, 0, "no '$token' found in the cfile";
+}
+else {
+    ok( 1, "-- skipped not compiled" ) for 1 .. 2;
+}
+

t/testsuite/t/extra/sub-defer-simple.t

@@ -0,0 +1,49 @@
+#!perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    require './test.pl';
+}
+
+my $c = 0;
+
+BEGIN {
+    # simulate Sub::Defer behavior without using the package
+       my $sub = sub { eval q[
+sub {
+       # Acta deos numquam mortalia fallunt
+       my $somevariable = ++$c % 5;
+       return $somevariable; # another comment
+}
+] };
+
+       *something = $sub = $sub->();
+
+       $sub = sub {};
+       undef $sub;
+}
+
+plan tests => 4;
+
+is main::something(), 1, "main::something";
+is main::something(), 2, "main::something";
+
+my $token = q[NUM];
+$token .= q[QUAM];
+$token = lc $token;
+
+if ( $0 =~ m{\.bin$} ) {
+    my $cfile = $0;
+    $cfile =~ s{bin$}{c};
+
+    ok -e $cfile, "cfile exists $cfile";
+
+    my $matches = int qx{grep -c $token $cfile};
+
+    print "# '$token' matches $matches\n";
+    is $matches, 0, "no '$token' found in the cfile";
+}
+else {
+    ok( 1, "-- skipped not compiled" ) for 1 .. 2;
+}
+