[Bast-commits] r4984 - in Devel-BeginLift/1.000/trunk: . lib/Devel t
rafl at dev.catalyst.perl.org
rafl at dev.catalyst.perl.org
Sat Oct 25 12:22:39 BST 2008
Author: rafl
Date: 2008-10-25 12:22:39 +0100 (Sat, 25 Oct 2008)
New Revision: 4984
Modified:
Devel-BeginLift/1.000/trunk/BeginLift.xs
Devel-BeginLift/1.000/trunk/Makefile.PL
Devel-BeginLift/1.000/trunk/lib/Devel/BeginLift.pm
Devel-BeginLift/1.000/trunk/t/generate.t
Log:
Merge branch 'entersub_for_cv'
* entersub_for_cv:
Plan for t/generate.t.
Document *_for_cv.
Turn *_for_cv into classmethods.
Require EntersubForCV 0.02.
Rename _setup and _teardown to {setup,teardown}_for_cv.
Return a nullop if the liftee returns a null sv.
Port to B::Hooks::OP::Check::EntersubForCV.
Create branch 'entersub_for_cv'.
Modified: Devel-BeginLift/1.000/trunk/BeginLift.xs
===================================================================
--- Devel-BeginLift/1.000/trunk/BeginLift.xs 2008-10-25 10:51:57 UTC (rev 4983)
+++ Devel-BeginLift/1.000/trunk/BeginLift.xs 2008-10-25 11:22:39 UTC (rev 4984)
@@ -6,72 +6,19 @@
#include <stdio.h>
#include <string.h>
+#include "hook_op_check_entersubforcv.h"
+
/* lifted from op.c */
#define LINKLIST(o) ((o)->op_next ? (o)->op_next : linklist((OP*)o))
-/* pointer to old PL_check entersub entry to be populated in init */
-
-STATIC OP *(*dbl_old_ck_entersub)(pTHX_ OP *op);
-
-/* replacement PL_check entersub entry */
-
-STATIC OP *dbl_ck_entersub(pTHX_ OP *o) {
+STATIC OP *lift_cb(pTHX_ OP *o, CV *cv, void *user_data) {
dSP;
- OP *kid;
- OP *last;
- OP *curop;
- OP *saved_next;
- HV *stash;
- I32 type = o->op_type;
SV *sv;
- SV** stack_save;
- HV* to_lift;
- SV** to_lift_pack_ref;
- HV* to_lift_pack_hash;
- SV** to_lift_flag_ref;
+ SV **stack_save;
+ OP *curop, *kid, *saved_next;
+ I32 type = o->op_type;
- o = dbl_old_ck_entersub(aTHX_ o); /* let the original do its job */
-
- kid = cUNOPo->op_first;
-
- if (kid->op_type != OP_NULL) /* pushmark for method call ... */
- return o;
-
- last = kLISTOP->op_last;
-
- if (last->op_type != OP_NULL) /* not what we expected */
- return o;
-
- kid = cUNOPx(last)->op_first;
-
- if (kid->op_type != OP_GV) /* not a GV so ignore */
- return o;
-
- stash = GvSTASH(kGVOP_gv);
-
- /* printf("Calling GV %s -> %s\n",
- HvNAME(stash), GvNAME(kGVOP_gv)); */
-
- to_lift = get_hv("Devel::BeginLift::lift", FALSE);
-
- if (!to_lift)
- return o;
-
- to_lift_pack_ref = hv_fetch(to_lift, HvNAME(stash), strlen(HvNAME(stash)),
- FALSE);
-
- if (!to_lift_pack_ref || !SvROK(*to_lift_pack_ref))
- return o; /* not a hashref */
-
- to_lift_pack_hash = (HV*) SvRV(*to_lift_pack_ref);
-
- to_lift_flag_ref = hv_fetch(to_lift_pack_hash, GvNAME(kGVOP_gv),
- strlen(GvNAME(kGVOP_gv)), FALSE);
-
- if (!to_lift_flag_ref || !SvTRUE(*to_lift_flag_ref))
- return o;
-
/* shamelessly lifted from fold_constants in op.c */
stack_save = SP;
@@ -151,25 +98,18 @@
}
}
-static int initialized = 0;
-
MODULE = Devel::BeginLift PACKAGE = Devel::BeginLift
PROTOTYPES: DISABLE
-void
-setup()
+UV
+setup_for_cv (class, CV *cv)
CODE:
- if (!initialized++) {
- dbl_old_ck_entersub = PL_check[OP_ENTERSUB];
- PL_check[OP_ENTERSUB] = dbl_ck_entersub;
- }
+ RETVAL = (UV)hook_op_check_entersubforcv (cv, lift_cb, NULL);
+ OUTPUT:
+ RETVAL
void
-teardown()
+teardown_for_cv (class, UV id)
CODE:
- /* ensure we only uninit when number of teardown calls matches
- number of setup calls */
- if (initialized && !--initialized) {
- PL_check[OP_ENTERSUB] = dbl_old_ck_entersub;
- }
+ hook_op_check_entersubforcv_remove ((hook_op_check_id)id);
Modified: Devel-BeginLift/1.000/trunk/Makefile.PL
===================================================================
--- Devel-BeginLift/1.000/trunk/Makefile.PL 2008-10-25 10:51:57 UTC (rev 4983)
+++ Devel-BeginLift/1.000/trunk/Makefile.PL 2008-10-25 11:22:39 UTC (rev 4984)
@@ -1,12 +1,23 @@
use inc::Module::Install 0.67;
+use ExtUtils::Depends;
+
name 'Devel-BeginLift';
all_from 'lib/Devel/BeginLift.pm';
+requires 'B::Hooks::OP::Check::EntersubForCV' => '0.02';
+
build_requires 'Test::More';
+build_requires 'B::Hooks::OP::Check::EntersubForCV';
+configure_requires 'ExtUtils::Depends';
+configure_requires 'B::Hooks::OP::Check::EntersubForCV';
+
+my $pkg = ExtUtils::Depends->new('Devel::Declare', 'B::Hooks::OP::Check::EntersubForCV');
+
WriteMakefile(
dist => {
PREOP => 'pod2text lib/Devel/BeginLift.pm >$(DISTVNAME)/README'
- }
+ },
+ $pkg->get_makefile_vars,
);
Modified: Devel-BeginLift/1.000/trunk/lib/Devel/BeginLift.pm
===================================================================
--- Devel-BeginLift/1.000/trunk/lib/Devel/BeginLift.pm 2008-10-25 10:51:57 UTC (rev 4983)
+++ Devel-BeginLift/1.000/trunk/lib/Devel/BeginLift.pm 2008-10-25 11:22:39 UTC (rev 4984)
@@ -8,6 +8,7 @@
use vars qw(%lift);
use base qw(DynaLoader);
+use B::Hooks::OP::Check::EntersubForCV;
bootstrap Devel::BeginLift;
@@ -25,14 +26,20 @@
sub setup_for {
my ($class, $target, $args) = @_;
- setup();
- $lift{$target}{$_} = 1 for @$args;
+ $lift{$target} ||= [];
+ push @{ $lift{$target} }, map {
+ $class->setup_for_cv($_);
+ } map {
+ ref $_ eq 'CODE'
+ ? $_
+ : \&{ "${target}::${_}" }
+ } @{ $args };
}
sub teardown_for {
my ($class, $target) = @_;
+ $class->teardown_for_cv($_) for @{ $lift{$target} };
delete $lift{$target};
- teardown();
}
=head1 NAME
@@ -104,6 +111,19 @@
lifting magic is number of teardown_for calls matches number of setup_for
calls.
+=head2 setup_for_cv
+
+ $id = Devel::BeginLift->setup_for_cv(\&code);
+
+Same as C<setup_for>, but only registers begin lifting magic for one code
+reference. Returns an id to be used in C<teardown_for_cv>.
+
+=head2 teardown_for_cv
+
+ Devel::BeginLift->teardown_for_cv($id);
+
+Deregisters begin lifting magic referred to by C<$id>.
+
=head1 AUTHOR
Matt S Trout - <mst at shadowcatsystems.co.uk>
Modified: Devel-BeginLift/1.000/trunk/t/generate.t
===================================================================
--- Devel-BeginLift/1.000/trunk/t/generate.t 2008-10-25 10:51:57 UTC (rev 4983)
+++ Devel-BeginLift/1.000/trunk/t/generate.t 2008-10-25 11:22:39 UTC (rev 4984)
@@ -6,7 +6,7 @@
BEGIN {
plan skip_all => "B::Generate required" unless eval { require B::Generate };
- plan 'no_plan';
+ plan tests => 2;
}
sub foo {
More information about the Bast-commits
mailing list