Get B compiling and passing all tests on both 5.9.x and 5.8.x

p4raw-id: //depot/perl@30558

10 files changed, 137 insertions, 44 deletions

diff --git a/ext/B/B.pm b/ext/B/B.pm
index 2e5409ca58..caccf4bfb0 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -21,9 +21,10 @@ require Exporter;
 		sub_generation amagic_generation perlstring
 		walkoptree_slow walkoptree walkoptree_exec walksymtable
 		parents comppadlist sv_undef compile_stats timing_info
-		begin_av init_av unitcheck_av check_av end_av regex_padav
-		dowarn defstash curstash warnhook diehook inc_gv
+		begin_av init_av check_av end_av regex_padav dowarn defstash
+		curstash warnhook diehook inc_gv
 		);
+push @EXPORT_OK, qw(unitcheck_av) if $] > 5.009;
 
 sub OPf_KIDS ();
 use strict;
diff --git a/ext/B/B.xs b/ext/B/B.xs
index eb7157b157..6fdac03042 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -251,6 +251,7 @@ make_sv_object(pTHX_ SV *arg, SV *sv)
     return arg;
 }
 
+#if PERL_VERSION >= 9
 static SV *
 make_temp_object(pTHX_ SV *arg, SV *temp)
 {
@@ -313,6 +314,7 @@ make_cop_io_object(pTHX_ SV *arg, COP *cop)
 	return make_sv_object(aTHX_ arg, NULL);
     }
 }
+#endif
 
 static SV *
 make_mg_object(pTHX_ SV *arg, MAGIC *mg)
@@ -565,7 +567,9 @@ typedef IO	*B__IO;
 
 typedef MAGIC	*B__MAGIC;
 typedef HE      *B__HE;
+#if PERL_VERSION >= 9
 typedef struct refcounted_he	*B__RHE;
+#endif
 
 MODULE = B	PACKAGE = B	PREFIX = B_
 
@@ -623,9 +627,13 @@ B_init_av()
 B::AV
 B_check_av()
 
+#if PERL_VERSION >= 9
+
 B::AV
 B_unitcheck_av()
 
+#endif
+
 B::AV
 B_begin_av()
 
@@ -1139,6 +1147,10 @@ LOOP_lastop(o)
 #define COP_arybase(o)	CopARYBASE_get(o)
 #define COP_line(o)	CopLINE(o)
 #define COP_hints(o)	CopHINTS_get(o)
+#if PERL_VERSION < 9
+#  define COP_warnings(o)  o->cop_warnings
+#  define COP_io(o)	o->cop_io
+#endif
 
 MODULE = B	PACKAGE = B::COP		PREFIX = COP_
 
@@ -1175,6 +1187,8 @@ U32
 COP_line(o)
 	B::COP	o
 
+#if PERL_VERSION >= 9
+
 void
 COP_warnings(o)
 	B::COP	o
@@ -1189,10 +1203,6 @@ COP_io(o)
 	ST(0) = make_cop_io_object(aTHX_ sv_newmortal(), o);
 	XSRETURN(1);
 
-U32
-COP_hints(o)
-	B::COP	o
-
 B::RHE
 COP_hints_hash(o)
 	B::COP o
@@ -1201,6 +1211,22 @@ COP_hints_hash(o)
     OUTPUT:
 	RETVAL
 
+#else
+
+B::SV
+COP_warnings(o)
+	B::COP	o
+
+B::SV
+COP_io(o)
+	B::COP	o
+
+#endif
+
+U32
+COP_hints(o)
+	B::COP	o
+
 MODULE = B	PACKAGE = B::SV
 
 U32
@@ -1882,6 +1908,8 @@ HeSVKEY_force(he)
 
 MODULE = B	PACKAGE = B::RHE	PREFIX = RHE_
 
+#if PERL_VERSION >= 9
+
 SV*
 RHE_HASH(h)
 	B::RHE h
@@ -1889,3 +1917,5 @@ RHE_HASH(h)
 	RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(aTHX_ h) );
     OUTPUT:
 	RETVAL
+
+#endif
diff --git a/ext/B/B/Deparse.pm b/ext/B/B/Deparse.pm
index 8fe96b0b27..224410ceb8 100644
--- a/ext/B/B/Deparse.pm
+++ b/ext/B/B/Deparse.pm
@@ -608,6 +608,7 @@ sub init {
 				? $self->{'ambient_warnings'} & WARN_MASK
 				: undef;
     $self->{'hints'}    = $self->{'ambient_hints'};
+    $self->{'hints'} &= 0xFF if $] < 5.009;
 
     # also a convenient place to clear out subs_declared
     delete $self->{'subs_declared'};
