User pragmas now accessible from B

From: "Joshua ben Jore" <twists@gmail.com>
Message-ID: <dc5c751d0612051318n2e2f08bfh185fab6323a980b@mail.gmail.com>

p4raw-id: //depot/perl@29475

diff --git a/MANIFEST b/MANIFEST
index 8d8c979..58d7ca7 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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 (file)
--- 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 (file)
--- 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 (file)
--- 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");