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

p4raw-id: //depot/perl@30558

diff --git a/ext/B/B.pm b/ext/B/B.pm
index 2e5409c..caccf4b 100644 (file)
--- 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 eb7157b..6fdac03 100644 (file)
--- 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 8fe96b0..224410c 100644 (file)
--- 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 2bc0a1f..e55eae7 100644 (file)
--- 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 b6be017..0b12510 100644 (file)
--- 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 d3711cc..3ce4625 100644 (file)
--- 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 b81d4c3..4117298 100644 (file)
--- 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 53cdf9f..c39a054 100644 (file)
--- 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 ce1cea5..7e84076 100644 (file)
--- 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 009161a..af86b05 100644 (file)
--- 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;