Change 29475 by [EMAIL PROTECTED] on 2006/12/06 12:51:34
Subject: [PATCH] User pragmas now accessible from B
From: "Joshua ben Jore" <[EMAIL PROTECTED]>
Date: Tue, 5 Dec 2006 13:18:21 -0800
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/perl/MANIFEST#1490 edit
... //depot/perl/ext/B/B.pm#75 edit
... //depot/perl/ext/B/B.xs#120 edit
... //depot/perl/ext/B/t/pragma.t#1 add
... //depot/perl/ext/B/typemap#10 edit
... //depot/perl/t/lib/mypragma.pm#3 edit
... //depot/perl/t/lib/mypragma.t#4 edit
Differences ...
==== //depot/perl/MANIFEST#1490 (text) ====
Index: perl/MANIFEST
--- perl/MANIFEST#1489~29455~ 2006-12-04 07:38:05.000000000 -0800
+++ perl/MANIFEST 2006-12-06 04:51:34.000000000 -0800
@@ -108,6 +108,7 @@
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
==== //depot/perl/ext/B/B.pm#75 (text) ====
Index: perl/ext/B/B.pm
--- perl/ext/B/B.pm#74~29062~ 2006-10-20 04:51:57.000000000 -0700
+++ perl/ext/B/B.pm 2006-12-06 04:51:34.000000000 -0800
@@ -7,7 +7,7 @@
#
package B;
-our $VERSION = '1.12';
+our $VERSION = '1.13';
use XSLoader ();
require Exporter;
==== //depot/perl/ext/B/B.xs#120 (text) ====
Index: perl/ext/B/B.xs
--- perl/ext/B/B.xs#119~29062~ 2006-10-20 04:51:57.000000000 -0700
+++ perl/ext/B/B.xs 2006-12-06 04:51:34.000000000 -0800
@@ -563,6 +563,8 @@
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 @@
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 @@
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
==== //depot/perl/ext/B/t/pragma.t#1 (text) ====
Index: perl/ext/B/t/pragma.t
--- /dev/null 2006-11-16 10:04:37.532058837 -0800
+++ perl/ext/B/t/pragma.t 2006-12-06 04:51:34.000000000 -0800
@@ -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;
+}
+
==== //depot/perl/ext/B/typemap#10 (text) ====
Index: perl/ext/B/typemap
--- perl/ext/B/typemap#9~20220~ 2003-07-27 08:13:10.000000000 -0700
+++ perl/ext/B/typemap 2006-12-06 04:51:34.000000000 -0800
@@ -32,6 +32,9 @@
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 @@
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_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));
==== //depot/perl/t/lib/mypragma.pm#3 (text) ====
Index: perl/t/lib/mypragma.pm
--- perl/t/lib/mypragma.pm#2~27666~ 2006-04-01 13:17:46.000000000 -0800
+++ perl/t/lib/mypragma.pm 2006-12-06 04:51:34.000000000 -0800
@@ -30,7 +30,7 @@
use warnings;
sub import {
- $^H{mypragma} = 1;
+ $^H{mypragma} = 42;
}
sub unimport {
==== //depot/perl/t/lib/mypragma.t#4 (text) ====
Index: perl/t/lib/mypragma.t
--- perl/t/lib/mypragma.t#3~27667~ 2006-04-01 15:09:34.000000000 -0800
+++ perl/t/lib/mypragma.t 2006-12-06 04:51:34.000000000 -0800
@@ -22,8 +22,8 @@
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 @@
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");
End of Patch.
