X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/eba68aa09a0b159ee4eef3cee1bd58ee95fdb81a..03d05f6e34ec0d195930f4155352c2082f8dff3a:/ext/XS-APItest/APItest.xs diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index b23232c..c5ae2be 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -2,6 +2,7 @@ #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; @@ -82,7 +83,6 @@ typedef void (freeent_function)(pTHX_ HV *, HE *); void test_freeent(freeent_function *f) { - dTHX; dSP; HV *test_hash = newHV(); HE *victim; @@ -148,8 +148,8 @@ bitflip_key(pTHX_ IV action, SV *field) { 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); @@ -274,7 +274,7 @@ blockhook_csc_start(pTHX_ int full) 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))); } @@ -400,9 +400,9 @@ 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) + 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; @@ -412,17 +412,20 @@ STATIC OP * 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); @@ -449,7 +452,7 @@ test_op_list_describe_part(SV *res, OP *o) 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 { @@ -476,8 +479,7 @@ THX_mkUNOP(pTHX_ U32 type, OP *first) 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; } @@ -488,10 +490,8 @@ THX_mkBINOP(pTHX_ U32 type, OP *first, OP *last) 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; } @@ -502,11 +502,9 @@ THX_mkLISTOP(pTHX_ U32 type, OP *first, OP *sib, OP *last) 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; } @@ -532,12 +530,14 @@ STATIC void 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 * @@ -555,19 +555,21 @@ THX_pp_establish_cleanup(pTHX) 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; } @@ -575,13 +577,16 @@ THX_ck_entersub_establish_cleanup(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) 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)); @@ -595,12 +600,13 @@ THX_ck_entersub_pad_scalar(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) 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("$")); @@ -656,6 +662,9 @@ 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 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 */ @@ -688,16 +697,18 @@ static OP *THX_parse_var(pTHX) } #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); @@ -705,7 +716,9 @@ static OP *THX_parse_rpn_expr(pTHX) 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': @@ -941,6 +954,106 @@ static OP *THX_parse_keyword_arrayexprflags(pTHX) 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) @@ -1025,6 +1138,18 @@ static int my_keyword_plugin(pTHX_ 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); } @@ -1049,7 +1174,6 @@ peep_xop(pTHX_ OP *o, OP *oldop) 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); @@ -1090,14 +1214,14 @@ addissub_myck_add(pTHX_ OP *op) 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); } @@ -1151,7 +1275,7 @@ bytes_cmp_utf8(bytes, utf8) RETVAL AV * -test_utf8n_to_uvuni(s, len, flags) +test_utf8n_to_uvchr(s, len, flags) SV *s SV *len @@ -1162,7 +1286,7 @@ test_utf8n_to_uvuni(s, len, flags) 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 is; not checked, so could have buffer overflow @@ -1171,7 +1295,7 @@ test_utf8n_to_uvuni(s, len, flags) 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]; in [1] */ av_push(RETVAL, newSVuv(ret)); @@ -1455,13 +1579,17 @@ common(params) 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); @@ -1534,6 +1662,22 @@ refcounted_he_fetch(key, level=0) #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] } @@ -1621,6 +1765,7 @@ SV * AUTOLOADp(...) PROTOTYPE: *$ CODE: + PERL_UNUSED_ARG(items); RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv)); OUTPUT: RETVAL @@ -1710,12 +1855,9 @@ xop_build_optree () 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; @@ -1736,6 +1878,25 @@ xop_build_optree () 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; @@ -1904,6 +2065,81 @@ mxpushu() 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, ...) @@ -1965,7 +2201,7 @@ newCONSTSUB(stash, name, flags, sv) ALIAS: newCONSTSUB_flags = 1 PREINIT: - CV* mycv; + CV* mycv = NULL; STRLEN len; const char *pv = SvPV(name, len); PPCODE: @@ -1980,6 +2216,7 @@ newCONSTSUB(stash, name, flags, sv) break; } EXTEND(SP, 2); + assert(mycv); PUSHs( CvCONST(mycv) ? &PL_sv_yes : &PL_sv_no ); PUSHs((SV*)CvGV(mycv)); @@ -2023,7 +2260,7 @@ gv_fetchmeth_type(stash, methname, type, level, flags) PREINIT: STRLEN len; const char * const name = SvPV_const(methname, len); - GV* gv; + GV* gv = NULL; PPCODE: switch (type) { case 0: @@ -2051,7 +2288,7 @@ gv_fetchmeth_autoload_type(stash, methname, type, level, flags) PREINIT: STRLEN len; const char * const name = SvPV_const(methname, len); - GV* gv; + GV* gv = NULL; PPCODE: switch (type) { case 0: @@ -2076,7 +2313,7 @@ gv_fetchmethod_flags_type(stash, methname, type, flags) int type I32 flags PREINIT: - GV* gv; + GV* gv = NULL; PPCODE: switch (type) { case 0: @@ -2106,7 +2343,7 @@ gv_autoload_type(stash, methname, type, method) 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) { @@ -2132,7 +2369,7 @@ whichsig_type(namesv, type) PREINIT: STRLEN len; const char * const name = SvPV_const(namesv, len); - I32 i; + I32 i = 0; PPCODE: switch (type) { case 0: @@ -2313,7 +2550,7 @@ my_caller(level) 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; @@ -2364,6 +2601,7 @@ utf16_to_utf8 (sv, ...) 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) { @@ -2507,13 +2745,12 @@ void 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) @@ -3075,6 +3312,7 @@ CODE: MULTICALL; } POP_MULTICALL; + PERL_UNUSED_VAR(newsp); XSRETURN_UNDEF; } @@ -3198,6 +3436,9 @@ BOOT: 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; } @@ -3295,7 +3536,7 @@ CV* cv 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)); } } @@ -3319,10 +3560,8 @@ OUTPUT: void stringify(SV *sv) -PREINIT: - const char *pv; CODE: - pv = SvPV_nolen(sv); + (void)SvPV_nolen(sv); SV * HvENAME(HV *hv) @@ -3350,6 +3589,8 @@ OUTPUT: SV * xs_cmp_undef(SV *a, SV *b) CODE: + PERL_UNUSED_ARG(a); + PERL_UNUSED_ARG(b); RETVAL = &PL_sv_undef; OUTPUT: RETVAL @@ -3394,7 +3635,6 @@ test_newFOROP_without_slab() 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)); @@ -3459,6 +3699,34 @@ sv_mortalcopy(SV *sv) 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 @@ -3466,8 +3734,8 @@ AUTOLOAD(...) 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) { @@ -3518,7 +3786,7 @@ test_get_vtbl() 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__) @@ -4444,3 +4712,242 @@ test_isQUOTEMETA(UV ord) 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