typedef PTR_TBL_t *XS__APItest__PtrTable;
#define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__)
+#define croak_fail_ne(h, w) croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__)
/* for my_cxt tests */
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;
+}
+
+STATIC OP *
+THX_ck_entersub_postinc(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);
+ return newUNOP(OP_POSTINC, 0,
+ op_lvalue(op_contextualize(argop, G_SCALAR), OP_POSTINC));
+}
+
/** RPN keyword parser **/
#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
static SV *hintkey_scopelessblock_sv;
static SV *hintkey_stmtasexpr_sv, *hintkey_stmtsasexpr_sv;
static SV *hintkey_loopblock_sv, *hintkey_blockasexpr_sv;
+static SV *hintkey_swaplabel_sv, *hintkey_labelconst_sv;
static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
/* low-level parser helpers */
#define parse_keyword_looprest() THX_parse_keyword_looprest(aTHX)
static OP *THX_parse_keyword_looprest(pTHX)
{
- I32 condline;
- OP *body;
- condline = CopLINE(PL_curcop);
- body = parse_stmtseq(0);
- return newWHILEOP(0, 1, NULL, condline, newSVOP(OP_CONST, 0, &PL_sv_yes),
- body, NULL, 1);
+ return newWHILEOP(0, 1, NULL, newSVOP(OP_CONST, 0, &PL_sv_yes),
+ parse_stmtseq(0), NULL, 1);
}
#define parse_keyword_scopelessblock() THX_parse_keyword_scopelessblock(aTHX)
#define parse_keyword_stmtasexpr() THX_parse_keyword_stmtasexpr(aTHX)
static OP *THX_parse_keyword_stmtasexpr(pTHX)
{
- OP *o = parse_fullstmt(0);
- o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
- o->op_type = OP_LEAVE;
- o->op_ppaddr = PL_ppaddr[OP_LEAVE];
- return o;
+ OP *o = parse_barestmt(0);
+ if (!o) o = newOP(OP_STUB, 0);
+ if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
+ return op_scope(o);
}
#define parse_keyword_stmtsasexpr() THX_parse_keyword_stmtsasexpr(aTHX)
lex_read_space(0);
if(lex_peek_unichar(0) != /*{*/'}') croak("syntax error");
lex_read_unichar(0);
- o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
- o->op_type = OP_LEAVE;
- o->op_ppaddr = PL_ppaddr[OP_LEAVE];
- return o;
+ if (!o) o = newOP(OP_STUB, 0);
+ if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
+ return op_scope(o);
}
#define parse_keyword_loopblock() THX_parse_keyword_loopblock(aTHX)
static OP *THX_parse_keyword_loopblock(pTHX)
{
- I32 condline;
- OP *body;
- condline = CopLINE(PL_curcop);
- body = parse_block(0);
- return newWHILEOP(0, 1, NULL, condline, newSVOP(OP_CONST, 0, &PL_sv_yes),
- body, NULL, 1);
+ return newWHILEOP(0, 1, NULL, newSVOP(OP_CONST, 0, &PL_sv_yes),
+ parse_block(0), NULL, 1);
}
#define parse_keyword_blockasexpr() THX_parse_keyword_blockasexpr(aTHX)
static OP *THX_parse_keyword_blockasexpr(pTHX)
{
OP *o = parse_block(0);
- o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
- o->op_type = OP_LEAVE;
- o->op_ppaddr = PL_ppaddr[OP_LEAVE];
- return o;
+ if (!o) o = newOP(OP_STUB, 0);
+ if (PL_hints & HINT_BLOCK_SCOPE) o->op_flags |= OPf_PARENS;
+ return op_scope(o);
+}
+
+#define parse_keyword_swaplabel() THX_parse_keyword_swaplabel(aTHX)
+static OP *THX_parse_keyword_swaplabel(pTHX)
+{
+ OP *sop = parse_barestmt(0);
+ SV *label = parse_label(PARSE_OPTIONAL);
+ if (label) sv_2mortal(label);
+ return newSTATEOP(0, label ? savepv(SvPVX(label)) : NULL, sop);
+}
+
+#define parse_keyword_labelconst() THX_parse_keyword_labelconst(aTHX)
+static OP *THX_parse_keyword_labelconst(pTHX)
+{
+ return newSVOP(OP_CONST, 0, parse_label(0));
}
/* plugin glue */
keyword_active(hintkey_blockasexpr_sv)) {
*op_ptr = parse_keyword_blockasexpr();
return KEYWORD_PLUGIN_EXPR;
+ } else if(keyword_len == 9 && strnEQ(keyword_ptr, "swaplabel", 9) &&
+ keyword_active(hintkey_swaplabel_sv)) {
+ *op_ptr = parse_keyword_swaplabel();
+ return KEYWORD_PLUGIN_STMT;
+ } else if(keyword_len == 10 && strnEQ(keyword_ptr, "labelconst", 10) &&
+ keyword_active(hintkey_labelconst_sv)) {
+ *op_ptr = parse_keyword_labelconst();
+ return KEYWORD_PLUGIN_EXPR;
} else {
return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
}
PPCODE:
my_exit(exitcode);
+U8
+first_byte(sv)
+ SV *sv
+ CODE:
+ char *s;
+ STRLEN len;
+ s = SvPVbyte(sv, len);
+ RETVAL = s[0];
+ OUTPUT:
+ RETVAL
+
I32
sv_count()
CODE:
#define check_cc(cv, xckfun, xckobj) \
do { \
cv_get_call_checker((cv), &ckfun, &ckobj); \
- if (ckfun != (xckfun) || ckobj != (xckobj)) croak_fail(); \
+ if (ckfun != (xckfun)) croak_fail_ne(FPTR2DPTR(void *, ckfun), xckfun); \
+ if (ckobj != (xckobj)) croak_fail_ne(FPTR2DPTR(void *, ckobj), xckobj); \
} while(0)
troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
tsh_cv = get_cv("XS::APItest::test_savehints", 0);
check_ph(cophh_fetch_pvs(a, "foo_\xc2\x8c", 0));
check_iv(cophh_fetch_pvs(a, "foo_\xd9\xa6", COPHH_KEY_UTF8), 666);
check_ph(cophh_fetch_pvs(a, "foo_\xd9\xa6", 0));
- cophh_free(a);
+ ENTER;
+ SAVEFREECOPHH(a);
+ LEAVE;
#undef check_ph
#undef check_iv
#undef msvpvs
hintkey_stmtsasexpr_sv = newSVpvs_share("XS::APItest/stmtsasexpr");
hintkey_loopblock_sv = newSVpvs_share("XS::APItest/loopblock");
hintkey_blockasexpr_sv = newSVpvs_share("XS::APItest/blockasexpr");
+ hintkey_swaplabel_sv = newSVpvs_share("XS::APItest/swaplabel");
+ hintkey_labelconst_sv = newSVpvs_share("XS::APItest/labelconst");
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);
+}
+
+void
+postinc(...)
+PROTOTYPE: $
+CODE:
+ croak("postinc called as a function");
+
+BOOT:
+{
+ CV *asscv = get_cv("XS::APItest::postinc", 0);
+ cv_set_call_checker(asscv, THX_ck_entersub_postinc, (SV*)asscv);
+}
https://perl5.git.perl.org / perl5.git / blobdiff