From: Joshua ben Jore Date: Tue, 5 Dec 2006 13:18:21 +0000 (-0800) Subject: User pragmas now accessible from B X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fd9f6265d8baae6f5a03aa84840f587026ca6455;p=p5sagit%2Fp5-mst-13.2.git User pragmas now accessible from B From: "Joshua ben Jore" Message-ID: p4raw-id: //depot/perl@29475 --- diff --git a/MANIFEST b/MANIFEST index 8d8c979..58d7ca7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -108,6 +108,7 @@ ext/B/t/o.t See if O works ext/B/t/showlex.t See if B::ShowLex works ext/B/t/terse.t See if B::Terse works ext/B/t/xref.t See if B::Xref works +ext/B/t/pragma.t See if user pragmas work. ext/B/typemap Compiler backend interface types ext/Compress/IO/Base/Changes IO::Compress::Base ext/Compress/IO/Base/lib/File/GlobMapper.pm IO::Compress::Base diff --git a/ext/B/B.pm b/ext/B/B.pm index e8d7715..e8f4a5c 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -7,7 +7,7 @@ # package B; -our $VERSION = '1.12'; +our $VERSION = '1.13'; use XSLoader (); require Exporter; diff --git a/ext/B/B.xs b/ext/B/B.xs index 9e6a8f0..3079f85 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -563,6 +563,8 @@ typedef GV *B__GV; typedef IO *B__IO; typedef MAGIC *B__MAGIC; +typedef HE *B__HE; +typedef struct refcounted_he *B__RHE; MODULE = B PACKAGE = B PREFIX = B_ @@ -1185,6 +1187,14 @@ U32 COP_hints(o) B::COP o +B::RHE +COP_hints_hash(o) + B::COP o + CODE: + RETVAL = o->cop_hints_hash; + OUTPUT: + RETVAL + MODULE = B PACKAGE = B::SV U32 @@ -1830,3 +1840,27 @@ HvARRAY(hv) PUSHs(make_sv_object(aTHX_ sv_newmortal(), sv)); } } + +MODULE = B PACKAGE = B::HE PREFIX = He + +B::SV +HeVAL(he) + B::HE he + +U32 +HeHASH(he) + B::HE he + +B::SV +HeSVKEY_force(he) + B::HE he + +MODULE = B PACKAGE = B::RHE PREFIX = RHE_ + +SV* +RHE_HASH(h) + B::RHE h + CODE: + RETVAL = newRV( (SV*)Perl_refcounted_he_chain_2hv(h) ); + OUTPUT: + RETVAL diff --git a/ext/B/t/pragma.t b/ext/B/t/pragma.t new file mode 100644 index 0000000..009161a --- /dev/null +++ b/ext/B/t/pragma.t @@ -0,0 +1,136 @@ +#!./perl -w + +BEGIN { ## no critic strict + if ( $ENV{PERL_CORE} ) { + chdir('t') if -d 't'; + @INC = qw(../lib . lib); + } + else { + unshift @INC, 't'; + } + require Config; + if ( ( $Config::Config{'extensions'} !~ /\bB\b/ ) ) { + print "1..0 # Skip -- Perl configured without B module\n"; + exit 0; + } +} + +use strict; +use warnings; +use Test::More tests => 4 * 3; +use B 'svref_2object'; + +# use Data::Dumper 'Dumper'; + +sub foo { + my ( $x, $y, $z ); + + # hh => {}, + $z = $x * $y; + + # hh => { mypragma => 42 } + use mypragma; + $z = $x + $y; + + # hh => { mypragma => 0 } + no mypragma; + $z = $x - $y; +} + +{ + + # Pragmas don't appear til they're used. + my $cop = find_op_cop( \&foo, qr/multiply/ ); + isa_ok( $cop, 'B::COP', 'found pp_multiply opnode' ); + + my $rhe = $cop->hints_hash; + isa_ok( $rhe, 'B::RHE', 'got hints_hash' ); + + my $hints_hash = $rhe->HASH; + is( ref($hints_hash), 'HASH', 'Got hash reference' ); + + ok( not( exists $hints_hash->{mypragma} ), q[! exists mypragma] ); +} + +{ + + # Pragmas can be fetched. + my $cop = find_op_cop( \&foo, qr/add/ ); + isa_ok( $cop, 'B::COP', 'found pp_add opnode' ); + + my $rhe = $cop->hints_hash; + isa_ok( $rhe, 'B::RHE', 'got hints_hash' ); + + my $hints_hash = $rhe->HASH; + is( ref($hints_hash), 'HASH', 'Got hash reference' ); + + is( $hints_hash->{mypragma}, 42, q[mypragma => 42] ); +} + +{ + + # Pragmas can be changed. + my $cop = find_op_cop( \&foo, qr/subtract/ ); + isa_ok( $cop, 'B::COP', 'found pp_subtract opnode' ); + + my $rhe = $cop->hints_hash; + isa_ok( $rhe, 'B::RHE', 'got hints_hash' ); + + my $hints_hash = $rhe->HASH; + is( ref($hints_hash), 'HASH', 'Got hash reference' ); + + is( $hints_hash->{mypragma}, 0, q[mypragma => 0] ); +} +exit; + +our $COP; + +sub find_op_cop { + my ( $sub, $op ) = @_; + my $cv = svref_2object($sub); + local $COP; + + if ( not _find_op_cop( $cv->ROOT, $op ) ) { + $COP = undef; + } + + return $COP; +} + +{ + + # Make B::NULL objects evaluate as false. + package B::NULL; + use overload 'bool' => sub () { !!0 }; +} + +sub _find_op_cop { + my ( $op, $name ) = @_; + + # Fail on B::NULL or whatever. + return 0 if not $op; + + # Succeed when we find our match. + return 1 if $op->name =~ $name; + + # Stash the latest seen COP opnode. This has our hints hash. + if ( $op->isa('B::COP') ) { + + # print Dumper( + # { cop => $op, + # hints => $op->hints_hash->HASH + # } + # ); + $COP = $op; + } + + # Recurse depth first passing success up if it happens. + if ( $op->can('first') ) { + return 1 if _find_op_cop( $op->first, $name ); + } + return 1 if _find_op_cop( $op->sibling, $name ); + + # Oh well. Hopefully our caller knows where to try next. + return 0; +} + diff --git a/ext/B/typemap b/ext/B/typemap index 99aec73..b94d2a6 100644 --- a/ext/B/typemap +++ b/ext/B/typemap @@ -32,6 +32,9 @@ SSize_t T_IV STRLEN T_UV PADOFFSET T_UV +B::HE T_HE_OBJ +B::RHE T_RHE_OBJ + INPUT T_OP_OBJ if (SvROK($arg)) { @@ -57,6 +60,22 @@ T_MG_OBJ else croak(\"$var is not a reference\") +T_HE_OBJ + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + croak(\"$var is not a reference\") + +T_RHE_OBJ + if (SvROK($arg)) { + IV tmp = SvIV((SV*)SvRV($arg)); + $var = INT2PTR($type,tmp); + } + else + croak(\"$var is not a reference\") + OUTPUT T_OP_OBJ sv_setiv(newSVrv($arg, cc_opclassname(aTHX_ (OP*)$var)), PTR2IV($var)); @@ -67,3 +86,9 @@ T_SV_OBJ T_MG_OBJ sv_setiv(newSVrv($arg, "B::MAGIC"), PTR2IV($var)); + +T_HE_OBJ + sv_setiv(newSVrv($arg, "B::HE"), PTR2IV($var)); + +T_RHE_OBJ + sv_setiv(newSVrv($arg, "B::RHE"), PTR2IV($var)); diff --git a/t/lib/mypragma.pm b/t/lib/mypragma.pm index 45244f6..fc6ee7b 100644 --- a/t/lib/mypragma.pm +++ b/t/lib/mypragma.pm @@ -30,7 +30,7 @@ use strict; use warnings; sub import { - $^H{mypragma} = 1; + $^H{mypragma} = 42; } sub unimport { diff --git a/t/lib/mypragma.t b/t/lib/mypragma.t index bd44cad..48e9865 100644 --- a/t/lib/mypragma.t +++ b/t/lib/mypragma.t @@ -22,8 +22,8 @@ is(mypragma::in_effect(), undef, "pragma not in effect yet"); or die $@; use mypragma; - is(mypragma::in_effect(), 1, "pragma is in effect within this block"); - eval qq{is(mypragma::in_effect(), 1, + is(mypragma::in_effect(), 42, "pragma is in effect within this block"); + eval qq{is(mypragma::in_effect(), 42, "pragma is in effect within this eval"); 1} or die $@; { @@ -33,8 +33,8 @@ is(mypragma::in_effect(), undef, "pragma not in effect yet"); or die $@; } - is(mypragma::in_effect(), 1, "pragma is in effect within this block"); - eval qq{is(mypragma::in_effect(), 1, + is(mypragma::in_effect(), 42, "pragma is in effect within this block"); + eval qq{is(mypragma::in_effect(), 42, "pragma is in effect within this eval"); 1} or die $@; } is(mypragma::in_effect(), undef, "pragma no longer in effect");