int peep_recording;
AV *peep_recorder;
AV *rpeep_recorder;
+ AV *xop_record;
} my_cxt_t;
START_MY_CXT
+MGVTBL vtbl_foo, vtbl_bar;
+
/* indirect functions to test the [pa]MY_CXT macros */
int
#else
/* Storing then deleting something should ensure that a hash entry is
available. */
- hv_store(test_hash, "", 0, &PL_sv_yes, 0);
- hv_delete(test_hash, "", 0, 0);
+ (void) hv_store(test_hash, "", 0, &PL_sv_yes, 0);
+ (void) hv_delete(test_hash, "", 0, 0);
/* We need to "inline" new_he here as it's static, and the functions we
test expect to be able to call del_HE on the HE */
i = 0;
do {
mPUSHu(results[i]);
- } while (++i < sizeof(results)/sizeof(results[0]));
+ } while (++i < (int)(sizeof(results)/sizeof(results[0])));
/* Goodbye to our extra reference. */
SvREFCNT_dec(test_scalar);
bitflip_key(pTHX_ IV action, SV *field) {
MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
SV *keysv;
+ PERL_UNUSED_ARG(action);
if (mg && (keysv = mg->mg_obj)) {
STRLEN len;
const char *p = SvPV(keysv, len);
rot13_key(pTHX_ IV action, SV *field) {
MAGIC *mg = mg_find(field, PERL_MAGIC_uvar);
SV *keysv;
+ PERL_UNUSED_ARG(action);
if (mg && (keysv = mg->mg_obj)) {
STRLEN len;
const char *p = SvPV(keysv, len);
STATIC I32
rmagical_a_dummy(pTHX_ IV idx, SV *sv) {
+ PERL_UNUSED_ARG(idx);
+ PERL_UNUSED_ARG(sv);
return 0;
}
dMY_CXT;
AV *const cur = GvAV(MY_CXT.cscgv);
+ PERL_UNUSED_ARG(full);
SAVEGENERICSV(GvAV(MY_CXT.cscgv));
if (cur) {
{
dMY_CXT;
+ PERL_UNUSED_ARG(o);
/* if we hit the end of a scope we missed the start of, we need to
* unconditionally clear @CSC */
if (GvAV(MY_CXT.cscgv) == MY_CXT.cscav && MY_CXT.cscav) {
{
dMY_CXT;
+ PERL_UNUSED_ARG(o);
if (MY_CXT.bhk_record)
av_push(MY_CXT.bhkav, newSVpvs("pre_end"));
}
{
dMY_CXT;
+ PERL_UNUSED_ARG(o);
if (MY_CXT.bhk_record)
av_push(MY_CXT.bhkav, newSVpvs("post_end"));
}
STATIC OP *
THX_ck_entersub_args_lists(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
{
+ PERL_UNUSED_ARG(namegv);
+ PERL_UNUSED_ARG(ckobj);
return ck_entersub_args_list(entersubop);
}
THX_ck_entersub_args_scalars(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
{
OP *aop = cUNOPx(entersubop)->op_first;
+ PERL_UNUSED_ARG(namegv);
+ PERL_UNUSED_ARG(ckobj);
if (!aop->op_sibling)
aop = cUNOPx(aop)->op_first;
for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
{
OP *sumop = NULL;
OP *pushop = cUNOPx(entersubop)->op_first;
+ PERL_UNUSED_ARG(namegv);
+ PERL_UNUSED_ARG(ckobj);
if (!pushop->op_sibling)
pushop = cUNOPx(pushop)->op_first;
while (1) {
return estop;
}
+STATIC OP *
+THX_ck_entersub_postinc(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
+{
+ OP *pushop, *argop;
+ 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);
}
}
+static XOP my_xop;
+
+static OP *
+pp_xop(pTHX)
+{
+ return PL_op->op_next;
+}
+
+static void
+peep_xop(pTHX_ OP *o, OP *oldop)
+{
+ dMY_CXT;
+ av_push(MY_CXT.xop_record, newSVpvf("peep:%"UVxf, PTR2UV(o)));
+ av_push(MY_CXT.xop_record, newSVpvf("oldop:%"UVxf, PTR2UV(oldop)));
+}
+
XS(XS_XS__APItest__XSUB_XS_VERSION_undef);
XS(XS_XS__APItest__XSUB_XS_VERSION_empty);
XS(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
INCLUDE: numeric.xs
+MODULE = XS::APItest::utf8 PACKAGE = XS::APItest::utf8
+
+int
+bytes_cmp_utf8(bytes, utf8)
+ SV *bytes
+ SV *utf8
+ PREINIT:
+ const U8 *b;
+ STRLEN blen;
+ const U8 *u;
+ STRLEN ulen;
+ CODE:
+ b = (const U8 *)SvPVbyte(bytes, blen);
+ u = (const U8 *)SvPVbyte(utf8, ulen);
+ RETVAL = bytes_cmp_utf8(b, blen, u, ulen);
+ OUTPUT:
+ RETVAL
+
+MODULE = XS::APItest:Overload PACKAGE = XS::APItest::Overload
+
+void
+amagic_deref_call(sv, what)
+ SV *sv
+ int what
+ PPCODE:
+ /* The reference is owned by something else. */
+ PUSHs(amagic_deref_call(sv, what));
+
+# I'd certainly like to discourage the use of this macro, given that we now
+# have amagic_deref_call
+
+void
+tryAMAGICunDEREF_var(sv, what)
+ SV *sv
+ int what
+ PPCODE:
+ {
+ SV **sp = &sv;
+ switch(what) {
+ case to_av_amg:
+ tryAMAGICunDEREF(to_av);
+ break;
+ case to_cv_amg:
+ tryAMAGICunDEREF(to_cv);
+ break;
+ case to_gv_amg:
+ tryAMAGICunDEREF(to_gv);
+ break;
+ case to_hv_amg:
+ tryAMAGICunDEREF(to_hv);
+ break;
+ case to_sv_amg:
+ tryAMAGICunDEREF(to_sv);
+ break;
+ default:
+ croak("Invalid value %d passed to tryAMAGICunDEREF_var", what);
+ }
+ }
+ /* The reference is owned by something else. */
+ PUSHs(sv);
+
MODULE = XS::APItest PACKAGE = XS::APItest::XSUB
BOOT:
PROTOTYPES: DISABLE
+HV *
+xop_custom_ops ()
+ CODE:
+ RETVAL = PL_custom_ops;
+ OUTPUT:
+ RETVAL
+
+HV *
+xop_custom_op_names ()
+ CODE:
+ PL_custom_op_names = newHV();
+ RETVAL = PL_custom_op_names;
+ OUTPUT:
+ RETVAL
+
+HV *
+xop_custom_op_descs ()
+ CODE:
+ PL_custom_op_descs = newHV();
+ RETVAL = PL_custom_op_descs;
+ OUTPUT:
+ RETVAL
+
+void
+xop_register ()
+ CODE:
+ XopENTRY_set(&my_xop, xop_name, "my_xop");
+ XopENTRY_set(&my_xop, xop_desc, "XOP for testing");
+ XopENTRY_set(&my_xop, xop_class, OA_UNOP);
+ XopENTRY_set(&my_xop, xop_peep, peep_xop);
+ Perl_custom_op_register(aTHX_ pp_xop, &my_xop);
+
+void
+xop_clear ()
+ CODE:
+ XopDISABLE(&my_xop, xop_name);
+ XopDISABLE(&my_xop, xop_desc);
+ XopDISABLE(&my_xop, xop_class);
+ XopDISABLE(&my_xop, xop_peep);
+
+IV
+xop_my_xop ()
+ CODE:
+ RETVAL = PTR2IV(&my_xop);
+ OUTPUT:
+ RETVAL
+
+IV
+xop_ppaddr ()
+ CODE:
+ RETVAL = PTR2IV(pp_xop);
+ OUTPUT:
+ RETVAL
+
+IV
+xop_OA_UNOP ()
+ CODE:
+ RETVAL = OA_UNOP;
+ OUTPUT:
+ RETVAL
+
+AV *
+xop_build_optree ()
+ CODE:
+ dMY_CXT;
+ UNOP *unop;
+ OP *kid;
+
+ MY_CXT.xop_record = newAV();
+
+ kid = newSVOP(OP_CONST, 0, newSViv(42));
+
+ NewOp(1102, unop, 1, UNOP);
+ unop->op_type = OP_CUSTOM;
+ unop->op_ppaddr = pp_xop;
+ unop->op_flags = OPf_KIDS;
+ unop->op_private = 0;
+ unop->op_first = kid;
+ unop->op_next = NULL;
+ kid->op_next = (OP*)unop;
+
+ av_push(MY_CXT.xop_record, newSVpvf("unop:%"UVxf, PTR2UV(unop)));
+ av_push(MY_CXT.xop_record, newSVpvf("kid:%"UVxf, PTR2UV(kid)));
+
+ av_push(MY_CXT.xop_record, newSVpvf("NAME:%s", OP_NAME((OP*)unop)));
+ av_push(MY_CXT.xop_record, newSVpvf("DESC:%s", OP_DESC((OP*)unop)));
+ av_push(MY_CXT.xop_record, newSVpvf("CLASS:%d", (int)OP_CLASS((OP*)unop)));
+
+ PL_rpeepp(aTHX_ kid);
+
+ FreeOp(kid);
+ FreeOp(unop);
+
+ RETVAL = MY_CXT.xop_record;
+ MY_CXT.xop_record = NULL;
+ OUTPUT:
+ RETVAL
+
BOOT:
{
MY_CXT_INIT;
CLONE(...)
CODE:
MY_CXT_CLONE;
+ PERL_UNUSED_VAR(items);
MY_CXT.sv = newSVpv("initial_clone",0);
MY_CXT.cscgv = gv_fetchpvs("XS::APItest::COMPILE_SCOPE_CONTAINER",
GV_ADDMULTI, SVt_PVAV);
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
}
+SV*
+take_svref(SVREF sv)
+CODE:
+ RETVAL = newRV_inc(sv);
+OUTPUT:
+ RETVAL
+
+SV*
+take_avref(AV* av)
+CODE:
+ RETVAL = newRV_inc((SV*)av);
+OUTPUT:
+ RETVAL
+
+SV*
+take_hvref(HV* hv)
+CODE:
+ RETVAL = newRV_inc((SV*)hv);
+OUTPUT:
+ RETVAL
+
+
+SV*
+take_cvref(CV* cv)
+CODE:
+ RETVAL = newRV_inc((SV*)cv);
+OUTPUT:
+ RETVAL
+
+
BOOT:
{
HV* stash;
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;
}
establish_cleanup(...)
PROTOTYPE: $
CODE:
+ PERL_UNUSED_VAR(items);
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:
+ PERL_UNUSED_VAR(items);
+ 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);
+}
+
+MODULE = XS::APItest PACKAGE = XS::APItest::Magic
+
+PROTOTYPES: DISABLE
+
+void
+sv_magic_foo(SV *sv, SV *thingy)
+ALIAS:
+ sv_magic_bar = 1
+CODE:
+ sv_magicext(SvRV(sv), NULL, PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo, (const char *)thingy, 0);
+
+SV *
+mg_find_foo(SV *sv)
+ALIAS:
+ mg_find_bar = 1
+CODE:
+ MAGIC *mg = mg_findext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
+ RETVAL = mg ? SvREFCNT_inc((SV *)mg->mg_ptr) : &PL_sv_undef;
+OUTPUT:
+ RETVAL
+
+void
+sv_unmagic_foo(SV *sv)
+ALIAS:
+ sv_unmagic_bar = 1
+CODE:
+ sv_unmagicext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
https://perl5.git.perl.org / perl5.git / blobdiff