From: Nicholas Clark Date: Tue, 13 Mar 2007 00:01:42 +0000 (+0000) Subject: Get B compiling and passing all tests on both 5.9.x and 5.8.x X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e412117ea1226c9d124c70f29c4db6aa58f12c11;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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..4117298e 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 53cdf9f..c39a054 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 ce1cea5..7e84076 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 009161a..af86b05 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;