backport B to work on 5.8.x, so that a single version of the source

can be maintained, and ultimately dual-lifed on CPAN
(the version conditional changes are actually surprisingly small)

p4raw-id: //depot/perl@23278

8 files changed, 151 insertions, 66 deletions

diff --git a/ext/B/B.xs b/ext/B/B.xs
index ed1af11c7b..43b91fe3be 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -29,11 +29,16 @@ static char *svclassnames[] = {
     "B::PVNV",
     "B::PVMG",
     "B::BM",
+#if PERL_VERSION >= 9
     "B::GV",
+#endif
     "B::PVLV",
     "B::AV",
     "B::HV",
     "B::CV",
+#if PERL_VERSION <= 8
+    "B::GV",
+#endif
     "B::FM",
     "B::IO",
 };
@@ -416,9 +421,15 @@ oplist(pTHX_ OP *o, SV **SP)
 {
     for(; o; o = o->op_next) {
 	SV *opsv;
-	if (o->op_opt == 0) 
+#if PERL_VERSION >= 9
+	if (o->op_opt == 0)
 	    break;
 	o->op_opt = 0;
+#else
+	if (o->op_seq == 0)
+	    break;
+	o->op_seq = 0;
+#endif
 	opsv = sv_newmortal();
 	sv_setiv(newSVrv(opsv, cc_opclassname(aTHX_ (OP*)o)), PTR2IV(o));
 	XPUSHs(opsv);
@@ -494,6 +505,9 @@ BOOT:
     specialsv_list[4] = pWARN_ALL;
     specialsv_list[5] = pWARN_NONE;
     specialsv_list[6] = pWARN_STD;
+#if PERL_VERSION <= 9
+#  define CVf_ASSERTION	0
+#endif
 #include "defsubs.h"
 }
 
@@ -714,8 +728,12 @@ threadsv_names()
 #define OP_desc(o)	PL_op_desc[o->op_type]
 #define OP_targ(o)	o->op_targ
 #define OP_type(o)	o->op_type
-#define OP_opt(o)	o->op_opt
-#define OP_static(o)	o->op_static
+#if PERL_VERSION >= 9
+#  define OP_opt(o)	o->op_opt
+#  define OP_static(o)	o->op_static
+#else
+#  define OP_seq(o)	o->op_seq
+#endif
 #define OP_flags(o)	o->op_flags
 #define OP_private(o)	o->op_private
 #define OP_spare(o)	o->op_spare
@@ -773,6 +791,8 @@ U16
 OP_type(o)
 	B::OP		o
 
+#if PERL_VERSION >= 9
+
 U8
 OP_opt(o)
 	B::OP		o
@@ -781,6 +801,14 @@ U8
 OP_static(o)
 	B::OP		o
 
+#else
+
+U16
+OP_seq(o)
+	B::OP		o
+
+#endif
+
 U8
 OP_flags(o)
 	B::OP		o
@@ -789,10 +817,14 @@ U8
 OP_private(o)
 	B::OP		o
 
+#if PERL_VERSION >= 9
+
 U8
 OP_spare(o)
 	B::OP		o
 
+#endif
+
 void
 OP_oplist(o)
 	B::OP		o
diff --git a/ext/B/B/C.pm b/ext/B/B/C.pm
index 2fb763dd83..245f6f0967 100644
--- a/ext/B/B/C.pm
+++ b/ext/B/B/C.pm
@@ -226,12 +226,6 @@ sub walk_and_save_optree {
     return objsym($start);
 }
 
-# Set the values for op_opt and op_static in each op.  The value of
-# op_opt is irrelevant, and the value of op_static needs to be 1 to tell
-# op_free that this is a statically defined op and that is shouldn't be
-# freed.
-my $op_os = "0, 1, 0";
-
 # Look this up here so we can do just a number compare
 # rather than looking up the name of every BASEOP in B::OP
 my $OP_THREADSV = opnumber('threadsv');
@@ -332,6 +326,38 @@ sub B::OP::fake_ppaddr {
       'NULL';
 }
 
+# This pair is needed becase B::FAKEOP::save doesn't scalar dereference
+# $op->next and $op->sibling
+
+{
+  # For 5.9 the hard coded text is the values for op_opt and op_static in each
+  # op.  The value of op_opt is irrelevant, and the value of op_static needs to
+  # be 1 to tell op_free that this is a statically defined op and that is
+  # shouldn't be freed.
+
+  # For 5.8:
+  # Current workaround/fix for op_free() trying to free statically
+  # defined OPs is to set op_seq = -1 and check for that in op_free().
+  # Instead of hardwiring -1 in place of $op->seq, we use $op_seq
+  # so that it can be changed back easily if necessary. In fact, to
+  # stop compilers from moaning about a U16 being initialised with an
+  # uncast -1 (the printf format is %d so we can't tweak it), we have
+  # to "know" that op_seq is a U16 and use 65535. Ugh.
+
+  my $static = $] > 5.009 ? '0, 1, 0' : sprintf "%u", 65535;
+  sub B::OP::_save_common_middle {
+    my $op = shift;
+    sprintf ("%s, %u, %u, $static, 0x%x, 0x%x",
+	     $op->fake_ppaddr, $op->targ, $op->type, $op->flags, $op->private);
+  }
+}
+
+sub B::OP::_save_common {
+ my $op = shift;
+ return sprintf("s\\_%x, s\\_%x, %s",
+		${$op->next}, ${$op->sibling}, $op->_save_common_middle);
+}
+
 sub B::OP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
