#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
+#include "fakesdio.h" /* Causes us to use PerlIO below */
typedef SV *SVREF;
typedef PTR_TBL_t *XS__APItest__PtrTable;
void
test_freeent(freeent_function *f) {
- dTHX;
dSP;
HV *test_hash = newHV();
HE *victim;
const char *const end = p + len;
while (p < end) {
STRLEN len;
- UV chr = utf8_to_uvuni_buf((U8 *)p, (U8 *) end, &len);
- new_p = (char *)uvuni_to_utf8((U8 *)new_p, chr ^ 32);
+ UV chr = utf8_to_uvchr_buf((U8 *)p, (U8 *) end, &len);
+ new_p = (char *)uvchr_to_utf8((U8 *)new_p, chr ^ 32);
p += len;
}
SvUTF8_on(newkey);
I32 i;
AV *const new_av = newAV();
- for (i = 0; i <= av_len(cur); i++) {
+ for (i = 0; i <= av_tindex(cur); i++) {
av_store(new_av, i, newSVsv(*av_fetch(cur, i, 0)));
}
OP *aop = cUNOPx(entersubop)->op_first;
PERL_UNUSED_ARG(namegv);
PERL_UNUSED_ARG(ckobj);
- if (!aop->op_sibling)
+ if (!OP_HAS_SIBLING(aop))
aop = cUNOPx(aop)->op_first;
- for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) {
+ for (aop = OP_SIBLING(aop); OP_HAS_SIBLING(aop); aop = OP_SIBLING(aop)) {
op_contextualize(aop, G_SCALAR);
}
return entersubop;
THX_ck_entersub_multi_sum(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
{
OP *sumop = NULL;
+ OP *parent = entersubop;
OP *pushop = cUNOPx(entersubop)->op_first;
PERL_UNUSED_ARG(namegv);
PERL_UNUSED_ARG(ckobj);
- if (!pushop->op_sibling)
+ if (!OP_HAS_SIBLING(pushop)) {
+ parent = pushop;
pushop = cUNOPx(pushop)->op_first;
+ }
while (1) {
- OP *aop = pushop->op_sibling;
- if (!aop->op_sibling)
+ OP *aop = OP_SIBLING(pushop);
+ if (!OP_HAS_SIBLING(aop))
break;
- pushop->op_sibling = aop->op_sibling;
- aop->op_sibling = NULL;
+ /* cut out first arg */
+ op_sibling_splice(parent, pushop, 1, NULL);
op_contextualize(aop, G_SCALAR);
if (sumop) {
sumop = newBINOP(OP_ADD, 0, sumop, aop);
if (o->op_flags & OPf_KIDS) {
OP *k;
sv_catpvs(res, "[");
- for (k = cUNOPx(o)->op_first; k; k = k->op_sibling)
+ for (k = cUNOPx(o)->op_first; k; k = OP_SIBLING(k))
test_op_list_describe_part(res, k);
sv_catpvs(res, "]");
} else {
UNOP *unop;
NewOp(1103, unop, 1, UNOP);
unop->op_type = (OPCODE)type;
- unop->op_first = first;
- unop->op_flags = OPf_KIDS;
+ op_sibling_splice((OP*)unop, NULL, 0, first);
return (OP *)unop;
}
BINOP *binop;
NewOp(1103, binop, 1, BINOP);
binop->op_type = (OPCODE)type;
- binop->op_first = first;
- binop->op_flags = OPf_KIDS;
- binop->op_last = last;
- first->op_sibling = last;
+ op_sibling_splice((OP*)binop, NULL, 0, last);
+ op_sibling_splice((OP*)binop, NULL, 0, first);
return (OP *)binop;
}
LISTOP *listop;
NewOp(1103, listop, 1, LISTOP);
listop->op_type = (OPCODE)type;
- listop->op_flags = OPf_KIDS;
- listop->op_first = first;
- first->op_sibling = sib;
- sib->op_sibling = last;
- listop->op_last = last;
+ op_sibling_splice((OP*)listop, NULL, 0, last);
+ op_sibling_splice((OP*)listop, NULL, 0, sib);
+ op_sibling_splice((OP*)listop, NULL, 0, first);
return (OP *)listop;
}
THX_run_cleanup(pTHX_ void *cleanup_code_ref)
{
dSP;
+ PUSHSTACK;
ENTER;
SAVETMPS;
PUSHMARK(SP);
call_sv((SV*)cleanup_code_ref, G_VOID|G_DISCARD);
FREETMPS;
LEAVE;
+ POPSTACK;
}
STATIC OP *
STATIC OP *
THX_ck_entersub_establish_cleanup(pTHX_ OP *entersubop, GV *namegv, SV *ckobj)
{
- OP *pushop, *argop, *estop;
+ OP *parent, *pushop, *argop, *estop;
ck_entersub_args_proto(entersubop, namegv, ckobj);
+ parent = entersubop;
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;
+ if(!OP_HAS_SIBLING(pushop)) {
+ parent = pushop;
+ pushop = cUNOPx(pushop)->op_first;
+ }
+ /* extract out first arg, then delete the rest of the tree */
+ argop = OP_SIBLING(pushop);
+ op_sibling_splice(parent, pushop, 1, NULL);
op_free(entersubop);
- NewOpSz(0, estop, sizeof(UNOP));
- estop->op_type = OP_RAND;
+
+ estop = mkUNOP(OP_RAND, argop);
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;
+ OP *parent, *pushop, *argop;
ck_entersub_args_proto(entersubop, namegv, ckobj);
+ parent = entersubop;
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;
+ if(!OP_HAS_SIBLING(pushop)) {
+ parent = pushop;
+ pushop = cUNOPx(pushop)->op_first;
+ }
+ argop = OP_SIBLING(pushop);
+ op_sibling_splice(parent, pushop, 1, NULL);
op_free(entersubop);
return newUNOP(OP_POSTINC, 0,
op_lvalue(op_contextualize(argop, G_SCALAR), OP_POSTINC));
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)
+ if(!OP_HAS_SIBLING(pushop))
+ pushop = cUNOPx(pushop)->op_first;
+ argop = OP_SIBLING(pushop);
+ if(argop->op_type != OP_CONST || OP_SIBLING(argop)->op_type != OP_CONST)
croak("bad argument expression type for pad_scalar()");
a0 = cSVOPx_sv(argop);
- a1 = cSVOPx_sv(argop->op_sibling);
+ a1 = cSVOPx_sv(OP_SIBLING(argop));
switch(SvIV(a0)) {
case 1: {
SV *namesv = sv_2mortal(newSVpvs("$"));
static SV *hintkey_arrayfullexpr_sv, *hintkey_arraylistexpr_sv;
static SV *hintkey_arraytermexpr_sv, *hintkey_arrayarithexpr_sv;
static SV *hintkey_arrayexprflags_sv;
+static SV *hintkey_DEFSV_sv;
+static SV *hintkey_with_vars_sv;
+static SV *hintkey_join_with_space_sv;
static int (*next_keyword_plugin)(pTHX_ char *, STRLEN, OP **);
/* low-level parser helpers */
}
#define push_rpn_item(o) \
- (tmpop = (o), tmpop->op_sibling = stack, stack = tmpop)
-#define pop_rpn_item() \
- (!stack ? (croak("RPN stack underflow"), (OP*)NULL) : \
- (tmpop = stack, stack = stack->op_sibling, \
- tmpop->op_sibling = NULL, tmpop))
+ op_sibling_splice(parent, NULL, 0, o);
+#define pop_rpn_item() ( \
+ (tmpop = op_sibling_splice(parent, NULL, 1, NULL)) \
+ ? tmpop : (croak("RPN stack underflow"), (OP*)NULL))
#define parse_rpn_expr() THX_parse_rpn_expr(aTHX)
static OP *THX_parse_rpn_expr(pTHX)
{
- OP *stack = NULL, *tmpop;
+ OP *tmpop;
+ /* fake parent for splice to mess with */
+ OP *parent = mkBINOP(OP_NULL, NULL, NULL);
+
while(1) {
I32 c;
lex_read_space(0);
switch(c) {
case /*(*/')': case /*{*/'}': {
OP *result = pop_rpn_item();
- if(stack) croak("RPN expression must return a single value");
+ if(cLISTOPx(parent)->op_first)
+ croak("RPN expression must return a single value");
+ op_free(parent);
return result;
} break;
case '0': case '1': case '2': case '3': case '4':
return o ? newANONLIST(o) : newANONHASH(newOP(OP_STUB, 0));
}
+#define parse_keyword_DEFSV() THX_parse_keyword_DEFSV(aTHX)
+static OP *THX_parse_keyword_DEFSV(pTHX)
+{
+ return newDEFSVOP();
+}
+
+#define sv_cat_c(a,b) THX_sv_cat_c(aTHX_ a, b)
+static void THX_sv_cat_c(pTHX_ SV *sv, U32 c) {
+ char ds[UTF8_MAXBYTES + 1], *d;
+ d = (char *)uvchr_to_utf8((U8 *)ds, c);
+ if (d - ds > 1) {
+ sv_utf8_upgrade(sv);
+ }
+ sv_catpvn(sv, ds, d - ds);
+}
+
+#define parse_keyword_with_vars() THX_parse_keyword_with_vars(aTHX)
+static OP *THX_parse_keyword_with_vars(pTHX)
+{
+ I32 c;
+ IV count;
+ int save_ix;
+ OP *vardeclseq, *body;
+
+ save_ix = block_start(TRUE);
+ vardeclseq = NULL;
+
+ count = 0;
+
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ while (c != '{') {
+ SV *varname;
+ PADOFFSET padoff;
+
+ if (c == -1) {
+ croak("unexpected EOF; expecting '{'");
+ }
+
+ if (!isIDFIRST_uni(c)) {
+ croak("unexpected '%c'; expecting an identifier", (int)c);
+ }
+
+ varname = newSVpvs("$");
+ if (lex_bufutf8()) {
+ SvUTF8_on(varname);
+ }
+
+ sv_cat_c(varname, c);
+ lex_read_unichar(0);
+
+ while (c = lex_peek_unichar(0), c != -1 && isIDCONT_uni(c)) {
+ sv_cat_c(varname, c);
+ lex_read_unichar(0);
+ }
+
+ padoff = pad_add_name_sv(varname, padadd_NO_DUP_CHECK, NULL, NULL);
+
+ {
+ OP *my_var = newOP(OP_PADSV, OPf_MOD | (OPpLVAL_INTRO << 8));
+ my_var->op_targ = padoff;
+
+ vardeclseq = op_append_list(
+ OP_LINESEQ,
+ vardeclseq,
+ newSTATEOP(
+ 0, NULL,
+ newASSIGNOP(
+ OPf_STACKED,
+ my_var, 0,
+ newSVOP(
+ OP_CONST, 0,
+ newSViv(++count)
+ )
+ )
+ )
+ );
+ }
+
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ }
+
+ intro_my();
+
+ body = parse_block(0);
+
+ return block_end(save_ix, op_append_list(OP_LINESEQ, vardeclseq, body));
+}
+
+#define parse_join_with_space() THX_parse_join_with_space(aTHX)
+static OP *THX_parse_join_with_space(pTHX)
+{
+ OP *delim, *args;
+
+ args = parse_listexpr(0);
+ delim = newSVOP(OP_CONST, 0, newSVpvs(" "));
+ return op_convert_list(OP_JOIN, 0, op_prepend_elem(OP_LIST, delim, args));
+}
+
/* plugin glue */
#define keyword_active(hintkey_sv) THX_keyword_active(aTHX_ hintkey_sv)
keyword_active(hintkey_arrayexprflags_sv)) {
*op_ptr = parse_keyword_arrayexprflags();
return KEYWORD_PLUGIN_EXPR;
+ } else if(keyword_len == 5 && strnEQ(keyword_ptr, "DEFSV", 5) &&
+ keyword_active(hintkey_DEFSV_sv)) {
+ *op_ptr = parse_keyword_DEFSV();
+ return KEYWORD_PLUGIN_EXPR;
+ } else if(keyword_len == 9 && strnEQ(keyword_ptr, "with_vars", 9) &&
+ keyword_active(hintkey_with_vars_sv)) {
+ *op_ptr = parse_keyword_with_vars();
+ return KEYWORD_PLUGIN_STMT;
+ } else if(keyword_len == 15 && strnEQ(keyword_ptr, "join_with_space", 15) &&
+ keyword_active(hintkey_join_with_space_sv)) {
+ *op_ptr = parse_join_with_space();
+ return KEYWORD_PLUGIN_EXPR;
} else {
return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
}
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);
OP *aop, *bop;
U8 flags;
if (!(flag_svp && SvTRUE(*flag_svp) && (op->op_flags & OPf_KIDS) &&
- (aop = cBINOPx(op)->op_first) && (bop = aop->op_sibling) &&
- !bop->op_sibling))
+ (aop = cBINOPx(op)->op_first) && (bop = OP_SIBLING(aop)) &&
+ !OP_HAS_SIBLING(bop)))
return addissub_nxck_add(aTHX_ op);
- aop->op_sibling = NULL;
- cBINOPx(op)->op_first = NULL;
- op->op_flags &= ~OPf_KIDS;
flags = op->op_flags;
- op_free(op);
+ op_sibling_splice(op, NULL, 1, NULL); /* excise aop */
+ op_sibling_splice(op, NULL, 1, NULL); /* excise bop */
+ op_free(op); /* free the empty husk */
+ flags &= ~OPf_KIDS;
return newBINOP(OP_SUBTRACT, flags, aop, bop);
}
RETVAL
AV *
-test_utf8n_to_uvuni(s, len, flags)
+test_utf8n_to_uvchr(s, len, flags)
SV *s
SV *len
STRLEN slen;
CODE:
- /* Call utf8n_to_uvuni() with the inputs. It always asks for the
+ /* Call utf8n_to_uvchr() with the inputs. It always asks for the
* actual length to be returned
*
* Length to assume <s> is; not checked, so could have buffer overflow
sv_2mortal((SV*)RETVAL);
ret
- = utf8n_to_uvuni((U8*) SvPV(s, slen), SvUV(len), &retlen, SvUV(flags));
+ = utf8n_to_uvchr((U8*) SvPV(s, slen), SvUV(len), &retlen, SvUV(flags));
/* Returns the return value in [0]; <retlen> in [1] */
av_push(RETVAL, newSVuv(ret));
if ((svp = hv_fetchs(params, "hash", 0)))
hash = SvUV(*svp);
- if ((svp = hv_fetchs(params, "hash_pv", 0))) {
+ if (hv_fetchs(params, "hash_pv", 0)) {
+ assert(key);
PERL_HASH(hash, key, klen);
}
- if ((svp = hv_fetchs(params, "hash_sv", 0))) {
- STRLEN len;
- const char *const p = SvPV(keysv, len);
- PERL_HASH(hash, p, len);
+ if (hv_fetchs(params, "hash_sv", 0)) {
+ assert(keysv);
+ {
+ STRLEN len;
+ const char *const p = SvPV(keysv, len);
+ PERL_HASH(hash, p, len);
+ }
}
result = (HE *)hv_common(hv, keysv, key, klen, flags, action, val, hash);
#endif
+void
+test_force_keys(HV *hv)
+ PREINIT:
+ HE *he;
+ STRLEN count = 0;
+ PPCODE:
+ hv_iterinit(hv);
+ he = hv_iternext(hv);
+ while (he) {
+ SV *sv = HeSVKEY_force(he);
+ ++count;
+ EXTEND(SP, count);
+ PUSHs(sv_mortalcopy(sv));
+ he = hv_iternext(hv);
+ }
+
=pod
sub TIEHASH { bless {}, $_[0] }
AUTOLOADp(...)
PROTOTYPE: *$
CODE:
+ PERL_UNUSED_ARG(items);
RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv));
OUTPUT:
RETVAL
kid = newSVOP(OP_CONST, 0, newSViv(42));
- NewOp(1102, unop, 1, UNOP);
- unop->op_type = OP_CUSTOM;
+ unop = (UNOP*)mkUNOP(OP_CUSTOM, kid);
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;
OUTPUT:
RETVAL
+IV
+xop_from_custom_op ()
+ CODE:
+/* author note: this test doesn't imply Perl_custom_op_xop is or isn't public
+ API or that Perl_custom_op_xop is known to be used outside the core */
+ UNOP *unop;
+ XOP *xop;
+
+ unop = (UNOP*)mkUNOP(OP_CUSTOM, NULL);
+ unop->op_ppaddr = pp_xop;
+ unop->op_private = 0;
+ unop->op_next = NULL;
+
+ xop = Perl_custom_op_xop(aTHX_ (OP *)unop);
+ FreeOp(unop);
+ RETVAL = PTR2IV(xop);
+ OUTPUT:
+ RETVAL
+
BOOT:
{
MY_CXT_INIT;
mXPUSHu(3);
XSRETURN(3);
+void
+call_sv_C()
+PREINIT:
+ CV * i_sub;
+ GV * i_gv;
+ I32 retcnt;
+ SV * errsv;
+ char * errstr;
+ SV * miscsv = sv_newmortal();
+ HV * hv = (HV*)sv_2mortal((SV*)newHV());
+CODE:
+ i_sub = get_cv("i", 0);
+ PUSHMARK(SP);
+ /* PUTBACK not needed since this sub was called with 0 args, and is calling
+ 0 args, so global SP doesn't need to be moved before a call_* */
+ retcnt = call_sv((SV*)i_sub, 0); /* try a CV* */
+ SPAGAIN;
+ SP -= retcnt; /* dont care about return count, wipe everything off */
+ sv_setpvs(miscsv, "i");
+ PUSHMARK(SP);
+ retcnt = call_sv(miscsv, 0); /* try a PV */
+ SPAGAIN;
+ SP -= retcnt;
+ /* no add and SVt_NULL are intentional, sub i should be defined already */
+ i_gv = gv_fetchpvn_flags("i", sizeof("i")-1, 0, SVt_NULL);
+ PUSHMARK(SP);
+ retcnt = call_sv((SV*)i_gv, 0); /* try a GV* */
+ SPAGAIN;
+ SP -= retcnt;
+ /* the tests below are not declaring this being public API behavior,
+ only current internal behavior, these tests can be changed in the
+ future if necessery */
+ PUSHMARK(SP);
+ retcnt = call_sv(&PL_sv_yes, 0); /* does nothing */
+ SPAGAIN;
+ SP -= retcnt;
+ PUSHMARK(SP);
+ retcnt = call_sv(&PL_sv_no, G_EVAL);
+ SPAGAIN;
+ SP -= retcnt;
+ errsv = ERRSV;
+ errstr = SvPV_nolen(errsv);
+ if(strnEQ(errstr, "Undefined subroutine &main:: called at",
+ sizeof("Undefined subroutine &main:: called at") - 1)) {
+ PUSHMARK(SP);
+ retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
+ SPAGAIN;
+ SP -= retcnt;
+ }
+ PUSHMARK(SP);
+ retcnt = call_sv(&PL_sv_undef, G_EVAL);
+ SPAGAIN;
+ SP -= retcnt;
+ errsv = ERRSV;
+ errstr = SvPV_nolen(errsv);
+ if(strnEQ(errstr, "Can't use an undefined value as a subroutine reference at",
+ sizeof("Can't use an undefined value as a subroutine reference at") - 1)) {
+ PUSHMARK(SP);
+ retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
+ SPAGAIN;
+ SP -= retcnt;
+ }
+ PUSHMARK(SP);
+ retcnt = call_sv((SV*)hv, G_EVAL);
+ SPAGAIN;
+ SP -= retcnt;
+ errsv = ERRSV;
+ errstr = SvPV_nolen(errsv);
+ if(strnEQ(errstr, "Not a CODE reference at",
+ sizeof("Not a CODE reference at") - 1)) {
+ PUSHMARK(SP);
+ retcnt = call_sv((SV*)i_sub, 0); /* call again to increase counter */
+ SPAGAIN;
+ SP -= retcnt;
+ }
void
call_sv(sv, flags, ...)
ALIAS:
newCONSTSUB_flags = 1
PREINIT:
- CV* mycv;
+ CV* mycv = NULL;
STRLEN len;
const char *pv = SvPV(name, len);
PPCODE:
break;
}
EXTEND(SP, 2);
+ assert(mycv);
PUSHs( CvCONST(mycv) ? &PL_sv_yes : &PL_sv_no );
PUSHs((SV*)CvGV(mycv));
PREINIT:
STRLEN len;
const char * const name = SvPV_const(methname, len);
- GV* gv;
+ GV* gv = NULL;
PPCODE:
switch (type) {
case 0:
PREINIT:
STRLEN len;
const char * const name = SvPV_const(methname, len);
- GV* gv;
+ GV* gv = NULL;
PPCODE:
switch (type) {
case 0:
int type
I32 flags
PREINIT:
- GV* gv;
+ GV* gv = NULL;
PPCODE:
switch (type) {
case 0:
PREINIT:
STRLEN len;
const char * const name = SvPV_const(methname, len);
- GV* gv;
+ GV* gv = NULL;
I32 flags = method ? GV_AUTOLOAD_ISMETHOD : 0;
PPCODE:
switch (type) {
PREINIT:
STRLEN len;
const char * const name = SvPV_const(namesv, len);
- I32 i;
+ I32 i = 0;
PPCODE:
switch (type) {
case 0:
ST(4) = cop_hints_fetch_pvs(cx->blk_oldcop, "foo", 0);
ST(5) = cop_hints_fetch_pvn(cx->blk_oldcop, "foo", 3, 0, 0);
ST(6) = cop_hints_fetch_sv(cx->blk_oldcop,
- sv_2mortal(newSVpvn("foo", 3)), 0, 0);
+ sv_2mortal(newSVpvs("foo")), 0, 0);
hv = cop_hints_2hv(cx->blk_oldcop, 0);
ST(7) = hv ? sv_2mortal(newRV_noinc((SV *)hv)) : &PL_sv_undef;
SV *dest;
I32 got; /* Gah, badly thought out APIs */
CODE:
+ if (ix) (void)SvPV_force_nolen(sv);
source = (U8 *)SvPVbyte(sv, len);
/* Optionally only convert part of the buffer. */
if (items > 1) {
test_rv2cv_op_cv()
PROTOTYPE:
PREINIT:
- GV *troc_gv, *wibble_gv;
+ GV *troc_gv;
CV *troc_cv;
OP *o;
CODE:
troc_gv = gv_fetchpv("XS::APItest::test_rv2cv_op_cv", 0, SVt_PVGV);
troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0);
- wibble_gv = gv_fetchpv("XS::APItest::wibble", 0, SVt_PVGV);
o = newCVREF(0, newGVOP(OP_GV, 0, troc_gv));
if (rv2cv_op_cv(o, 0) != troc_cv) croak_fail();
if (rv2cv_op_cv(o, RV2CVOPCV_RETURN_NAME_GV) != (CV*)troc_gv)
MULTICALL;
}
POP_MULTICALL;
+ PERL_UNUSED_VAR(newsp);
XSRETURN_UNDEF;
}
hintkey_arraytermexpr_sv = newSVpvs_share("XS::APItest/arraytermexpr");
hintkey_arrayarithexpr_sv = newSVpvs_share("XS::APItest/arrayarithexpr");
hintkey_arrayexprflags_sv = newSVpvs_share("XS::APItest/arrayexprflags");
+ hintkey_DEFSV_sv = newSVpvs_share("XS::APItest/DEFSV");
+ hintkey_with_vars_sv = newSVpvs_share("XS::APItest/with_vars");
+ hintkey_join_with_space_sv = newSVpvs_share("XS::APItest/join_with_space");
next_keyword_plugin = PL_keyword_plugin;
PL_keyword_plugin = my_keyword_plugin;
}
for ( i = PadnamelistMAX(pad_namelist); i >= 0; i-- ) {
PADNAME* name = PadnamelistARRAY(pad_namelist)[i];
- if (SvPOKp(name)) {
+ if (PadnameLEN(name)) {
av_push(retav, newSVpadname(name));
}
}
void
stringify(SV *sv)
-PREINIT:
- const char *pv;
CODE:
- pv = SvPV_nolen(sv);
+ (void)SvPV_nolen(sv);
SV *
HvENAME(HV *hv)
SV *
xs_cmp_undef(SV *a, SV *b)
CODE:
+ PERL_UNUSED_ARG(a);
+ PERL_UNUSED_ARG(b);
RETVAL = &PL_sv_undef;
OUTPUT:
RETVAL
CODE:
{
const I32 floor = start_subparse(0,0);
- CV * const cv = PL_compcv;
/* The slab allocator does not like CvROOT being set. */
CvROOT(PL_compcv) = (OP *)1;
op_free(newFOROP(0, 0, newOP(OP_PUSHMARK, 0), 0, 0));
OUTPUT:
RETVAL
+SV *
+newRV(SV *sv)
+
+void
+alias_av(AV *av, IV ix, SV *sv)
+ CODE:
+ av_store(av, ix, SvREFCNT_inc(sv));
+
+SV *
+cv_name(SVREF ref, ...)
+ CODE:
+ RETVAL = SvREFCNT_inc(cv_name((CV *)ref,
+ items>1 && ST(1) != &PL_sv_undef
+ ? ST(1)
+ : NULL,
+ items>2 ? SvUV(ST(2)) : 0));
+ OUTPUT:
+ RETVAL
+
+void
+sv_catpvn(SV *sv, SV *sv2)
+ CODE:
+ {
+ STRLEN len;
+ const char *s = SvPV(sv2,len);
+ sv_catpvn_flags(sv,s,len, SvUTF8(sv2) ? SV_CATUTF8 : SV_CATBYTES);
+ }
+
MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
int
INIT:
SV* comms;
SV* class_and_method;
- SV* tmp;
CODE:
+ PERL_UNUSED_ARG(items);
class_and_method = GvSV(CvGV(cv));
comms = get_sv("main::the_method", 1);
if (class_and_method == NULL) {
MGVTBL *want;
CODE:
#define test_get_this_vtable(name) \
- want = CAT2(&PL_vtbl_, name); \
+ want = (MGVTBL*)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__)
RETVAL = _isQUOTEMETA(ord);
OUTPUT:
RETVAL
+
+UV
+test_toLOWER(UV ord)
+ CODE:
+ RETVAL = toLOWER(ord);
+ OUTPUT:
+ RETVAL
+
+UV
+test_toLOWER_L1(UV ord)
+ CODE:
+ RETVAL = toLOWER_L1(ord);
+ OUTPUT:
+ RETVAL
+
+UV
+test_toLOWER_LC(UV ord)
+ CODE:
+ RETVAL = toLOWER_LC(ord);
+ OUTPUT:
+ RETVAL
+
+AV *
+test_toLOWER_uni(UV ord)
+ PREINIT:
+ U8 s[UTF8_MAXBYTES_CASE + 1];
+ STRLEN len;
+ AV *av;
+ SV *utf8;
+ CODE:
+ av = newAV();
+ av_push(av, newSVuv(toLOWER_uni(ord, s, &len)));
+
+ utf8 = newSVpvn((char *) s, len);
+ SvUTF8_on(utf8);
+ av_push(av, utf8);
+
+ av_push(av, newSVuv(len));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+AV *
+test_toLOWER_utf8(SV * p)
+ PREINIT:
+ U8 *input;
+ U8 s[UTF8_MAXBYTES_CASE + 1];
+ STRLEN len;
+ AV *av;
+ SV *utf8;
+ CODE:
+ input = (U8 *) SvPV(p, len);
+ av = newAV();
+ av_push(av, newSVuv(toLOWER_utf8(input, s, &len)));
+
+ utf8 = newSVpvn((char *) s, len);
+ SvUTF8_on(utf8);
+ av_push(av, utf8);
+
+ av_push(av, newSVuv(len));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+UV
+test_toFOLD(UV ord)
+ CODE:
+ RETVAL = toFOLD(ord);
+ OUTPUT:
+ RETVAL
+
+UV
+test_toFOLD_LC(UV ord)
+ CODE:
+ RETVAL = toFOLD_LC(ord);
+ OUTPUT:
+ RETVAL
+
+AV *
+test_toFOLD_uni(UV ord)
+ PREINIT:
+ U8 s[UTF8_MAXBYTES_CASE + 1];
+ STRLEN len;
+ AV *av;
+ SV *utf8;
+ CODE:
+ av = newAV();
+ av_push(av, newSVuv(toFOLD_uni(ord, s, &len)));
+
+ utf8 = newSVpvn((char *) s, len);
+ SvUTF8_on(utf8);
+ av_push(av, utf8);
+
+ av_push(av, newSVuv(len));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+AV *
+test_toFOLD_utf8(SV * p)
+ PREINIT:
+ U8 *input;
+ U8 s[UTF8_MAXBYTES_CASE + 1];
+ STRLEN len;
+ AV *av;
+ SV *utf8;
+ CODE:
+ input = (U8 *) SvPV(p, len);
+ av = newAV();
+ av_push(av, newSVuv(toFOLD_utf8(input, s, &len)));
+
+ utf8 = newSVpvn((char *) s, len);
+ SvUTF8_on(utf8);
+ av_push(av, utf8);
+
+ av_push(av, newSVuv(len));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+UV
+test_toUPPER(UV ord)
+ CODE:
+ RETVAL = toUPPER(ord);
+ OUTPUT:
+ RETVAL
+
+UV
+test_toUPPER_LC(UV ord)
+ CODE:
+ RETVAL = toUPPER_LC(ord);
+ OUTPUT:
+ RETVAL
+
+AV *
+test_toUPPER_uni(UV ord)
+ PREINIT:
+ U8 s[UTF8_MAXBYTES_CASE + 1];
+ STRLEN len;
+ AV *av;
+ SV *utf8;
+ CODE:
+ av = newAV();
+ av_push(av, newSVuv(toUPPER_uni(ord, s, &len)));
+
+ utf8 = newSVpvn((char *) s, len);
+ SvUTF8_on(utf8);
+ av_push(av, utf8);
+
+ av_push(av, newSVuv(len));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+AV *
+test_toUPPER_utf8(SV * p)
+ PREINIT:
+ U8 *input;
+ U8 s[UTF8_MAXBYTES_CASE + 1];
+ STRLEN len;
+ AV *av;
+ SV *utf8;
+ CODE:
+ input = (U8 *) SvPV(p, len);
+ av = newAV();
+ av_push(av, newSVuv(toUPPER_utf8(input, s, &len)));
+
+ utf8 = newSVpvn((char *) s, len);
+ SvUTF8_on(utf8);
+ av_push(av, utf8);
+
+ av_push(av, newSVuv(len));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+UV
+test_toTITLE(UV ord)
+ CODE:
+ RETVAL = toTITLE(ord);
+ OUTPUT:
+ RETVAL
+
+AV *
+test_toTITLE_uni(UV ord)
+ PREINIT:
+ U8 s[UTF8_MAXBYTES_CASE + 1];
+ STRLEN len;
+ AV *av;
+ SV *utf8;
+ CODE:
+ av = newAV();
+ av_push(av, newSVuv(toTITLE_uni(ord, s, &len)));
+
+ utf8 = newSVpvn((char *) s, len);
+ SvUTF8_on(utf8);
+ av_push(av, utf8);
+
+ av_push(av, newSVuv(len));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+AV *
+test_toTITLE_utf8(SV * p)
+ PREINIT:
+ U8 *input;
+ U8 s[UTF8_MAXBYTES_CASE + 1];
+ STRLEN len;
+ AV *av;
+ SV *utf8;
+ CODE:
+ input = (U8 *) SvPV(p, len);
+ av = newAV();
+ av_push(av, newSVuv(toTITLE_utf8(input, s, &len)));
+
+ utf8 = newSVpvn((char *) s, len);
+ SvUTF8_on(utf8);
+ av_push(av, utf8);
+
+ av_push(av, newSVuv(len));
+ RETVAL = av;
+ OUTPUT:
+ RETVAL
+
+SV *
+test_Gconvert(SV * number, SV * num_digits)
+ PREINIT:
+ char buffer[100];
+ int len;
+ CODE:
+ len = (int) SvIV(num_digits);
+ if (len > 99) croak("Too long a number for test_Gconvert");
+ PERL_UNUSED_RESULT(Gconvert(SvNV(number), len,
+ 0, /* No trailing zeroes */
+ buffer));
+ RETVAL = newSVpv(buffer, 0);
+ OUTPUT:
+ RETVAL