[Bast-commits] r3532 - in trunk/Devel-BeginLift: . lib/Devel
matthewt at dev.catalyst.perl.org
matthewt at dev.catalyst.perl.org
Tue Jun 26 23:40:21 GMT 2007
Author: matthewt
Date: 2007-06-26 23:40:21 +0100 (Tue, 26 Jun 2007)
New Revision: 3532
Added:
trunk/Devel-BeginLift/BeginLift.xs
trunk/Devel-BeginLift/Makefile.PL
Modified:
trunk/Devel-BeginLift/lib/Devel/BeginLift.pm
Log:
handle void return, move to pure xs
Added: trunk/Devel-BeginLift/BeginLift.xs
===================================================================
--- trunk/Devel-BeginLift/BeginLift.xs (rev 0)
+++ trunk/Devel-BeginLift/BeginLift.xs 2007-06-26 22:40:21 UTC (rev 3532)
@@ -0,0 +1,121 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include <stdio.h>
+#include <string.h>
+#include "proto.h"
+
+/* lifted from op.c (w/linklist -> Perl_linklist) */
+
+#define LINKLIST(o) ((o)->op_next ? (o)->op_next : Perl_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) {
+ OP *kid;
+ OP *last;
+ OP *curop;
+ HV *stash;
+ I32 type = o->op_type;
+ SV *sv;
+ char* stack_save;
+ HV* to_lift;
+ SV** to_lift_pack_ref;
+ HV* to_lift_pack_hash;
+ SV** to_lift_flag_ref;
+
+ 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 = PL_stack_sp;
+ curop = LINKLIST(o);
+ o->op_next = 0;
+ PL_op = curop;
+ CALLRUNOPS(aTHX);
+
+ if (PL_stack_sp > stack_save) { /* sub returned something */
+ sv = *(PL_stack_sp--);
+ if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
+ pad_swipe(o->op_targ, FALSE);
+ else if (SvTEMP(sv)) { /* grab mortal temp? */
+ (void)SvREFCNT_inc(sv);
+ SvTEMP_off(sv);
+ }
+ op_free(o);
+ if (type == OP_RV2GV)
+ return newGVOP(OP_GV, 0, (GV*)sv);
+ return newSVOP(OP_CONST, 0, sv);
+ } else {
+ /* this bit not lifted, handles the 'sub doesn't return stuff' case
+ which fold_constants can ignore */
+ op_free(o);
+ return newOP(OP_NULL, 0);
+ }
+}
+
+static int initialized = 0;
+
+MODULE = Devel::BeginLift PACKAGE = Devel::BeginLift
+
+PROTOTYPES: DISABLE
+
+void
+setup()
+ CODE:
+ if (!initialized++) {
+ dbl_old_ck_entersub = PL_check[OP_ENTERSUB];
+ PL_check[OP_ENTERSUB] = dbl_ck_entersub;
+ }
+
+void
+teardown()
+ 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;
+ }
Added: trunk/Devel-BeginLift/Makefile.PL
===================================================================
--- trunk/Devel-BeginLift/Makefile.PL (rev 0)
+++ trunk/Devel-BeginLift/Makefile.PL 2007-06-26 22:40:21 UTC (rev 3532)
@@ -0,0 +1,8 @@
+use inc::Module::Install 0.67;
+
+name 'Devel-BeginLift';
+license 'perl';
+author 'Matt S Trout';
+all_from 'lib/Devel/BeginLift.pm';
+
+WriteMakefile;
Modified: trunk/Devel-BeginLift/lib/Devel/BeginLift.pm
===================================================================
--- trunk/Devel-BeginLift/lib/Devel/BeginLift.pm 2007-06-26 20:03:47 UTC (rev 3531)
+++ trunk/Devel-BeginLift/lib/Devel/BeginLift.pm 2007-06-26 22:40:21 UTC (rev 3532)
@@ -2,126 +2,15 @@
use strict;
use warnings;
+use 5.008001;
+our $VERSION = 0.01;
+
use vars qw(%lift);
+use base qw(DynaLoader);
-use Inline C => <<'EOC';
-#include <stdio.h>
-#include <string.h>
-#include "proto.h"
+bootstrap Devel::BeginLift;
-/* lifted from op.c (w/linklist -> Perl_linklist) */
-
-#define LINKLIST(o) ((o)->op_next ? (o)->op_next : Perl_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) {
- OP *kid;
- OP *last;
- OP *curop;
- HV *stash;
- I32 type = o->op_type;
- SV *sv;
- char* stack_save;
- HV* to_lift;
- SV** to_lift_pack_ref;
- HV* to_lift_pack_hash;
- SV** to_lift_flag_ref;
-
- 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 = PL_stack_sp;
- curop = LINKLIST(o);
- o->op_next = 0;
- PL_op = curop;
- CALLRUNOPS(aTHX);
-
- if (PL_stack_sp > stack_save) { /* sub returned something */
- sv = *(PL_stack_sp--);
- if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
- pad_swipe(o->op_targ, FALSE);
- else if (SvTEMP(sv)) { /* grab mortal temp? */
- (void)SvREFCNT_inc(sv);
- SvTEMP_off(sv);
- }
- op_free(o);
- if (type == OP_RV2GV)
- return newGVOP(OP_GV, 0, (GV*)sv);
- return newSVOP(OP_CONST, 0, sv);
- } else {
- /* this bit not lifted, handles the 'sub doesn't return stuff' case
- which fold_constants can ignore */
- op_free(o);
- return newSVOP(OP_CONST, 0, &PL_sv_undef);
- }
-}
-
-static int initialized = 0;
-
-void setup() {
- if (!initialized++) {
- dbl_old_ck_entersub = PL_check[OP_ENTERSUB];
- PL_check[OP_ENTERSUB] = dbl_ck_entersub;
- }
-}
-
-void teardown() {
- /* 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;
- }
-}
-EOC
-
-# C code done, now for the perl.
-
sub import {
my ($class, @args) = @_;
my $target = caller;
More information about the Bast-commits
mailing list