X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/325e1816dc5cd0a76cbe852add810d33cb1a95fb..65df57a84b55413fcde1e64b86e3d740485536d3:/ext/XS-APItest/APItest.xs diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 8eaabdb..bb22e6c 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1,7 +1,15 @@ #define PERL_IN_XS_APITEST + +/* We want to be able to test things that aren't API yet. */ +#define PERL_EXT + +/* Do *not* define PERL_NO_GET_CONTEXT. This is the one place where we get + to test implicit Perl_get_context(). */ + #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; @@ -9,6 +17,61 @@ 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__) +#ifdef EBCDIC + +void +cat_utf8a2n(SV* sv, const char * const ascii_utf8, STRLEN len) +{ + /* Converts variant UTF-8 text pointed to by 'ascii_utf8' of length 'len', + * to UTF-EBCDIC, appending that text to the text already in 'sv'. + * Currently doesn't work on invariants, as that is unneeded here, and we + * could get double translations if we did. + * + * It has the algorithm for strict UTF-8 hard-coded in to find the code + * point it represents, then calls uvchr_to_utf8() to convert to + * UTF-EBCDIC). + * + * Note that this uses code points, not characters. Thus if the input is + * the UTF-8 for the code point 0xFF, the output will be the UTF-EBCDIC for + * 0xFF, even though that code point represents different characters on + * ASCII vs EBCDIC platforms. */ + + dTHX; + char * p = (char *) ascii_utf8; + const char * const e = p + len; + + while (p < e) { + UV code_point; + U8 native_utf8[UTF8_MAXBYTES + 1]; + U8 * char_end; + U8 start = (U8) *p; + + /* Start bytes are the same in both UTF-8 and I8, therefore we can + * treat this ASCII UTF-8 byte as an I8 byte. But PL_utf8skip[] is + * indexed by NATIVE_UTF8 bytes, so transform to that */ + STRLEN char_bytes_len = PL_utf8skip[I8_TO_NATIVE_UTF8(start)]; + + if (start < 0xc2) { + croak("fail: Expecting start byte, instead got 0x%X at %s line %d", + (U8) *p, __FILE__, __LINE__); + } + code_point = (start & (((char_bytes_len) >= 7) + ? 0x00 + : (0x1F >> ((char_bytes_len)-2)))); + p++; + while (p < e && ((( (U8) *p) & 0xC0) == 0x80)) { + + code_point = (code_point << 6) | (( (U8) *p) & 0x3F); + p++; + } + + char_end = uvchr_to_utf8(native_utf8, code_point); + sv_catpvn(sv, (char *) native_utf8, char_end - native_utf8); + } +} + +#endif + /* for my_cxt tests */ #define MY_CXT_KEY "XS::APItest::_guts" XS_VERSION @@ -30,7 +93,19 @@ typedef struct { START_MY_CXT +int +S_myset_set(pTHX_ SV* sv, MAGIC* mg) +{ + SV *isv = (SV*)mg->mg_ptr; + + PERL_UNUSED_ARG(sv); + SvIVX(isv)++; + return 0; +} + MGVTBL vtbl_foo, vtbl_bar; +MGVTBL vtbl_myset = { 0, S_myset_set, 0, 0, 0, 0, 0, 0 }; + /* indirect functions to test the [pa]MY_CXT macros */ @@ -82,7 +157,6 @@ typedef void (freeent_function)(pTHX_ HV *, HE *); void test_freeent(freeent_function *f) { - dTHX; dSP; HV *test_hash = newHV(); HE *victim; @@ -95,8 +169,8 @@ test_freeent(freeent_function *f) { #else /* Storing then deleting something should ensure that a hash entry is available. */ - (void) hv_store(test_hash, "", 0, &PL_sv_yes, 0); - (void) hv_delete(test_hash, "", 0, 0); + (void) hv_stores(test_hash, "", &PL_sv_yes); + (void) hv_deletes(test_hash, "", 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 */ @@ -130,6 +204,9 @@ test_freeent(freeent_function *f) { SvREFCNT_dec(test_scalar); } +/* Not that it matters much, but it's handy for the flipped character to just + * be the opposite case (at least for ASCII-range and most Latin1 as well). */ +#define FLIP_BIT ('A' ^ 'a') static I32 bitflip_key(pTHX_ IV action, SV *field) { @@ -141,24 +218,33 @@ bitflip_key(pTHX_ IV action, SV *field) { const char *p = SvPV(keysv, len); if (len) { - SV *newkey = newSV(len); - char *new_p = SvPVX(newkey); + /* Allow for the flipped val to be longer than the original. This + * is just for testing, so can afford to have some slop */ + const STRLEN newlen = len * 2; + + SV *newkey = newSV(newlen); + const char * const new_p_orig = SvPVX(newkey); + char *new_p = (char *) new_p_orig; if (SvUTF8(keysv)) { 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); - p += len; + STRLEN curlen; + UV chr = utf8_to_uvchr_buf((U8 *)p, (U8 *) end, &curlen); + + /* Make sure don't exceed bounds */ + assert(new_p - new_p_orig + curlen < newlen); + + new_p = (char *)uvchr_to_utf8((U8 *)new_p, chr ^ FLIP_BIT); + p += curlen; } SvUTF8_on(newkey); } else { while (len--) - *new_p++ = *p++ ^ 32; + *new_p++ = *p++ ^ FLIP_BIT; } *new_p = '\0'; - SvCUR_set(newkey, SvCUR(keysv)); + SvCUR_set(newkey, new_p - new_p_orig); SvPOK_on(newkey); mg->mg_obj = newkey; @@ -259,7 +345,12 @@ rmagical_a_dummy(pTHX_ IV idx, SV *sv) { return 0; } -STATIC MGVTBL rmagical_b = { 0 }; +/* We could do "= { 0 };" but some versions of gcc do warn + * (with -Wextra) about missing initializer, this is probably gcc + * being a bit too paranoid. But since this is file-static, we can + * just have it without initializer, since it should get + * zero-initialized. */ +STATIC MGVTBL rmagical_b; STATIC void blockhook_csc_start(pTHX_ int full) @@ -274,7 +365,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 +491,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 (!OpHAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; - for (aop = aop->op_sibling; aop->op_sibling; aop = aop->op_sibling) { + for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) { op_contextualize(aop, G_SCALAR); } return entersubop; @@ -412,17 +503,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 (!OpHAS_SIBLING(pushop)) { + parent = pushop; pushop = cUNOPx(pushop)->op_first; + } while (1) { - OP *aop = pushop->op_sibling; - if (!aop->op_sibling) + OP *aop = OpSIBLING(pushop); + if (!OpHAS_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 +543,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 = OpSIBLING(k)) test_op_list_describe_part(res, k); sv_catpvs(res, "]"); } else { @@ -476,8 +570,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 +581,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 +593,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 +621,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 +646,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(!OpHAS_SIBLING(pushop)) { + parent = pushop; + pushop = cUNOPx(pushop)->op_first; + } + /* extract out first arg, then delete the rest of the tree */ + argop = OpSIBLING(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 +668,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(!OpHAS_SIBLING(pushop)) { + parent = pushop; + pushop = cUNOPx(pushop)->op_first; + } + argop = OpSIBLING(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 +691,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(!OpHAS_SIBLING(pushop)) + pushop = cUNOPx(pushop)->op_first; + argop = OpSIBLING(pushop); + if(argop->op_type != OP_CONST || OpSIBLING(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(OpSIBLING(argop)); switch(SvIV(a0)) { case 1: { SV *namesv = sv_2mortal(newSVpvs("$")); @@ -656,6 +753,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 +788,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 +807,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 +1045,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) @@ -956,75 +1160,87 @@ static int THX_keyword_active(pTHX_ SV *hintkey_sv) static int my_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) { - if(keyword_len == 3 && strnEQ(keyword_ptr, "rpn", 3) && + if(keyword_len == 3 && strEQs(keyword_ptr, "rpn") && keyword_active(hintkey_rpn_sv)) { *op_ptr = parse_keyword_rpn(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 7 && strnEQ(keyword_ptr, "calcrpn", 7) && + } else if(keyword_len == 7 && strEQs(keyword_ptr, "calcrpn") && keyword_active(hintkey_calcrpn_sv)) { *op_ptr = parse_keyword_calcrpn(); return KEYWORD_PLUGIN_STMT; - } else if(keyword_len == 9 && strnEQ(keyword_ptr, "stufftest", 9) && + } else if(keyword_len == 9 && strEQs(keyword_ptr, "stufftest") && keyword_active(hintkey_stufftest_sv)) { *op_ptr = parse_keyword_stufftest(); return KEYWORD_PLUGIN_STMT; } else if(keyword_len == 12 && - strnEQ(keyword_ptr, "swaptwostmts", 12) && + strEQs(keyword_ptr, "swaptwostmts") && keyword_active(hintkey_swaptwostmts_sv)) { *op_ptr = parse_keyword_swaptwostmts(); return KEYWORD_PLUGIN_STMT; - } else if(keyword_len == 8 && strnEQ(keyword_ptr, "looprest", 8) && + } else if(keyword_len == 8 && strEQs(keyword_ptr, "looprest") && keyword_active(hintkey_looprest_sv)) { *op_ptr = parse_keyword_looprest(); return KEYWORD_PLUGIN_STMT; - } else if(keyword_len == 14 && strnEQ(keyword_ptr, "scopelessblock", 14) && + } else if(keyword_len == 14 && strEQs(keyword_ptr, "scopelessblock") && keyword_active(hintkey_scopelessblock_sv)) { *op_ptr = parse_keyword_scopelessblock(); return KEYWORD_PLUGIN_STMT; - } else if(keyword_len == 10 && strnEQ(keyword_ptr, "stmtasexpr", 10) && + } else if(keyword_len == 10 && strEQs(keyword_ptr, "stmtasexpr") && keyword_active(hintkey_stmtasexpr_sv)) { *op_ptr = parse_keyword_stmtasexpr(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 11 && strnEQ(keyword_ptr, "stmtsasexpr", 11) && + } else if(keyword_len == 11 && strEQs(keyword_ptr, "stmtsasexpr") && keyword_active(hintkey_stmtsasexpr_sv)) { *op_ptr = parse_keyword_stmtsasexpr(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 9 && strnEQ(keyword_ptr, "loopblock", 9) && + } else if(keyword_len == 9 && strEQs(keyword_ptr, "loopblock") && keyword_active(hintkey_loopblock_sv)) { *op_ptr = parse_keyword_loopblock(); return KEYWORD_PLUGIN_STMT; - } else if(keyword_len == 11 && strnEQ(keyword_ptr, "blockasexpr", 11) && + } else if(keyword_len == 11 && strEQs(keyword_ptr, "blockasexpr") && keyword_active(hintkey_blockasexpr_sv)) { *op_ptr = parse_keyword_blockasexpr(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 9 && strnEQ(keyword_ptr, "swaplabel", 9) && + } else if(keyword_len == 9 && strEQs(keyword_ptr, "swaplabel") && keyword_active(hintkey_swaplabel_sv)) { *op_ptr = parse_keyword_swaplabel(); return KEYWORD_PLUGIN_STMT; - } else if(keyword_len == 10 && strnEQ(keyword_ptr, "labelconst", 10) && + } else if(keyword_len == 10 && strEQs(keyword_ptr, "labelconst") && keyword_active(hintkey_labelconst_sv)) { *op_ptr = parse_keyword_labelconst(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arrayfullexpr", 13) && + } else if(keyword_len == 13 && strEQs(keyword_ptr, "arrayfullexpr") && keyword_active(hintkey_arrayfullexpr_sv)) { *op_ptr = parse_keyword_arrayfullexpr(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arraylistexpr", 13) && + } else if(keyword_len == 13 && strEQs(keyword_ptr, "arraylistexpr") && keyword_active(hintkey_arraylistexpr_sv)) { *op_ptr = parse_keyword_arraylistexpr(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 13 && strnEQ(keyword_ptr, "arraytermexpr", 13) && + } else if(keyword_len == 13 && strEQs(keyword_ptr, "arraytermexpr") && keyword_active(hintkey_arraytermexpr_sv)) { *op_ptr = parse_keyword_arraytermexpr(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 14 && strnEQ(keyword_ptr, "arrayarithexpr", 14) && + } else if(keyword_len == 14 && strEQs(keyword_ptr, "arrayarithexpr") && keyword_active(hintkey_arrayarithexpr_sv)) { *op_ptr = parse_keyword_arrayarithexpr(); return KEYWORD_PLUGIN_EXPR; - } else if(keyword_len == 14 && strnEQ(keyword_ptr, "arrayexprflags", 14) && + } else if(keyword_len == 14 && strEQs(keyword_ptr, "arrayexprflags") && keyword_active(hintkey_arrayexprflags_sv)) { *op_ptr = parse_keyword_arrayexprflags(); return KEYWORD_PLUGIN_EXPR; + } else if(keyword_len == 5 && strEQs(keyword_ptr, "DEFSV") && + keyword_active(hintkey_DEFSV_sv)) { + *op_ptr = parse_keyword_DEFSV(); + return KEYWORD_PLUGIN_EXPR; + } else if(keyword_len == 9 && strEQs(keyword_ptr, "with_vars") && + keyword_active(hintkey_with_vars_sv)) { + *op_ptr = parse_keyword_with_vars(); + return KEYWORD_PLUGIN_STMT; + } else if(keyword_len == 15 && strEQs(keyword_ptr, "join_with_space") && + 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 +1265,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 +1305,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 = OpSIBLING(aop)) && + !OpHAS_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); } @@ -1132,6 +1347,14 @@ INCLUDE: const-xs.inc INCLUDE: numeric.xs +void +assertx(int x) + CODE: + /* this only needs to compile and checks that assert() can be + used this way syntactically */ + (void)(assert(x), 1); + (void)(x); + MODULE = XS::APItest::utf8 PACKAGE = XS::APItest::utf8 int @@ -1151,7 +1374,7 @@ bytes_cmp_utf8(bytes, utf8) RETVAL AV * -test_utf8n_to_uvuni(s, len, flags) +test_utf8n_to_uvchr_error(s, len, flags) SV *s SV *len @@ -1160,20 +1383,25 @@ test_utf8n_to_uvuni(s, len, flags) STRLEN retlen; UV ret; STRLEN slen; + U32 errors; CODE: - /* Call utf8n_to_uvuni() with the inputs. It always asks for the - * actual length to be returned + /* Now that utf8n_to_uvchr() is a trivial wrapper for + * utf8n_to_uvchr_error(), call the latter with the inputs. It always + * asks for the actual length to be returned and errors to be returned * * Length to assume is; not checked, so could have buffer overflow */ RETVAL = newAV(); sv_2mortal((SV*)RETVAL); - ret - = utf8n_to_uvuni((U8*) SvPV(s, slen), SvUV(len), &retlen, SvUV(flags)); + ret = utf8n_to_uvchr_error((U8*) SvPV(s, slen), + SvUV(len), + &retlen, + SvUV(flags), + &errors); - /* Returns the return value in [0]; in [1] */ + /* Returns the return value in [0]; in [1], in [2] */ av_push(RETVAL, newSVuv(ret)); if (retlen == (STRLEN) -1) { av_push(RETVAL, newSViv(-1)); @@ -1181,6 +1409,55 @@ test_utf8n_to_uvuni(s, len, flags) else { av_push(RETVAL, newSVuv(retlen)); } + av_push(RETVAL, newSVuv(errors)); + + OUTPUT: + RETVAL + +AV * +test_valid_utf8_to_uvchr(s) + + SV *s + PREINIT: + STRLEN retlen; + UV ret; + STRLEN slen; + + CODE: + /* 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 + */ + RETVAL = newAV(); + sv_2mortal((SV*)RETVAL); + + ret + = valid_utf8_to_uvchr((U8*) SvPV(s, slen), &retlen); + + /* Returns the return value in [0]; in [1] */ + av_push(RETVAL, newSVuv(ret)); + av_push(RETVAL, newSVuv(retlen)); + + OUTPUT: + RETVAL + +SV * +test_uvchr_to_utf8_flags(uv, flags) + + SV *uv + SV *flags + PREINIT: + U8 dest[UTF8_MAXBYTES]; + U8 *ret; + + CODE: + /* Call uvchr_to_utf8_flags() with the inputs. */ + ret = uvchr_to_utf8_flags(dest, SvUV(uv), SvUV(flags)); + if (! ret) { + XSRETURN_UNDEF; + } + RETVAL = newSVpvn((char *) dest, ret - dest); OUTPUT: RETVAL @@ -1247,6 +1524,61 @@ XS_APIVERSION_valid(...) XS_APIVERSION_BOOTCHECK; XSRETURN_EMPTY; +void +xsreturn( int len ) + PPCODE: + int i = 0; + EXTEND( SP, len ); + for ( ; i < len; i++ ) { + ST(i) = sv_2mortal( newSViv(i) ); + } + XSRETURN( len ); + +void +xsreturn_iv() + PPCODE: + XSRETURN_IV(I32_MIN + 1); + +void +xsreturn_uv() + PPCODE: + XSRETURN_UV( (U32)((1U<<31) + 1) ); + +void +xsreturn_nv() + PPCODE: + XSRETURN_NV(0.25); + +void +xsreturn_pv() + PPCODE: + XSRETURN_PV("returned"); + +void +xsreturn_pvn() + PPCODE: + XSRETURN_PVN("returned too much",8); + +void +xsreturn_no() + PPCODE: + XSRETURN_NO; + +void +xsreturn_yes() + PPCODE: + XSRETURN_YES; + +void +xsreturn_undef() + PPCODE: + XSRETURN_UNDEF; + +void +xsreturn_empty() + PPCODE: + XSRETURN_EMPTY; + MODULE = XS::APItest:Hash PACKAGE = XS::APItest::Hash void @@ -1455,13 +1787,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 +1870,22 @@ refcounted_he_fetch(key, level=0) #endif +void +test_force_keys(HV *hv) + PREINIT: + HE *he; + SSize_t 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 +1973,7 @@ SV * AUTOLOADp(...) PROTOTYPE: *$ CODE: + PERL_UNUSED_ARG(items); RETVAL = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SvUTF8(cv)); OUTPUT: RETVAL @@ -1710,12 +2063,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 +2086,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; @@ -1905,6 +2274,114 @@ mxpushu() XSRETURN(3); + # test_EXTEND(): excerise the EXTEND() macro. + # After calling EXTEND(), it also does *(p+n) = NULL and + # *PL_stack_max = NULL to allow valgrind etc to spot if the stack hasn't + # actually been extended properly. + # + # max_offset specifies the SP to use. It is treated as a signed offset + # from PL_stack_max. + # nsv is the SV holding the value of n indicating how many slots + # to extend the stack by. + # use_ss is a boolean indicating that n should be cast to a SSize_t + +void +test_EXTEND(max_offset, nsv, use_ss) + IV max_offset; + SV *nsv; + bool use_ss; +PREINIT: + SV **sp = PL_stack_max + max_offset; +PPCODE: + if (use_ss) { + SSize_t n = (SSize_t)SvIV(nsv); + EXTEND(sp, n); + *(sp + n) = NULL; + } + else { + IV n = SvIV(nsv); + EXTEND(sp, n); + *(sp + n) = NULL; + } + *PL_stack_max = NULL; + + +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, ...) SV* sv @@ -1940,6 +2417,23 @@ call_pv(subname, flags, ...) PUSHs(sv_2mortal(newSViv(i))); void +call_argv(subname, flags, ...) + char* subname + I32 flags + PREINIT: + I32 i; + char *tmpary[4]; + PPCODE: + for (i=0; iblk_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 +2882,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 +3026,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) @@ -2633,6 +3151,11 @@ void test_cophh() PREINIT: COPHH *a, *b; +#ifdef EBCDIC + SV* key_sv; + char * key_name; + STRLEN key_len; +#endif CODE: #define check_ph(EXPR) \ do { if((EXPR) != &PL_sv_placeholder) croak("fail"); } while(0) @@ -2696,24 +3219,81 @@ test_cophh() check_iv(cophh_fetch_pvs(a, "foo_3", 0), 333); check_iv(cophh_fetch_pvs(a, "foo_4", 0), 444); check_ph(cophh_fetch_pvs(a, "foo_5", 0)); - a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8); + a = cophh_store_pvs(a, "foo_1", msviv(11111), COPHH_KEY_UTF8); a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0); +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8); +#else + /* On EBCDIC, we need to translate the UTF-8 in the ASCII test to the + * equivalent UTF-EBCDIC for the code page. This is done at runtime + * (with the helper function in this file). Therefore we can't use + * cophhh_store_pvs(), as we don't have literal string */ + key_sv = sv_2mortal(newSVpvs("foo_")); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8); +#endif +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8); +#endif +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8); +#endif check_iv(cophh_fetch_pvs(a, "foo_1", 0), 11111); check_iv(cophh_fetch_pvs(a, "foo_1", COPHH_KEY_UTF8), 11111); check_iv(cophh_fetch_pvs(a, "foo_\xaa", 0), 123); +#ifndef EBCDIC check_iv(cophh_fetch_pvs(a, "foo_\xc2\xaa", COPHH_KEY_UTF8), 123); check_ph(cophh_fetch_pvs(a, "foo_\xc2\xaa", 0)); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xaa")); + key_name = SvPV(key_sv, key_len); + check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 123); + check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0)); +#endif check_iv(cophh_fetch_pvs(a, "foo_\xbb", 0), 456); +#ifndef EBCDIC check_iv(cophh_fetch_pvs(a, "foo_\xc2\xbb", COPHH_KEY_UTF8), 456); check_ph(cophh_fetch_pvs(a, "foo_\xc2\xbb", 0)); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb")); + key_name = SvPV(key_sv, key_len); + check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 456); + check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0)); +#endif check_iv(cophh_fetch_pvs(a, "foo_\xcc", 0), 789); +#ifndef EBCDIC check_iv(cophh_fetch_pvs(a, "foo_\xc3\x8c", COPHH_KEY_UTF8), 789); check_ph(cophh_fetch_pvs(a, "foo_\xc2\x8c", 0)); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c")); + key_name = SvPV(key_sv, key_len); + check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 789); + check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0)); +#endif +#ifndef EBCDIC check_iv(cophh_fetch_pvs(a, "foo_\xd9\xa6", COPHH_KEY_UTF8), 666); check_ph(cophh_fetch_pvs(a, "foo_\xd9\xa6", 0)); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6")); + key_name = SvPV(key_sv, key_len); + check_iv(cophh_fetch_pvn(a, key_name, key_len, 0, COPHH_KEY_UTF8), 666); + check_ph(cophh_fetch_pvn(a, key_name, key_len, 0, 0)); +#endif ENTER; SAVEFREECOPHH(a); LEAVE; @@ -2748,15 +3328,41 @@ HV * example_cophh_2hv() PREINIT: COPHH *a; +#ifdef EBCDIC + SV* key_sv; + char * key_name; + STRLEN key_len; +#endif CODE: #define msviv(VALUE) sv_2mortal(newSViv(VALUE)) a = cophh_new_empty(); a = cophh_store_pvs(a, "foo_0", msviv(999), 0); a = cophh_store_pvs(a, "foo_1", msviv(111), 0); a = cophh_store_pvs(a, "foo_\xaa", msviv(123), 0); +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xc2\xbb", msviv(456), COPHH_KEY_UTF8); +#else + key_sv = sv_2mortal(newSVpvs("foo_")); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc2\xbb")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(456), COPHH_KEY_UTF8); +#endif +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xc3\x8c", msviv(789), COPHH_KEY_UTF8); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xc3\x8c")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(789), COPHH_KEY_UTF8); +#endif +#ifndef EBCDIC a = cophh_store_pvs(a, "foo_\xd9\xa6", msviv(666), COPHH_KEY_UTF8); +#else + sv_setpvs(key_sv, "foo_"); + cat_utf8a2n(key_sv, STR_WITH_LEN("\xd9\xa6")); + key_name = SvPV(key_sv, key_len); + a = cophh_store_pvn(a, key_name, key_len, 0, msviv(666), COPHH_KEY_UTF8); +#endif a = cophh_delete_pvs(a, "foo_0", 0); a = cophh_delete_pvs(a, "foo_2", 0); RETVAL = cophh_2hv(a, 0); @@ -3078,28 +3684,92 @@ CODE: XSRETURN_UNDEF; } -#ifdef USE_ITHREADS +=pod + +multicall_return(): call the passed sub once in the specificed context +and return whatever it returns + +=cut void -clone_with_stack() +multicall_return(block, context) + SV *block + I32 context +PROTOTYPE: &$ CODE: { - PerlInterpreter *interp = aTHX; /* The original interpreter */ - PerlInterpreter *interp_dup; /* The duplicate interpreter */ - int oldscope = 1; /* We are responsible for all scopes */ + dSP; + dMULTICALL; + GV *gv; + HV *stash; + I32 gimme = context; + CV *cv; + AV *av; + SV **p; + SSize_t i, size; - interp_dup = perl_clone(interp, CLONEf_COPY_STACKS | CLONEf_CLONE_HOST ); + cv = sv_2cv(block, &stash, &gv, 0); + if (cv == Nullcv) { + croak("multicall_return not a subroutine reference"); + } + PUSH_MULTICALL(cv); - /* destroy old perl */ - PERL_SET_CONTEXT(interp); + MULTICALL; - POPSTACK_TO(PL_mainstack); - dounwind(-1); - LEAVE_SCOPE(0); + /* copy returned values into an array so they're not freed during + * POP_MULTICALL */ - while (interp->Iscopestack_ix > 1) - LEAVE; - FREETMPS; + av = newAV(); + SPAGAIN; + + switch (context) { + case G_VOID: + break; + + case G_SCALAR: + av_push(av, SvREFCNT_inc(TOPs)); + break; + + case G_ARRAY: + for (p = PL_stack_base + 1; p <= SP; p++) + av_push(av, SvREFCNT_inc(*p)); + break; + } + + POP_MULTICALL; + + size = AvFILLp(av) + 1; + EXTEND(SP, size); + for (i = 0; i < size; i++) + ST(i) = *av_fetch(av, i, FALSE); + sv_2mortal((SV*)av); + XSRETURN(size); +} + + +#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); + if (cxstack_ix >= 0) { + dounwind(-1); + cx_popblock(cxstack); + } + LEAVE_SCOPE(0); + PL_scopestack_ix = oldscope; + FREETMPS; perl_destruct(interp); perl_free(interp); @@ -3198,6 +3868,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; } @@ -3319,10 +3992,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 +4021,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,15 +4067,25 @@ test_newFOROP_without_slab() CODE: { const I32 floor = start_subparse(0,0); - CV * const cv = PL_compcv; + OP *o; /* 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)); + o = newFOROP(0, 0, newOP(OP_PUSHMARK, 0), 0, 0); +#ifdef PERL_OP_PARENT + if (cLOOPx(cUNOPo->op_first)->op_last->op_sibparent + != cUNOPo->op_first) + { + Perl_warn(aTHX_ "Op parent pointer is stale"); + RETVAL = FALSE; + } + else +#endif + /* If we do not crash before returning, the test passes. */ + RETVAL = TRUE; + op_free(o); CvROOT(PL_compcv) = NULL; SvREFCNT_dec(PL_compcv); LEAVE_SCOPE(floor); - /* If we have not crashed yet, then the test passes. */ - RETVAL = TRUE; } OUTPUT: RETVAL @@ -3449,6 +4132,7 @@ lexical_import(SV *name, CV *cv) padadd_STATE, 0, 0); SvREFCNT_dec(PL_curpad[off]); PL_curpad[off] = SvREFCNT_inc(cv); + intro_my(); LEAVE; } @@ -3459,6 +4143,112 @@ 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); + } + +bool +test_newOP_CUSTOM() + CODE: + { + OP *o = newLISTOP(OP_CUSTOM, 0, NULL, NULL); + op_free(o); + o = newOP(OP_CUSTOM, 0); + op_free(o); + o = newUNOP(OP_CUSTOM, 0, NULL); + op_free(o); + o = newUNOP_AUX(OP_CUSTOM, 0, NULL, NULL); + op_free(o); + o = newMETHOP(OP_CUSTOM, 0, newOP(OP_NULL,0)); + op_free(o); + o = newMETHOP_named(OP_CUSTOM, 0, newSV(0)); + op_free(o); + o = newBINOP(OP_CUSTOM, 0, NULL, NULL); + op_free(o); + o = newPMOP(OP_CUSTOM, 0); + op_free(o); + o = newSVOP(OP_CUSTOM, 0, newSV(0)); + op_free(o); +#ifdef USE_ITHREADS + ENTER; + lex_start(NULL, NULL, 0); + { + I32 ix = start_subparse(FALSE,0); + o = newPADOP(OP_CUSTOM, 0, newSV(0)); + op_free(o); + LEAVE_SCOPE(ix); + } + LEAVE; +#endif + o = newPVOP(OP_CUSTOM, 0, NULL); + op_free(o); + o = newLOGOP(OP_CUSTOM, 0, newOP(OP_NULL,0), newOP(OP_NULL,0)); + op_free(o); + o = newLOOPEX(OP_CUSTOM, newOP(OP_NULL,0)); + op_free(o); + RETVAL = TRUE; + } + OUTPUT: + RETVAL + +void +test_sv_catpvf(SV *fmtsv) + PREINIT: + SV *sv; + char *fmt; + CODE: + fmt = SvPV_nolen(fmtsv); + sv = sv_2mortal(newSVpvn("", 0)); + sv_catpvf(sv, fmt, 5, 6, 7, 8); + +void +load_module(flags, name, ...) + U32 flags + SV *name +CODE: + if (items == 2) { + Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), NULL); + } else if (items == 3) { + Perl_load_module(aTHX_ flags, SvREFCNT_inc(name), SvREFCNT_inc(ST(2))); + } else + Perl_croak(aTHX_ "load_module can't yet support %"IVdf" items", (IV)items); + +SV * +string_without_null(SV *sv) + CODE: + { + STRLEN len; + const char *s = SvPV(sv, len); + RETVAL = newSVpvn_flags(s, len, SvUTF8(sv)); + *SvEND(RETVAL) = 0xff; + } + OUTPUT: + RETVAL + MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest int @@ -3467,6 +4257,7 @@ AUTOLOAD(...) SV* comms; SV* class_and_method; CODE: + PERL_UNUSED_ARG(items); class_and_method = GvSV(CvGV(cv)); comms = get_sv("main::the_method", 1); if (class_and_method == NULL) { @@ -3510,6 +4301,11 @@ ALIAS: CODE: sv_unmagicext(SvRV(sv), PERL_MAGIC_ext, ix ? &vtbl_bar : &vtbl_foo); +void +sv_magic(SV *sv, SV *thingy) +CODE: + sv_magic(SvRV(sv), NULL, PERL_MAGIC_ext, (const char *)thingy, 0); + UV test_get_vtbl() PREINIT: @@ -3517,7 +4313,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__) @@ -3555,6 +4351,18 @@ test_get_vtbl() OUTPUT: RETVAL + + # attach ext magic to the SV pointed to by rsv that only has set magic, + # where that magic's job is to increment thingy + +void +sv_magic_myset(SV *rsv, SV *thingy) +CODE: + sv_magicext(SvRV(rsv), NULL, PERL_MAGIC_ext, &vtbl_myset, + (const char *)thingy, 0); + + + bool test_isBLANK_uni(UV ord) CODE: @@ -3948,6 +4756,20 @@ test_isDIGIT_LC(UV ord) RETVAL bool +test_isOCTAL_A(UV ord) + CODE: + RETVAL = isOCTAL_A(ord); + OUTPUT: + RETVAL + +bool +test_isOCTAL_L1(UV ord) + CODE: + RETVAL = isOCTAL_L1(ord); + OUTPUT: + RETVAL + +bool test_isIDFIRST_uni(UV ord) CODE: RETVAL = isIDFIRST_uni(ord); @@ -4445,6 +5267,315 @@ test_isQUOTEMETA(UV ord) RETVAL UV +test_OFFUNISKIP(UV ord) + CODE: + RETVAL = OFFUNISKIP(ord); + OUTPUT: + RETVAL + +bool +test_OFFUNI_IS_INVARIANT(UV ord) + CODE: + RETVAL = OFFUNI_IS_INVARIANT(ord); + OUTPUT: + RETVAL + +bool +test_UVCHR_IS_INVARIANT(UV ord) + CODE: + RETVAL = UVCHR_IS_INVARIANT(ord); + OUTPUT: + RETVAL + +bool +test_UTF8_IS_INVARIANT(char ch) + CODE: + RETVAL = UTF8_IS_INVARIANT(ch); + OUTPUT: + RETVAL + +UV +test_UVCHR_SKIP(UV ord) + CODE: + RETVAL = UVCHR_SKIP(ord); + OUTPUT: + RETVAL + +UV +test_UTF8_SKIP(char * ch) + CODE: + RETVAL = UTF8_SKIP(ch); + OUTPUT: + RETVAL + +bool +test_UTF8_IS_START(char ch) + CODE: + RETVAL = UTF8_IS_START(ch); + OUTPUT: + RETVAL + +bool +test_UTF8_IS_CONTINUATION(char ch) + CODE: + RETVAL = UTF8_IS_CONTINUATION(ch); + OUTPUT: + RETVAL + +bool +test_UTF8_IS_CONTINUED(char ch) + CODE: + RETVAL = UTF8_IS_CONTINUED(ch); + OUTPUT: + RETVAL + +bool +test_UTF8_IS_DOWNGRADEABLE_START(char ch) + CODE: + RETVAL = UTF8_IS_DOWNGRADEABLE_START(ch); + OUTPUT: + RETVAL + +bool +test_UTF8_IS_ABOVE_LATIN1(char ch) + CODE: + RETVAL = UTF8_IS_ABOVE_LATIN1(ch); + OUTPUT: + RETVAL + +bool +test_isUTF8_POSSIBLY_PROBLEMATIC(char ch) + CODE: + RETVAL = isUTF8_POSSIBLY_PROBLEMATIC(ch); + OUTPUT: + RETVAL + +STRLEN +test_isUTF8_CHAR(char *s, STRLEN len) + CODE: + RETVAL = isUTF8_CHAR((U8 *) s, (U8 *) s + len); + OUTPUT: + RETVAL + +STRLEN +test_isUTF8_CHAR_flags(char *s, STRLEN len, U32 flags) + CODE: + RETVAL = isUTF8_CHAR_flags((U8 *) s, (U8 *) s + len, flags); + OUTPUT: + RETVAL + +STRLEN +test_isSTRICT_UTF8_CHAR(char *s, STRLEN len) + CODE: + RETVAL = isSTRICT_UTF8_CHAR((U8 *) s, (U8 *) s + len); + OUTPUT: + RETVAL + +STRLEN +test_isC9_STRICT_UTF8_CHAR(char *s, STRLEN len) + CODE: + RETVAL = isC9_STRICT_UTF8_CHAR((U8 *) s, (U8 *) s + len); + OUTPUT: + RETVAL + +IV +test_is_utf8_valid_partial_char_flags(char *s, STRLEN len, U32 flags) + CODE: + /* RETVAL should be bool (here and in tests below), but making it IV + * allows us to test it returning 0 or 1 */ + RETVAL = is_utf8_valid_partial_char_flags((U8 *) s, (U8 *) s + len, flags); + OUTPUT: + RETVAL + +IV +test_is_utf8_string(char *s, STRLEN len) + CODE: + RETVAL = is_utf8_string((U8 *) s, len); + OUTPUT: + RETVAL + +AV * +test_is_utf8_string_loc(char *s, STRLEN len) + PREINIT: + AV *av; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_utf8_string_loc((U8 *) s, len, &ep))); + av_push(av, newSViv(ep - (U8 *) s)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +test_is_utf8_string_loclen(char *s, STRLEN len) + PREINIT: + AV *av; + STRLEN ret_len; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_utf8_string_loclen((U8 *) s, len, &ep, &ret_len))); + av_push(av, newSViv(ep - (U8 *) s)); + av_push(av, newSVuv(ret_len)); + RETVAL = av; + OUTPUT: + RETVAL + +IV +test_is_utf8_string_flags(char *s, STRLEN len, U32 flags) + CODE: + RETVAL = is_utf8_string_flags((U8 *) s, len, flags); + OUTPUT: + RETVAL + +AV * +test_is_utf8_string_loc_flags(char *s, STRLEN len, U32 flags) + PREINIT: + AV *av; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_utf8_string_loc_flags((U8 *) s, len, &ep, flags))); + av_push(av, newSViv(ep - (U8 *) s)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +test_is_utf8_string_loclen_flags(char *s, STRLEN len, U32 flags) + PREINIT: + AV *av; + STRLEN ret_len; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_utf8_string_loclen_flags((U8 *) s, len, &ep, &ret_len, flags))); + av_push(av, newSViv(ep - (U8 *) s)); + av_push(av, newSVuv(ret_len)); + RETVAL = av; + OUTPUT: + RETVAL + +IV +test_is_strict_utf8_string(char *s, STRLEN len) + CODE: + RETVAL = is_strict_utf8_string((U8 *) s, len); + OUTPUT: + RETVAL + +AV * +test_is_strict_utf8_string_loc(char *s, STRLEN len) + PREINIT: + AV *av; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_strict_utf8_string_loc((U8 *) s, len, &ep))); + av_push(av, newSViv(ep - (U8 *) s)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +test_is_strict_utf8_string_loclen(char *s, STRLEN len) + PREINIT: + AV *av; + STRLEN ret_len; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_strict_utf8_string_loclen((U8 *) s, len, &ep, &ret_len))); + av_push(av, newSViv(ep - (U8 *) s)); + av_push(av, newSVuv(ret_len)); + RETVAL = av; + OUTPUT: + RETVAL + +IV +test_is_c9strict_utf8_string(char *s, STRLEN len) + CODE: + RETVAL = is_c9strict_utf8_string((U8 *) s, len); + OUTPUT: + RETVAL + +AV * +test_is_c9strict_utf8_string_loc(char *s, STRLEN len) + PREINIT: + AV *av; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_c9strict_utf8_string_loc((U8 *) s, len, &ep))); + av_push(av, newSViv(ep - (U8 *) s)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +test_is_c9strict_utf8_string_loclen(char *s, STRLEN len) + PREINIT: + AV *av; + STRLEN ret_len; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_c9strict_utf8_string_loclen((U8 *) s, len, &ep, &ret_len))); + av_push(av, newSViv(ep - (U8 *) s)); + av_push(av, newSVuv(ret_len)); + RETVAL = av; + OUTPUT: + RETVAL + +IV +test_is_utf8_fixed_width_buf_flags(char *s, STRLEN len, U32 flags) + CODE: + RETVAL = is_utf8_fixed_width_buf_flags((U8 *) s, len, flags); + OUTPUT: + RETVAL + +AV * +test_is_utf8_fixed_width_buf_loc_flags(char *s, STRLEN len, U32 flags) + PREINIT: + AV *av; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_utf8_fixed_width_buf_loc_flags((U8 *) s, len, &ep, flags))); + av_push(av, newSViv(ep - (U8 *) s)); + RETVAL = av; + OUTPUT: + RETVAL + +AV * +test_is_utf8_fixed_width_buf_loclen_flags(char *s, STRLEN len, U32 flags) + PREINIT: + AV *av; + STRLEN ret_len; + const U8 * ep; + CODE: + av = newAV(); + av_push(av, newSViv(is_utf8_fixed_width_buf_loclen_flags((U8 *) s, len, &ep, &ret_len, flags))); + av_push(av, newSViv(ep - (U8 *) s)); + av_push(av, newSVuv(ret_len)); + RETVAL = av; + OUTPUT: + RETVAL + +IV +test_utf8_hop_safe(SV *s_sv, STRLEN s_off, IV off) + PREINIT: + STRLEN len; + U8 *p; + U8 *r; + CODE: + p = (U8 *)SvPV(s_sv, len); + r = utf8_hop_safe(p + s_off, off, p, p + len); + RETVAL = r - p; + OUTPUT: + RETVAL + +UV test_toLOWER(UV ord) CODE: RETVAL = toLOWER(ord); @@ -4667,3 +5798,85 @@ test_toTITLE_utf8(SV * p) 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"); + if (len < 0) croak("Too short a number for test_Gconvert"); + PERL_UNUSED_RESULT(Gconvert(SvNV(number), len, + 0, /* No trailing zeroes */ + buffer)); + RETVAL = newSVpv(buffer, 0); + OUTPUT: + RETVAL + +MODULE = XS::APItest PACKAGE = XS::APItest::Backrefs + +void +apitest_weaken(SV *sv) + PROTOTYPE: $ + CODE: + sv_rvweaken(sv); + +SV * +has_backrefs(SV *sv) + CODE: + if (SvROK(sv) && sv_get_backrefs(SvRV(sv))) + RETVAL = &PL_sv_yes; + else + RETVAL = &PL_sv_no; + OUTPUT: + RETVAL + +#ifdef WIN32 +#ifdef PERL_IMPLICIT_SYS + +const char * +PerlDir_mapA(const char *path) + +const WCHAR * +PerlDir_mapW(const WCHAR *wpath) + +#endif + +void +Comctl32Version() + PREINIT: + HMODULE dll; + VS_FIXEDFILEINFO *info; + UINT len; + HRSRC hrsc; + HGLOBAL ver; + void * vercopy; + PPCODE: + dll = GetModuleHandle("comctl32.dll"); /* must already be in proc */ + if(!dll) + croak("Comctl32Version: comctl32.dll not in process???"); + hrsc = FindResource(dll, MAKEINTRESOURCE(VS_VERSION_INFO), + MAKEINTRESOURCE(VS_FILE_INFO)); + if(!hrsc) + croak("Comctl32Version: comctl32.dll no version???"); + ver = LoadResource(dll, hrsc); + len = SizeofResource(dll, hrsc); + vercopy = _alloca(len); + memcpy(vercopy, ver, len); + if (VerQueryValue(vercopy, "\\", (void**)&info, &len)) { + int dwValueMS1 = (info->dwFileVersionMS>>16); + int dwValueMS2 = (info->dwFileVersionMS&0xffff); + int dwValueLS1 = (info->dwFileVersionLS>>16); + int dwValueLS2 = (info->dwFileVersionLS&0xffff); + EXTEND(SP, 4); + mPUSHi(dwValueMS1); + mPUSHi(dwValueMS2); + mPUSHi(dwValueLS1); + mPUSHi(dwValueLS2); + } + +#endif + +