From: Matt S Trout Date: Tue, 26 Jun 2007 22:40:21 +0000 (+0000) Subject: handle void return, move to pure xs X-Git-Tag: 0.001000~11 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1594b447f8e0ac2e53896bd04f5784a9390ec6ab;p=p5sagit%2FDevel-BeginLift.git handle void return, move to pure xs --- diff --git a/BeginLift.xs b/BeginLift.xs new file mode 100644 index 0000000..86cd01d --- /dev/null +++ b/BeginLift.xs @@ -0,0 +1,121 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#include +#include +#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; + } diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..5c2e3cc --- /dev/null +++ b/Makefile.PL @@ -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; diff --git a/lib/Devel/BeginLift.pm b/lib/Devel/BeginLift.pm index 0d421b3..4c642b0 100644 --- a/lib/Devel/BeginLift.pm +++ b/lib/Devel/BeginLift.pm @@ -2,125 +2,14 @@ package Devel::BeginLift; use strict; use warnings; +use 5.008001; -use vars qw(%lift); - -use Inline C => <<'EOC'; -#include -#include -#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)); */ +our $VERSION = 0.01; - 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 +use vars qw(%lift); +use base qw(DynaLoader); -# C code done, now for the perl. +bootstrap Devel::BeginLift; sub import { my ($class, @args) = @_;