diff --git a/ext/B/defsubs_h.PL b/ext/B/defsubs_h.PL
index 2bc0a1f270..e55eae7beb 100644
--- a/ext/B/defsubs_h.PL
+++ b/ext/B/defsubs_h.PL
@@ -23,7 +23,6 @@ foreach my $const (qw(
 		      CVf_LVALUE
 		      CVf_METHOD
 		      CVf_NODEBUG
-		      CVf_ISXSUB
 		      CVf_UNIQUE
 		      CVf_WEAKOUTSIDE
 		      GVf_IMPORTED_AV
@@ -60,6 +59,11 @@ if ($] < 5.009) {
     doconst(OPpPAD_STATE);
 }
 
+if ($] >= 5.009) {
+    # Constant not present in 5.8.x
+    doconst(CVf_ISXSUB);
+}
+
 foreach my $file (qw(op.h cop.h))
  {
   my $path = $^O eq 'MacOS' ? ":::$file" : "../../$file";
diff --git a/ext/B/t/OptreeCheck.pm b/ext/B/t/OptreeCheck.pm
index b6be0172e7..0b12510d91 100644
--- a/ext/B/t/OptreeCheck.pm
+++ b/ext/B/t/OptreeCheck.pm
@@ -714,7 +714,28 @@ sub mkCheckRex {
 		$
 	       ]
 	[$1 . ($2 && ':{') . $4]xegm;	# change to the hints without open.pm
-      }
+    }
+
+    if ($] < 5.009) {
+	# 5.8.x doesn't provide the hints in the OP, which means that
+	# B::Concise doesn't show the symbolic hints. So strip all the
+	# symbolic hints from the golden results.
+	$str =~ s[(			# capture
+		   \(\?:next\|db\)state	# the regexp matching next/db state
+		   .*			# all sorts of things follow it
+		  v			# The opening v
+		  )
+		  :(?:\\[{*]		# \{ or \*
+		      |[^,\\])		# or other symbols on their own
+		    (?:,
+		     (?:\\[{*]
+			|[^,\\])
+		      )*		# maybe some more joined with commas
+		(\ ->[0-9a-z]+)?
+		$
+	       ]
+	[$1$2]xgm;			# change to the hints without flags
+    }
 
     # don't care about:
     $str =~ s/:-?\d+,-?\d+/:-?\\d+,-?\\d+/msg;		# FAKE line numbers
diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t
index d3711cccbb..3ce4625591 100644
--- a/ext/B/t/concise-xs.t
+++ b/ext/B/t/concise-xs.t
@@ -119,9 +119,9 @@ use Test::More tests => ( # per-pkg tests (function ct + require_ok)
 			  40 + 16	# Data::Dumper, Digest::MD5
 			  + 517 + 239	# B::Deparse, B
 			  + 595 + 190	# POSIX, IO::Socket
-			  + 3 * ($] > 5.009)
-			  + 16 * ($] >= 5.009003)
-			  - 22);	# fudge
+			  + 346 * ($] > 5.009)
+			  + 17 * ($] >= 5.009003)
+			  - 366);	# fudge
 
 require_ok("B::Concise");
 
