#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 SvPVX(res);
}
-/* the real new*OP functions have a tendancy to call fold_constants, and
+/* the real new*OP functions have a tendency to call fold_constants, and
* other such unhelpful things, so we need our own versions for testing */
#define mkUNOP(t, f) THX_mkUNOP(aTHX_ (t), (f))
STATIC OP *
THX_ck_entersub_postinc(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
{
- OP *pushop, *argop, *estop;
+ OP *pushop, *argop;
ck_entersub_args_proto(entersubop, namegv, ckobj);
pushop = cUNOPx(entersubop)->op_first;
if(!pushop->op_sibling) pushop = cUNOPx(pushop)->op_first;
op_lvalue(op_contextualize(argop, G_SCALAR), OP_POSTINC));
}
+STATIC OP *
+THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
+{
+ OP *pushop, *argop;
+ PADOFFSET padoff = NOT_IN_PAD;
+ SV *a0, *a1;
+ 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;
+ if(argop->op_type != OP_CONST || argop->op_sibling->op_type != OP_CONST)
+ croak("bad argument expression type for pad_scalar()");
+ a0 = cSVOPx_sv(argop);
+ a1 = cSVOPx_sv(argop->op_sibling);
+ switch(SvIV(a0)) {
+ case 1: {
+ SV *namesv = sv_2mortal(newSVpvs("$"));
+ sv_catsv(namesv, a1);
+ padoff = pad_findmy_sv(namesv, 0);
+ } break;
+ case 2: {
+ char *namepv;
+ STRLEN namelen;
+ SV *namesv = sv_2mortal(newSVpvs("$"));
+ sv_catsv(namesv, a1);
+ namepv = SvPV(namesv, namelen);
+ padoff = pad_findmy_pvn(namepv, namelen, SvUTF8(namesv));
+ } break;
+ case 3: {
+ char *namepv;
+ SV *namesv = sv_2mortal(newSVpvs("$"));
+ sv_catsv(namesv, a1);
+ namepv = SvPV_nolen(namesv);
+ padoff = pad_findmy_pv(namepv, SvUTF8(namesv));
+ } break;
+ case 4: {
+ padoff = pad_findmy_pvs("$foo", 0);
+ } break;
+ default: croak("bad type value for pad_scalar()");
+ }
+ op_free(entersubop);
+ if(padoff == NOT_IN_PAD) {
+ return newSVOP(OP_CONST, 0, newSVpvs("NOT_IN_PAD"));
+ } else if(PAD_COMPNAME_FLAGS_isOUR(padoff)) {
+ return newSVOP(OP_CONST, 0, newSVpvs("NOT_MY"));
+ } else {
+ OP *padop = newOP(OP_PADSV, 0);
+ padop->op_targ = padoff;
+ return padop;
+ }
+}
+
/** RPN keyword parser **/
#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
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 SV *hintkey_arrayfullexpr_sv, *hintkey_arraylistexpr_sv;
+static SV *hintkey_arraytermexpr_sv, *hintkey_arrayarithexpr_sv;
+static SV *hintkey_arrayexprflags_sv;
static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
/* low-level parser helpers */
}
if(s-start < 2) croak("RPN syntax error");
lex_read_to(s);
- {
- /* because pad_findmy() doesn't really use length yet */
- SV *namesv = sv_2mortal(newSVpvn(start, s-start));
- varpos = pad_findmy(SvPVX(namesv), s-start, 0);
- }
+ varpos = pad_findmy_pvn(start, s-start, 0);
if(varpos == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(varpos))
croak("RPN only supports \"my\" variables");
padop = newOP(OP_PADSV, 0);
return newSVOP(OP_CONST, 0, parse_label(0));
}
+#define parse_keyword_arrayfullexpr() THX_parse_keyword_arrayfullexpr(aTHX)
+static OP *THX_parse_keyword_arrayfullexpr(pTHX)
+{
+ return newANONLIST(parse_fullexpr(0));
+}
+
+#define parse_keyword_arraylistexpr() THX_parse_keyword_arraylistexpr(aTHX)
+static OP *THX_parse_keyword_arraylistexpr(pTHX)
+{
+ return newANONLIST(parse_listexpr(0));
+}
+
+#define parse_keyword_arraytermexpr() THX_parse_keyword_arraytermexpr(aTHX)
+static OP *THX_parse_keyword_arraytermexpr(pTHX)
+{
+ return newANONLIST(parse_termexpr(0));
+}
+
+#define parse_keyword_arrayarithexpr() THX_parse_keyword_arrayarithexpr(aTHX)
+static OP *THX_parse_keyword_arrayarithexpr(pTHX)
+{
+ return newANONLIST(parse_arithexpr(0));
+}
+
+#define parse_keyword_arrayexprflags() THX_parse_keyword_arrayexprflags(aTHX)
+static OP *THX_parse_keyword_arrayexprflags(pTHX)
+{
+ U32 flags = 0;
+ I32 c;
+ OP *o;
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ if (c != '!' && c != '?') croak("syntax error");
+ lex_read_unichar(0);
+ if (c == '?') flags |= PARSE_OPTIONAL;
+ o = parse_listexpr(flags);
+ return o ? newANONLIST(o) : newANONHASH(newOP(OP_STUB, 0));
+}
+
/* plugin glue */
#define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
keyword_active(hintkey_labelconst_sv)) {
*op_ptr = parse_keyword_labelconst();
return KEYWORD_PLUGIN_EXPR;
+ } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arrayfullexpr", 13) &&
+ keyword_active(hintkey_arrayfullexpr_sv)) {
+ *op_ptr = parse_keyword_arrayfullexpr();
+ return KEYWORD_PLUGIN_EXPR;
+ } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arraylistexpr", 13) &&
+ keyword_active(hintkey_arraylistexpr_sv)) {
+ *op_ptr = parse_keyword_arraylistexpr();
+ return KEYWORD_PLUGIN_EXPR;
+ } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arraytermexpr", 13) &&
+ keyword_active(hintkey_arraytermexpr_sv)) {
+ *op_ptr = parse_keyword_arraytermexpr();
+ return KEYWORD_PLUGIN_EXPR;
+ } else if(keyword_len == 14 && strnEQ(keyword_ptr, "arrayarithexpr", 14) &&
+ keyword_active(hintkey_arrayarithexpr_sv)) {
+ *op_ptr = parse_keyword_arrayarithexpr();
+ return KEYWORD_PLUGIN_EXPR;
+ } else if(keyword_len == 14 && strnEQ(keyword_ptr, "arrayexprflags", 14) &&
+ keyword_active(hintkey_arrayexprflags_sv)) {
+ *op_ptr = parse_keyword_arrayexprflags();
+ return KEYWORD_PLUGIN_EXPR;
} else {
return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
}
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);
+static I32
+filter_call(pTHX_ int idx, SV *buf_sv, int maxlen)
+{
+ SV *my_sv = FILTER_DATA(idx);
+ char *p;
+ char *end;
+ int n = FILTER_READ(idx + 1, buf_sv, maxlen);
+
+ if (n<=0) return n;
+
+ p = SvPV_force_nolen(buf_sv);
+ end = p + SvCUR(buf_sv);
+ while (p < end) {
+ if (*p == 'o') *p = 'e';
+ p++;
+ }
+ return SvCUR(buf_sv);
+}
+
+
+XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_undef);
+XS_EXTERNAL(XS_XS__APItest__XSUB_XS_VERSION_empty);
+XS_EXTERNAL(XS_XS__APItest__XSUB_XS_APIVERSION_invalid);
#include "const-c.inc"
MODULE = XS::APItest:Overload PACKAGE = XS::APItest::Overload
-SV *
+void
amagic_deref_call(sv, what)
SV *sv
int what
# I'd certainly like to discourage the use of this macro, given that we now
# have amagic_deref_call
-SV *
+void
tryAMAGICunDEREF_var(sv, what)
SV *sv
int what
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", OP_CLASS((OP*)unop)));
+ av_push(MY_CXT.xop_record, newSVpvf("CLASS:%d", (int)OP_CLASS((OP*)unop)));
PL_rpeepp(aTHX_ kid);
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);
PUSHs(sv_2mortal(newSViv(i)));
void
+gv_init_type(namesv, multi, flags, type)
+ SV* namesv
+ int multi
+ I32 flags
+ int type
+ PREINIT:
+ STRLEN len;
+ const char * const name = SvPV_const(namesv, len);
+ GV *gv = *(GV**)hv_fetch(PL_defstash, name, len, TRUE);
+ PPCODE:
+ if (SvTYPE(gv) == SVt_PVGV)
+ Perl_croak(aTHX_ "GV is already a PVGV");
+ switch (type) {
+ case 0:
+ gv_init(gv, PL_defstash, name, len, multi);
+ break;
+ case 1:
+ gv_init_sv(gv, PL_defstash, namesv, multi, flags);
+ break;
+ case 2:
+ gv_init_pv(gv, PL_defstash, name, multi, flags | SvUTF8(namesv));
+ break;
+ case 3:
+ gv_init_pvn(gv, PL_defstash, name, len, multi, flags | SvUTF8(namesv));
+ break;
+ }
+ XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
+
+void
eval_sv(sv, flags)
SV* sv
I32 flags
#undef msvpvs
#undef msviv
+void
+test_coplabel()
+ PREINIT:
+ COP *cop;
+ const char *label;
+ STRLEN len;
+ U32 utf8;
+ CODE:
+ cop = &PL_compiling;
+ Perl_cop_store_label(aTHX_ cop, "foo", 3, 0);
+ label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
+ if (strcmp(label,"foo")) croak("fail # cop_fetch_label label");
+ if (len != 3) croak("fail # cop_fetch_label len");
+ if (utf8) croak("fail # cop_fetch_label utf8");
+ /* SMALL GERMAN UMLAUT A */
+ Perl_cop_store_label(aTHX_ cop, "foä", 4, SVf_UTF8);
+ label = Perl_cop_fetch_label(aTHX_ cop, &len, &utf8);
+ if (strcmp(label,"foä")) croak("fail # cop_fetch_label label");
+ if (len != 4) croak("fail # cop_fetch_label len");
+ if (!utf8) croak("fail # cop_fetch_label utf8");
+
+
HV *
example_cophh_2hv()
PREINIT:
XSRETURN_UNDEF;
}
+#ifdef USE_ITHREADS
+
+void
+clone_with_stack()
+CODE:
+{
+ PerlInterpreter *interp = aTHX; /* The original interpreter */
+ PerlInterpreter *interp_dup; /* The duplicate interpreter */
+ int oldscope = 1; /* We are responsible for all scopes */
+
+ interp_dup = perl_clone(interp, CLONEf_COPY_STACKS | CLONEf_CLONE_HOST );
+
+ /* destroy old perl */
+ PERL_SET_CONTEXT(interp);
+
+ POPSTACK_TO(PL_mainstack);
+ dounwind(-1);
+ LEAVE_SCOPE(0);
+
+ while (interp->Iscopestack_ix > 1)
+ LEAVE;
+ FREETMPS;
+
+ perl_destruct(interp);
+ perl_free(interp);
+
+ /* switch to new perl */
+ PERL_SET_CONTEXT(interp_dup);
+
+ /* continue after 'clone_with_stack' */
+ interp_dup->Iop = interp_dup->Iop->op_next;
+
+ /* run with new perl */
+ Perl_runops_standard(interp_dup);
+
+ /* We may have additional unclosed scopes if fork() was called
+ * from within a BEGIN block. See perlfork.pod for more details.
+ * We cannot clean up these other scopes because they belong to a
+ * different interpreter, but we also cannot leave PL_scopestack_ix
+ * dangling because that can trigger an assertion in perl_destruct().
+ */
+ if (PL_scopestack_ix > oldscope) {
+ PL_scopestack[oldscope-1] = PL_scopestack[PL_scopestack_ix-1];
+ PL_scopestack_ix = oldscope;
+ }
+
+ perl_destruct(interp_dup);
+ perl_free(interp_dup);
+
+ /* call the real 'exit' not PerlProc_exit */
+#undef exit
+ exit(0);
+}
+
+#endif /* USE_ITHREDS */
SV*
take_svref(SVREF sv)
hintkey_blockasexpr_sv = newSVpvs_share("XS::APItest/blockasexpr");
hintkey_swaplabel_sv = newSVpvs_share("XS::APItest/swaplabel");
hintkey_labelconst_sv = newSVpvs_share("XS::APItest/labelconst");
+ hintkey_arrayfullexpr_sv = newSVpvs_share("XS::APItest/arrayfullexpr");
+ hintkey_arraylistexpr_sv = newSVpvs_share("XS::APItest/arraylistexpr");
+ hintkey_arraytermexpr_sv = newSVpvs_share("XS::APItest/arraytermexpr");
+ hintkey_arrayarithexpr_sv = newSVpvs_share("XS::APItest/arrayarithexpr");
+ hintkey_arrayexprflags_sv = newSVpvs_share("XS::APItest/arrayexprflags");
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:
postinc(...)
PROTOTYPE: $
CODE:
+ PERL_UNUSED_VAR(items);
croak("postinc called as a function");
+void
+filter()
+CODE:
+ filter_add(filter_call, NULL);
+
BOOT:
{
CV *asscv = get_cv("XS::APItest::postinc", 0);
cv_set_call_checker(asscv, THX_ck_entersub_postinc, (SV*)asscv);
}
+SV *
+lv_temp_object()
+CODE:
+ RETVAL =
+ sv_bless(
+ newRV_noinc(newSV(0)),
+ gv_stashpvs("XS::APItest::TempObj",GV_ADD)
+ ); /* Package defined in test script */
+OUTPUT:
+ RETVAL
+
+void
+fill_hash_with_nulls(HV *hv)
+PREINIT:
+ UV i = 0;
+CODE:
+ for(; i < 1000; ++i) {
+ HE *entry = hv_fetch_ent(hv, sv_2mortal(newSVuv(i)), 1, 0);
+ SvREFCNT_dec(HeVAL(entry));
+ HeVAL(entry) = NULL;
+ }
+
+bool
+SvIsCOW(SV *sv)
+CODE:
+ RETVAL = SvIsCOW(sv);
+OUTPUT:
+ RETVAL
+
+void
+pad_scalar(...)
+PROTOTYPE: $$
+CODE:
+ PERL_UNUSED_VAR(items);
+ croak("pad_scalar called as a function");
+
+BOOT:
+{
+ CV *pscv = get_cv("XS::APItest::pad_scalar", 0);
+ cv_set_call_checker(pscv, THX_ck_entersub_pad_scalar, (SV*)pscv);
+}
+
+SV*
+fetch_pad_names( cv )
+CV* cv
+ PREINIT:
+ I32 i;
+ AV *pad_namelist;
+ AV *retav = newAV();
+ CODE:
+ pad_namelist = (AV*) *av_fetch(CvPADLIST(cv), 0, FALSE);
+
+ for ( i = av_len(pad_namelist); i >= 0; i-- ) {
+ SV** name_ptr = av_fetch(pad_namelist, i, 0);
+
+ if (name_ptr && SvPOKp(*name_ptr)) {
+ av_push(retav, newSVsv(*name_ptr));
+ }
+ }
+ RETVAL = newRV_noinc((SV*)retav);
+ OUTPUT:
+ RETVAL
+
+STRLEN
+underscore_length()
+PROTOTYPE:
+PREINIT:
+ SV *u;
+ U8 *pv;
+ STRLEN bytelen;
+CODE:
+ u = find_rundefsv();
+ pv = (U8*)SvPV(u, bytelen);
+ RETVAL = SvUTF8(u) ? utf8_length(pv, pv+bytelen) : bytelen;
+OUTPUT:
+ RETVAL
+
+void
+stringify(SV *sv)
+PREINIT:
+ const char *pv;
+CODE:
+ pv = SvPV_nolen(sv);
+
+
MODULE = XS::APItest PACKAGE = XS::APItest::Magic
PROTOTYPES: DISABLE
sv_unmagic_bar = 1
CODE:
sv_unmagicext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo);
+
+UV
+test_get_vtbl()
+ PREINIT:
+ MGVTBL *have;
+ MGVTBL *want;
+ CODE:
+#define test_get_this_vtable(name) \
+ want = CAT2(&PL_vtbl_, name); \
+ have = get_vtbl(CAT2(want_vtbl_, name)); \
+ if (have != want) \
+ croak("fail %p!=%p for get_vtbl(want_vtbl_" STRINGIFY(name) ") at " __FILE__ " line %d", have, want, __LINE__)
+
+ test_get_this_vtable(sv);
+ test_get_this_vtable(env);
+ test_get_this_vtable(envelem);
+ test_get_this_vtable(sigelem);
+ test_get_this_vtable(pack);
+ test_get_this_vtable(packelem);
+ test_get_this_vtable(dbline);
+ test_get_this_vtable(isa);
+ test_get_this_vtable(isaelem);
+ test_get_this_vtable(arylen);
+ test_get_this_vtable(mglob);
+ test_get_this_vtable(nkeys);
+ test_get_this_vtable(taint);
+ test_get_this_vtable(substr);
+ test_get_this_vtable(vec);
+ test_get_this_vtable(pos);
+ test_get_this_vtable(bm);
+ test_get_this_vtable(fm);
+ test_get_this_vtable(uvar);
+ test_get_this_vtable(defelem);
+ test_get_this_vtable(regexp);
+ test_get_this_vtable(regdata);
+ test_get_this_vtable(regdatum);
+#ifdef USE_LOCALE_COLLATE
+ test_get_this_vtable(collxfrm);
+#endif
+ test_get_this_vtable(amagic);
+ test_get_this_vtable(amagicelem);
+ test_get_this_vtable(backref);
+ test_get_this_vtable(utf8);
+
+ RETVAL = PTR2UV(get_vtbl(-1));
+ OUTPUT:
+ RETVAL