ext/XS-APItest/t/call_checker.t test call checker plugin API
ext/XS-APItest/t/caller.t XS::APItest: tests for caller_cx
ext/XS-APItest/t/call.t XS::APItest extension
+ext/XS-APItest/t/cleanup.t test stack behaviour on unwinding
ext/XS-APItest/t/cophh.t test COPHH API
ext/XS-APItest/t/copyhints.t test hv_copy_hints_hv() API
ext/XS-APItest/t/exception.t XS::APItest extension
return SvPVX(rv);
}
+/** establish_cleanup operator, ripped off from Scope::Cleanup **/
+
+STATIC void
+THX_run_cleanup(pTHX_ void *cleanup_code_ref)
+{
+ dSP;
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+ call_sv((SV*)cleanup_code_ref, G_VOID|G_DISCARD);
+ FREETMPS;
+ LEAVE;
+}
+
+STATIC OP *
+THX_pp_establish_cleanup(pTHX)
+{
+ dSP;
+ SV *cleanup_code_ref;
+ cleanup_code_ref = newSVsv(POPs);
+ SAVEFREESV(cleanup_code_ref);
+ SAVEDESTRUCTOR_X(THX_run_cleanup, cleanup_code_ref);
+ if(GIMME_V != G_VOID) PUSHs(&PL_sv_undef);
+ RETURN;
+}
+
+STATIC OP *
+THX_ck_entersub_establish_cleanup(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
+{
+ OP *pushop, *argop, *estop;
+ ck_entersub_args_proto(entersubop, namegv, ckobj);
+ pushop = cUNOPx(entersubop)->op_first;
+ if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first;
+ argop = pushop->op_sibling;
+ pushop->op_sibling = argop->op_sibling;
+ argop->op_sibling = NULL;
+ op_free(entersubop);
+ NewOpSz(0, estop, sizeof(UNOP));
+ estop->op_type = OP_RAND;
+ estop->op_ppaddr = THX_pp_establish_cleanup;
+ cUNOPx(estop)->op_flags = OPf_KIDS;
+ cUNOPx(estop)->op_first = argop;
+ PL_hints |= HINT_BLOCK_SCOPE;
+ return estop;
+}
+
/** RPN keyword parser **/
#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
next_keyword_plugin = PL_keyword_plugin;
PL_keyword_plugin = my_keyword_plugin;
}
+
+void
+establish_cleanup(...)
+PROTOTYPE: $
+CODE:
+ croak("establish_cleanup called as a function");
+
+BOOT:
+{
+ CV *estcv = get_cv("XS::APItest::establish_cleanup", 0);
+ cv_set_call_checker(estcv, THX_ck_entersub_establish_cleanup, (SV*)estcv);
+}
--- /dev/null
+use warnings;
+use strict;
+
+use Test::More tests => 3;
+
+use XS::APItest qw(establish_cleanup);
+
+my @events;
+
+# unwinding on local return from sub
+
+sub aa {
+ push @events, "aa0";
+ establish_cleanup sub { push @events, "bb0" };
+ push @events, "aa1";
+ "aa2";
+}
+
+sub cc {
+ push @events, "cc0";
+ push @events, [ "cc1", aa() ];
+ push @events, "cc2";
+ "cc3";
+}
+
+@events = ();
+push @events, "dd0";
+push @events, [ "dd1", cc() ];
+is_deeply \@events, [
+ "dd0",
+ "cc0",
+ "aa0",
+ "aa1",
+ "bb0",
+ [ "cc1", "aa2" ],
+ "cc2",
+ [ "dd1", "cc3" ],
+];
+
+# unwinding on local return from format
+
+sub ff { push @events, "ff0" }
+
+format EE =
+@<<
+((push @events, "ee0"), (establish_cleanup \&ff), (push @events, "ee1"), "ee2")
+.
+
+sub gg {
+ push @events, "gg0";
+ write(EE);
+ push @events, "gg1";
+ "gg2";
+}
+
+@events = ();
+open EE, ">", \(my $ee);
+push @events, "hh0";
+push @events, [ "hh1", gg() ];
+close EE;
+is_deeply \@events, [
+ "hh0",
+ "gg0",
+ "ee0",
+ "ee1",
+ "ff0",
+ "gg1",
+ [ "hh1", "gg2" ],
+];
+
+# unwinding on die
+
+sub pp {
+ my $value = eval {
+ push @events, "pp0";
+ establish_cleanup sub { push @events, "qq0" };
+ push @events, "pp1";
+ die "pp2\n";
+ push @events, "pp3";
+ "pp4";
+ };
+ [ "pp5", $value, $@ ];
+}
+
+@events = ();
+push @events, "rr0";
+push @events, [ "rr1", pp() ];
+is_deeply \@events, [
+ "rr0",
+ "pp0",
+ "pp1",
+ "qq0",
+ [ "rr1", [ "pp5", undef, "pp2\n" ] ],
+];
+
+1;
SV *namesv;
register PERL_CONTEXT *cx;
SV **newsp;
+ COP *oldcop;
+ JMPENV *restartjmpenv;
+ OP *restartop;
if (cxix < cxstack_ix)
dounwind(cxix);
}
POPEVAL(cx);
namesv = cx->blk_eval.old_namesv;
+ oldcop = cx->blk_oldcop;
+ restartjmpenv = cx->blk_eval.cur_top_env;
+ restartop = cx->blk_eval.retop;
if (gimme == G_SCALAR)
*++newsp = &PL_sv_undef;
* XXX it might be better to find a way to avoid messing with
* PL_curcop in save_re_context() instead, but this is a more
* minimal fix --GSAR */
- PL_curcop = cx->blk_oldcop;
+ PL_curcop = oldcop;
if (optype == OP_REQUIRE) {
const char* const msg = SvPVx_nolen_const(exceptsv);
else {
sv_setsv(ERRSV, exceptsv);
}
- assert(CxTYPE(cx) == CXt_EVAL);
- PL_restartjmpenv = cx->blk_eval.cur_top_env;
- PL_restartop = cx->blk_eval.retop;
+ PL_restartjmpenv = restartjmpenv;
+ PL_restartop = restartop;
JMPENV_JUMP(3);
/* NOTREACHED */
}
SV **newsp;
I32 gimme;
register PERL_CONTEXT *cx;
+ OP *retop;
if (!io || !(ofp = IoOFP(io)))
goto forget_top;
forget_top:
POPBLOCK(cx,PL_curpm);
POPFORMAT(cx);
+ retop = cx->blk_sub.retop;
LEAVE;
fp = IoOFP(io);
PUTBACK;
PERL_UNUSED_VAR(newsp);
PERL_UNUSED_VAR(gimme);
- return cx->blk_sub.retop;
+ return retop;
}
PP(pp_prtf)