@@ -157,8 +157,7 @@ my $testpkgs = {
 		  formfeed end_av dowarn diehook defstash curstash
 		  cstring comppadlist check_av cchar cast_I32 bootstrap
 		  begin_av amagic_generation sub_generation address
-		  unitcheck_av
-		  )],
+		  ), $] > 5.009 ? ('unitcheck_av') : ()],
     },
 
     B::Deparse => { dflt => 'perl',	# 235 functions
@@ -214,8 +213,8 @@ my $testpkgs = {
 			     register_domain recv protocol peername
 			     new listen import getsockopt croak
 			     connected connect configure confess close
-			     carp bind atmark accept blocking
-			     /],
+			     carp bind atmark accept
+			     /, $] > 5.009 ? ('blocking') : () ],
 
 		    XS => [qw/ unpack_sockaddr_un unpack_sockaddr_in
 			   sockatmark sockaddr_family pack_sockaddr_un
diff --git a/ext/B/t/f_sort.t b/ext/B/t/f_sort.t
index b81d4c3a1e..4117298e54 100644
--- a/ext/B/t/f_sort.t
+++ b/ext/B/t/f_sort.t
@@ -664,10 +664,7 @@ use sort 'stable';
 
 =cut
 
-checkOptree(note   => q{},
-	    bcopts => q{-exec},
-	    code   => q{use sort 'stable'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; },
-	    expect => <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
 # 1  <;> nextstate(main 656 (eval 40):1) v:%,{
 # 2  <0> pushmark s
 # 3  <0> pushmark s
@@ -692,7 +689,16 @@ EOT_EOT
 # a  <2> aassign[t6] KS/COMMON
 # b  <1> leavesub[1 ref] K/REFC,1
 EONT_EONT
-    
+
+if($] < 5.009) {
+    # 5.8.x doesn't show the /STABLE flag, so massage the golden results.
+    s!/STABLE!!s foreach ($expect, $expect_nt);
+}
+
+checkOptree(note   => q{},
+	    bcopts => q{-exec},
+	    code   => q{use sort 'stable'; @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; },
+	    expect => $expect, expect_nt => $expect_nt);
 
 =for gentest
 
diff --git a/ext/B/t/optree_constants.t b/ext/B/t/optree_constants.t
index 53cdf9f325..c39a054456 100644
--- a/ext/B/t/optree_constants.t
+++ b/ext/B/t/optree_constants.t
@@ -44,20 +44,28 @@ sub myno () { return 1!=1 }
 sub pi () { 3.14159 };
 
 my $want = {	# expected types, how value renders in-line, todos (maybe)
-    myfl	=> [ 'NV', myfl ],
-    myint	=> [ 'IV', myint ],
     mystr	=> [ 'PV', '"'.mystr.'"' ],
     myhref	=> [ 'RV', '\\\\HASH'],
-    myundef	=> [ 'NULL', ],
     pi		=> [ 'NV', pi ],
-    myaref	=> [ 'RV', '\\\\' ],
     myglob	=> [ 'RV', '\\\\' ],
-    myrex	=> [ 'RV', '\\\\' ],
     mysub	=> [ 'RV', '\\\\' ],
     myunsub	=> [ 'RV', '\\\\' ],
     # these are not inlined, at least not per BC::Concise
     #myyes	=> [ 'RV', ],
     #myno	=> [ 'RV', ],
+    $] > 5.009 ? (
+    myaref	=> [ 'RV', '\\\\' ],
+    myfl	=> [ 'NV', myfl ],
+    myint	=> [ 'IV', myint ],
+    myrex	=> [ 'RV', '\\\\' ],
+    myundef	=> [ 'NULL', ],
+    ) : (
+    myaref	=> [ 'PVIV', '' ],
+    myfl	=> [ 'PVNV', myfl ],
+    myint	=> [ 'PVIV', myint ],
+    myrex	=> [ 'PVNV', '' ],
+    myundef	=> [ 'PVIV', ],
+    )
 };
 
 use constant WEEKDAYS