@@ -343,9 +369,7 @@ sub B::OP::save {
 	$init->add(sprintf("(void)find_threadsv(%s);",
 			   cstring($threadsv_names[$op->targ])));
     }
-    $opsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x",
-			 ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ,
-			 $type, $op->flags, $op->private));
+    $opsect->add($op->_save_common);
     my $ix = $opsect->index;
     $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
         unless $optimize_ppaddr;
@@ -359,9 +383,8 @@ sub B::FAKEOP::new {
 
 sub B::FAKEOP::save {
     my ($op, $level) = @_;
-    $opsect->add(sprintf("%s, %s, %s, %u, %u, $op_os, 0x%x, 0x%x",
-			 $op->next, $op->sibling, $op->fake_ppaddr, $op->targ,
-			 $op->type, $op->flags, $op->private));
+    $opsect->add(sprintf("%s, %s, %s",
+			 $op->next, $op->sibling, $op->_save_common_middle));
     my $ix = $opsect->index;
     $init->add(sprintf("op_list[$ix].op_ppaddr = %s;", $op->ppaddr))
         unless $optimize_ppaddr;
@@ -380,10 +403,7 @@ sub B::UNOP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
     return $sym if defined $sym;
-    $unopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x",
-			   ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
-			   $op->targ, $op->type, $op->flags,
-			   $op->private, ${$op->first}));
+    $unopsect->add(sprintf("%s, s\\_%x", $op->_save_common, ${$op->first}));
     my $ix = $unopsect->index;
     $init->add(sprintf("unop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
         unless $optimize_ppaddr;
@@ -394,10 +414,8 @@ sub B::BINOP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
     return $sym if defined $sym;
-    $binopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x",
-			    ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
-			    $op->targ, $op->type, $op->flags,
-			    $op->private, ${$op->first}, ${$op->last}));
+    $binopsect->add(sprintf("%s, s\\_%x, s\\_%x",
+			    $op->_save_common, ${$op->first}, ${$op->last}));
     my $ix = $binopsect->index;
     $init->add(sprintf("binop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
         unless $optimize_ppaddr;
@@ -408,10 +426,8 @@ sub B::LISTOP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
     return $sym if defined $sym;
-    $listopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x",
-			     ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
-			     $op->targ, $op->type, $op->flags,
-			     $op->private, ${$op->first}, ${$op->last}));
+    $listopsect->add(sprintf("%s, s\\_%x, s\\_%x",
+			     $op->_save_common, ${$op->first}, ${$op->last}));
     my $ix = $listopsect->index;
     $init->add(sprintf("listop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
         unless $optimize_ppaddr;
@@ -422,10 +438,8 @@ sub B::LOGOP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
     return $sym if defined $sym;
-    $logopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x",
-			    ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
-			    $op->targ, $op->type, $op->flags,
-			    $op->private, ${$op->first}, ${$op->other}));
+    $logopsect->add(sprintf("%s, s\\_%x, s\\_%x",
+			    $op->_save_common, ${$op->first}, ${$op->other}));
     my $ix = $logopsect->index;
     $init->add(sprintf("logop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
         unless $optimize_ppaddr;
@@ -439,10 +453,8 @@ sub B::LOOP::save {
     #warn sprintf("LOOP: redoop %s, nextop %s, lastop %s\n",
     #		 peekop($op->redoop), peekop($op->nextop),
     #		 peekop($op->lastop)); # debug
-    $loopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x",
-			   ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
-			   $op->targ, $op->type, $op->flags,
-			   $op->private, ${$op->first}, ${$op->last},
+    $loopsect->add(sprintf("%s, s\\_%x, s\\_%x, s\\_%x, s\\_%x, s\\_%x",
+			   $op->_save_common, ${$op->first}, ${$op->last},
 			   ${$op->redoop}, ${$op->nextop},
 			   ${$op->lastop}));
     my $ix = $loopsect->index;
@@ -455,10 +467,7 @@ sub B::PVOP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
     return $sym if defined $sym;
-    $pvopsect->add(sprintf("s\\_%x, s\\_%x, %s,  %u, %u, $op_os, 0x%x, 0x%x, %s",
-			   ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
-			   $op->targ, $op->type, $op->flags,
-			   $op->private, cstring($op->pv)));
+    $pvopsect->add(sprintf("%s, %s", $op->_save_common, cstring($op->pv)));
     my $ix = $pvopsect->index;
     $init->add(sprintf("pvop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
         unless $optimize_ppaddr;
@@ -472,11 +481,8 @@ sub B::SVOP::save {
     my $sv = $op->sv;
     my $svsym = '(SV*)' . $sv->save;
     my $is_const_addr = $svsym =~ m/Null|\&/;
-    $svopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, %s",
-			   ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
-			   $op->targ, $op->type, $op->flags,
-			   $op->private,
-                           ( $is_const_addr ? $svsym : 'Nullsv' )));
+    $svopsect->add(sprintf("%s, %s", $op->_save_common,
+			   ( $is_const_addr ? $svsym : 'Nullsv' )));
     my $ix = $svopsect->index;
     $init->add(sprintf("svop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
         unless $optimize_ppaddr;
@@ -489,10 +495,8 @@ sub B::PADOP::save {
     my ($op, $level) = @_;
     my $sym = objsym($op);
     return $sym if defined $sym;
-    $padopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, %d",
-			   ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
-			   $op->targ, $op->type, $op->flags,
-			   $op->private,$op->padix));
+    $padopsect->add(sprintf("%s, %d",
+			    $op->_save_common, $op->padix));
     my $ix = $padopsect->index;
     $init->add(sprintf("padop_list[$ix].op_ppaddr = %s;", $op->ppaddr))
         unless $optimize_ppaddr;
@@ -533,10 +537,8 @@ sub B::COP::save {
         $warn_sv = $warnings->save;
     }
 
-    $copsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, %s, NULL, NULL, %u, %d, %u, %s",
-			  ${$op->next}, ${$op->sibling}, $op->fake_ppaddr,
-			  $op->targ, $op->type, $op->flags,
-			  $op->private, cstring($op->label), $op->cop_seq,
+    $copsect->add(sprintf("%s, %s, NULL, NULL, %u, %d, %u, %s",
+			  $op->_save_common, cstring($op->label), $op->cop_seq,
 			  $op->arybase, $op->line,
                           ( $optimize_warn_sv ? $warn_sv : 'NULL' )));
     my $ix = $copsect->index;
@@ -579,10 +581,8 @@ sub B::PMOP::save {
     # pmnext handling is broken in perl itself, I think. Bad op_pmnext
     # fields aren't noticed in perl's runtime (unless you try reset) but we
     # segfault when trying to dereference it to find op->op_pmnext->op_type
-    $pmopsect->add(sprintf("s\\_%x, s\\_%x, %s, %u, %u, $op_os, 0x%x, 0x%x, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x",
-			   ${$op->next}, ${$op->sibling}, $op->fake_ppaddr, $op->targ,
-			   $op->type, $op->flags, $op->private,
-			   ${$op->first}, ${$op->last}, 
+    $pmopsect->add(sprintf("%s, s\\_%x, s\\_%x, %s, %s, 0, %u, 0x%x, 0x%x, 0x%x",
+			   $op->_save_common, ${$op->first}, ${$op->last},
 			   $replrootfield, $replstartfield,
                            ( $ithreads ? $op->pmoffset : 0 ),
 			   $op->pmflags, $op->pmpermflags, $op->pmdynflags ));
diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm
index 9259b3165b..c6ac0102b3 100644
--- a/ext/B/B/Concise.pm
+++ b/ext/B/B/Concise.pm
@@ -47,7 +47,8 @@ my %style =
     "(?(#seq)?)#noise#arg(?([#targarg])?)"],
    "debug" =>
    ["#class (#addr)\n\top_next\t\t#nextaddr\n\top_sibling\t#sibaddr\n\t"
-    . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n"
+    . "op_ppaddr\tPL_ppaddr[OP_#NAME]\n\top_type\t\t#typenum\n" .
+    ($] > 5.009 ? '' : "\top_seq\t\t#seqnum\n")
     . "\top_flags\t#flagval\n\top_private\t#privval\n"
     . "(?(\top_first\t#firstaddr\n)?)(?(\top_last\t\t#lastaddr\n)?)"
     . "(?(\top_sv\t\t#svaddr\n)?)",
@@ -432,9 +433,15 @@ sub walk_exec {
 		push @$targ, $ar;
 		push @todo, [$op->pmreplstart, $ar];
 	    } elsif ($name =~ /^enter(loop|iter)$/) {
-		$labels{${$op->nextop}} = "NEXT";
-		$labels{${$op->lastop}} = "LAST";
-		$labels{${$op->redoop}} = "REDO";
+		if ($] > 5.009) {
+		    $labels{${$op->nextop}} = "NEXT";
+		    $labels{${$op->lastop}} = "LAST";
+		    $labels{${$op->redoop}} = "REDO";
+		} else {
+		    $labels{$op->nextop->seq} = "NEXT";
+		    $labels{$op->lastop->seq} = "LAST";
+		    $labels{$op->redoop->seq} = "REDO";		
+		}
 	    }
 	}
     }
@@ -736,8 +743,14 @@ sub concise_op {
     }
     $h{seq} = $h{hyphseq} = seq($op);
     $h{seq} = "" if $h{seq} eq "-";
-    $h{opt} = $op->opt;
-    $h{static} = $op->static;
+    if ($] > 5.009) {
+	$h{opt} = $op->opt;
+	$h{static} = $op->static;
+	$h{label} = $labels{$$op};
+    } else {
+	$h{seqnum} = $op->seq;
+	$h{label} = $labels{$op->seq};
+    }
     $h{next} = $op->next;
     $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
     $h{nextaddr} = sprintf("%#x", $ {$op->next});
@@ -751,7 +764,6 @@ sub concise_op {
     $h{privval} = $op->private;
     $h{private} = private_flags($h{name}, $op->private);
     $h{addr} = sprintf("%#x", $$op);
-    $h{label} = $labels{$$op};
     $h{typenum} = $op->type;
     $h{noise} = $linenoise[$op->type];
 
@@ -850,7 +862,11 @@ sub tree {
 # a little code at the end of the module, and compute the base sequence
 # number for the user's program as being a small offset later, so all we
 # have to worry about are changes in the offset.
- 
+
+# [For 5.8.x and earlier perl is generating sequence numbers for all ops,
+#  and using them to reference labels]
+
+
 # When you say "perl -MO=Concise -e '$a'", the output should look like:
 
 # 4  <@> leave[t1] vKP/REFC ->(end)
@@ -1342,15 +1358,28 @@ The numeric value of the OP's private flags.
 The sequence number of the OP. Note that this is a sequence number
 generated by B::Concise.
 
+=item B<#seqnum>
+
+5.8.x and earlier only. 5.9 and later do not provide this.
+
+The real sequence number of the OP, as a regular number and not adjusted
+to be relative to the start of the real program. (This will generally be
+a fairly large number because all of B<B::Concise> is compiled before
+your program is).
+
 =item B<#opt>
 
 Whether or not the op has been optimised by the peephole optimiser.
 
+Only available in 5.9 and later.
+
 =item B<#static>
 
 Whether or not the op is statically defined.  This flag is used by the
 B::C compiler backend and indicates that the op should not be freed.
 
+Only available in 5.9 and later.
+
 =item B<#sibaddr>
 
 The address of the OP's next youngest sibling, in hexidecimal.
diff --git a/ext/B/B/Debug.pm b/ext/B/B/Debug.pm
index aeac17f36a..39209cf70f 100644
--- a/ext/B/B/Debug.pm
+++ b/ext/B/B/Debug.pm
@@ -11,15 +11,25 @@ my %done_gv;
 
 sub B::OP::debug {
     my ($op) = @_;
-    printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op->opt, $op->static, $op->flags, $op->private;
+    printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type;
 %s (0x%lx)
 	op_next		0x%x
 	op_sibling	0x%x
 	op_ppaddr	%s
 	op_targ		%d
 	op_type		%d
+EOT
+    if ($] > 5.009) {
+	printf <<'EOT', $op->opt, $op->static;
 	op_opt		%d
 	op_static	%d
+EOT
+    } else {
+	printf <<'EOT', $op->seq;
+	op_seq		%d
+EOT
+    }
+    printf <<'EOT', $op->flags, $op->private;
 	op_flags	%d
 	op_private	%d
 EOT
diff --git a/ext/B/t/f_map.t b/ext/B/t/f_map.t
index 478cee8e46..7d4303fbf0 100644
--- a/ext/B/t/f_map.t
+++ b/ext/B/t/f_map.t
@@ -8,7 +8,11 @@ BEGIN {
         print "1..0 # Skip -- Perl configured without B module\n";
         exit 0;
     }
-    require q(./test.pl);
+    if ($] < 5.009) {
+        print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n";
+        exit 0;
+    }
+   require q(./test.pl);
 }
 use OptreeCheck;
 plan tests => 9;
diff --git a/ext/B/t/f_sort.t b/ext/B/t/f_sort.t
index 377b41c99f..c6f6bc4958 100644
--- a/ext/B/t/f_sort.t
+++ b/ext/B/t/f_sort.t
@@ -8,6 +8,10 @@ BEGIN {
         print "1..0 # Skip -- Perl configured without B module\n";
         exit 0;
     }
+    if ($] < 5.009) {
+        print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n";
+        exit 0;
+    }
     require q(./test.pl);
 }
 use OptreeCheck;
diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t
index a8bc7907a9..c51eeaeb35 100644
--- a/ext/B/t/optree_samples.t
+++ b/ext/B/t/optree_samples.t
@@ -8,6 +8,10 @@ BEGIN {
         print "1..0 # Skip -- Perl configured without B module\n";
         exit 0;
     }
+    if ($] < 5.009) {
+        print "1..0 # Skip -- TODO - provide golden result regexps for 5.8\n";
+        exit 0;
+    }
     require './test.pl';
 }
 use OptreeCheck;
diff --git a/ext/B/t/stash.t b/ext/B/t/stash.t
index 99f96fecd8..873e484c21 100755
--- a/ext/B/t/stash.t
+++ b/ext/B/t/stash.t
@@ -73,6 +73,8 @@ $got = "@got";
 
 my $expected = "attributes Carp Carp::Heavy DB Exporter Exporter::Heavy Internals main Regexp utf8 version warnings";
 
+$expected =~ s/version // if $] < 5.009;
+
 {
     no strict 'vars';
     use vars '$OS2::is_aout';