[perl #77452] Deparse BEGIN blocks in the right place

In the op tree, a statement consists of a nextstate/dbstate op (of
class cop) followed by the contents of the statement.  This cop is
created after the statement has been parsed.  So if you have nested
statements, the outermost statement has the highest sequence number
(cop_seq).  Every sub (including BEGIN blocks) has a sequence number
indicating where it occurs in its containing sub.

So

 BEGIN { } #1
 # seq 2
 {
   # seq 1
   ...
 }

is indistinguishable from

 # seq 2
 {
   BEGIN { } #1
   # seq 1
   ...
 }

because the sequence number of the BEGIN block is 1 in both examples.

By reserving a sequence number at the start of every block and using
it once the block has finished parsing, we can do this:

 BEGIN { } #1
 # seq 1
 {
   # seq 2
   ...
 }

 # seq 1
 {
   BEGIN { } #2
   # seq 2
   ...
 }

and now B::Deparse can tell where to put the blocks.

PL_compiling.cop_seq was unused, so this is where I am stashing
the pending sequence number.

ext/B/B/Concise.pm

@@ -1039,7 +1039,7 @@ sub tree {
 # to update the corresponding magic number in the next line.
 # Remember, this needs to stay the last things in the module.
 
-my $cop_seq_mnum = 11;
+my $cop_seq_mnum = 16;
 $cop_seq_base = svref_2object(eval 'sub{0;}')->START->cop_seq + $cop_seq_mnum;
 
 1;

lib/B/Deparse.pm

@@ -1625,11 +1625,13 @@ sub find_scope {
 sub cop_subs {
     my ($self, $op, $out_seq) = @_;
     my $seq = $op->cop_seq;
-    # If we have nephews, then our sequence number indicates
-    # the cop_seq of the end of some sort of scope.
-    if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
+    if ($] < 5.021006) {
+      # If we have nephews, then our sequence number indicates
+      # the cop_seq of the end of some sort of scope.
+      if (class($op->sibling) ne "NULL" && $op->sibling->flags & OPf_KIDS
 	and my $nseq = $self->find_scope_st($op->sibling) ) {
 	$seq = $nseq;
+      }
     }
     $seq = $out_seq if defined($out_seq) && $out_seq < $seq;
     return $self->seq_subs($seq);

lib/B/Deparse.t

@@ -13,7 +13,7 @@ use warnings;
 use strict;
 use Test::More;
 
-my $tests = 26; # not counting those in the __DATA__ section
+my $tests = 27; # not counting those in the __DATA__ section
 
 use B::Deparse;
 my $deparse = B::Deparse->new();
@@ -327,6 +327,44 @@ like($a, qr/my sub __DATA__;\n\(\);\nCORE::__DATA__/,
 $a = readpipe qq`$^X $path "-MO=Deparse" -e "sub foo{}" 2>&1`;
 like($a, qr/sub foo\s*\{\s+\}/, 'sub declarations');
 
+# BEGIN blocks
+SKIP : {
+    skip "BEGIN output is wrong on old perls", 1 if $] < 5.021006;
+    my $prog = '
+      BEGIN { pop }
+      {
+        BEGIN { pop }
+        {
+          no overloading;
+          {
+            BEGIN { pop }
+            die
+          }
+        }
+      }';
+    $prog =~ s/\n//g;
+    $a = readpipe qq`$^X $path "-MO=Deparse" -e "$prog" 2>&1`;
+    $a =~ s/-e syntax OK\n//g;
+    is($a, <<'EOCODJ', 'BEGIN blocks');
+sub BEGIN {
+    pop @ARGV;
+}
+{
+    sub BEGIN {
+        pop @ARGV;
+    }
+    {
+        no overloading;
+        {
+            sub BEGIN {
+                pop @ARGV;
+            }
+            die;
+        }
+    }
+}
+EOCODJ
+}
 
 done_testing($tests);
 

op.c

@@ -3677,11 +3677,16 @@ Perl_block_start(pTHX_ int full)
 {
     const int retval = PL_savestack_ix;
 
+    PL_compiling.cop_seq = PL_cop_seqmax++;
+    if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
+	PL_cop_seqmax++;
     pad_block_start(full);
     SAVEHINTS();
     PL_hints &= ~HINT_BLOCK_SCOPE;
     SAVECOMPILEWARNINGS();
     PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
+    SAVEI32(PL_compiling.cop_seq);
+    PL_compiling.cop_seq = 0;
 
     CALL_BLOCK_HOOKS(bhk_start, full);
 

pad.c

@@ -1568,8 +1568,14 @@ Perl_intro_my(pTHX)
     U32 seq;
 
     ASSERT_CURPAD_ACTIVE("intro_my");
+    if (PL_compiling.cop_seq) {
+	seq = PL_compiling.cop_seq;
+	PL_compiling.cop_seq = 0;
+    }
+    else
+	seq = PL_cop_seqmax;
     if (! PL_min_intro_pending)
-	return PL_cop_seqmax;
+	return seq;
 
     svp = AvARRAY(PL_comppad_name);
     for (i = PL_min_intro_pending; i <= PL_max_intro_pending; i++) {
@@ -1588,7 +1594,6 @@ Perl_intro_my(pTHX)
 	    );
 	}
     }
-    seq = PL_cop_seqmax;
     PL_cop_seqmax++;
     if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
 	PL_cop_seqmax++;