@@ -128,17 +136,18 @@ EONT_EONT
 checkOptree ( name	=> 'myyes() as coderef',
 	      prog	=> 'sub a() { 1==1 }; print a',
 	      noanchors => 1,
+	      strip_open_hints => 1,
 	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 # 6  <@> leave[1 ref] vKP/REFC ->(end)
 # 1     <0> enter ->2
-# 2     <;> nextstate(main 2 -e:1) v:{ ->3
+# 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
 # 5     <@> print vK ->6
 # 3        <0> pushmark s ->4
 # 4        <$> const[SPECIAL sv_yes] s ->5
 EOT_EOT
 # 6  <@> leave[1 ref] vKP/REFC ->(end)
 # 1     <0> enter ->2
-# 2     <;> nextstate(main 2 -e:1) v:{ ->3
+# 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
 # 5     <@> print vK ->6
 # 3        <0> pushmark s ->4
 # 4        <$> const(SPECIAL sv_yes) s ->5
@@ -151,27 +160,25 @@ EONT_EONT
 checkOptree ( name	=> 'myno() as coderef',
 	      prog	=> 'sub a() { 1!=1 }; print a',
 	      noanchors => 1,
+	      strip_open_hints => 1,
 	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 # 6  <@> leave[1 ref] vKP/REFC ->(end)
 # 1     <0> enter ->2
-# 2     <;> nextstate(main 2 -e:1) v:{ ->3
+# 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
 # 5     <@> print vK ->6
 # 3        <0> pushmark s ->4
 # 4        <$> const[SPECIAL sv_no] s ->5
 EOT_EOT
 # 6  <@> leave[1 ref] vKP/REFC ->(end)
 # 1     <0> enter ->2
-# 2     <;> nextstate(main 2 -e:1) v:{ ->3
+# 2     <;> nextstate(main 2 -e:1) v:>,<,%,{ ->3
 # 5     <@> print vK ->6
 # 3        <0> pushmark s ->4
 # 4        <$> const(SPECIAL sv_no) s ->5
 EONT_EONT
 
 
-checkOptree ( name	=> 'constant sub returning list',
-	      code	=> \&WEEKDAYS,
-	      noanchors => 1,
-	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
 # 3  <1> leavesub[2 refs] K/REFC,1 ->(end)
 # -     <@> lineseq K ->3
 # 1        <;> nextstate(constant 61 constant.pm:118) v:*,& ->2
@@ -183,16 +190,23 @@ EOT_EOT
 # 2        <0> padav[@list:FAKE:m:71] ->3
 EONT_EONT
 
+if($] < 5.009) {
+    # 5.8.x doesn't add the m flag to padav
+    s/FAKE:m:\d+/FAKE/ foreach ($expect, $expect_nt);
+}
+
+checkOptree ( name	=> 'constant sub returning list',
+	      code	=> \&WEEKDAYS,
+	      noanchors => 1,
+	      expect => $expect, expect_nt => $expect_nt);
+
 
 sub printem {
     printf "myint %d mystr %s myfl %f pi %f\n"
 	, myint, mystr, myfl, pi;
 }
 
-checkOptree ( name	=> 'call many in a print statement',
-	      code	=> \&printem,
-	      strip_open_hints => 1,
-	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
 # -     <@> lineseq KP ->9
 # 1        <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
@@ -216,6 +230,18 @@ EOT_EOT
 # 7           <$> const(NV 3.14159) s ->8
 EONT_EONT
 
+if($] < 5.009) {
+    # 5.8.x's use constant has larger types
+    foreach ($expect, $expect_nt) {
+	s/IV 42/PV$&/;
+	s/NV 1.41/PV$&/;
+    }
+}
+
+checkOptree ( name	=> 'call many in a print statement',
+	      code	=> \&printem,
+	      strip_open_hints => 1,
+	      expect => $expect, expect_nt => $expect_nt);
 
 } #skip
 
diff --git a/ext/B/t/optree_specials.t b/ext/B/t/optree_specials.t
index ce1cea5e9c..7e84076f8c 100644
--- a/ext/B/t/optree_specials.t
+++ b/ext/B/t/optree_specials.t
@@ -27,7 +27,7 @@ BEGIN {
 use OptreeCheck;	# ALSO DOES @ARGV HANDLING !!!!!!
 use Config;
 
-plan tests => 8;
+plan tests => 7 + ($] > 5.009 ? 1 : 0);
 
 require_ok("B::Concise");
 
@@ -144,11 +144,12 @@ EOT_EOT
 # 2              <$> gvsv(*chk) s ->3
 EONT_EONT
 
-checkOptree ( name	=> 'UNITCHECK',
-	      bcopts	=> 'UNITCHECK',
-	      prog	=> $src,
-	      strip_open_hints => 1,
-	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
+if ($] >= 5.009) {
+    checkOptree ( name	=> 'UNITCHECK',
+		  bcopts=> 'UNITCHECK',
+		  prog	=> $src,
+		  strip_open_hints => 1,
+		  expect=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
 # UNITCHECK 1:
 # 4  <1> leavesub[1 ref] K/REFC,1 ->(end)
 # -     <@> lineseq KP ->4
@@ -165,7 +166,7 @@ EOT_EOT
 # -           <1> ex-rv2sv sKRM/1 ->3
 # 2              <$> gvsv(*uc) s ->3
 EONT_EONT
-
+}
 
 checkOptree ( name	=> 'INIT',
 	      bcopts	=> 'INIT',
diff --git a/ext/B/t/pragma.t b/ext/B/t/pragma.t
index 009161ab57..af86b05345 100644
--- a/ext/B/t/pragma.t
+++ b/ext/B/t/pragma.t
@@ -13,6 +13,10 @@ BEGIN {    ## no critic strict
         print "1..0 # Skip -- Perl configured without B module\n";
         exit 0;
     }
+    if ( $] < 5.009 ) {
+        print "1..0 # Skip -- No user pragmata in 5.8.x\n";
+        exit 0;
+    }
 }
 
 use strict;