X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a59fa18fc69fd714097da0fbefe02d42727641f6..367917954ddd5b3c7085e1a814b02065191c7c38:/ext/XS-APItest/APItest.xs diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 1b8ec3f..7a18bbf 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1,4 +1,11 @@ #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" @@ -8,7 +15,63 @@ typedef SV *SVREF; 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__) +#define croak_fail_nep(h, w) croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__) +#define croak_fail_nei(h, w) croak("fail %d!=%d at " __FILE__ " line %d", (int)(h), (int)(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 */ @@ -31,7 +94,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 */ @@ -83,7 +158,6 @@ typedef void (freeent_function)(pTHX_ HV *, HE *); void test_freeent(freeent_function *f) { - dTHX; dSP; HV *test_hash = newHV(); HE *victim; @@ -96,8 +170,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 */ @@ -124,13 +198,16 @@ test_freeent(freeent_function *f) { i = 0; do { - mPUSHu(results[i]); + mXPUSHu(results[i]); } while (++i < (int)(sizeof(results)/sizeof(results[0]))); /* Goodbye to our extra reference. */ 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) { @@ -142,24 +219,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_uvchr_buf((U8 *)p, (U8 *) end, &len); - new_p = (char *)uvchr_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; @@ -260,7 +346,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) @@ -275,7 +366,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))); } @@ -401,9 +492,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; @@ -413,17 +504,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); @@ -450,7 +544,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 { @@ -477,8 +571,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; } @@ -489,10 +582,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; } @@ -503,11 +594,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; } @@ -558,19 +647,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; } @@ -578,13 +669,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)); @@ -598,12 +692,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("$")); @@ -659,6 +754,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 */ @@ -691,16 +789,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); @@ -708,7 +808,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': @@ -944,6 +1046,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) @@ -959,75 +1161,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); } @@ -1045,8 +1259,8 @@ static void peep_xop(pTHX_ OP *o, OP *oldop) { dMY_CXT; - av_push(MY_CXT.xop_record, newSVpvf("peep:%"UVxf, PTR2UV(o))); - av_push(MY_CXT.xop_record, newSVpvf("oldop:%"UVxf, PTR2UV(oldop))); + av_push(MY_CXT.xop_record, newSVpvf("peep:%" UVxf, PTR2UV(o))); + av_push(MY_CXT.xop_record, newSVpvf("oldop:%" UVxf, PTR2UV(oldop))); } static I32 @@ -1092,14 +1306,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); } @@ -1134,6 +1348,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 @@ -1153,7 +1375,7 @@ bytes_cmp_utf8(bytes, utf8) RETVAL AV * -test_utf8n_to_uvchr(s, len, flags) +test_utf8n_to_uvchr_error(s, len, flags) SV *s SV *len @@ -1162,20 +1384,25 @@ test_utf8n_to_uvchr(s, len, flags) STRLEN retlen; UV ret; STRLEN slen; + U32 errors; CODE: - /* Call utf8n_to_uvchr() 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_uvchr((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)); @@ -1183,6 +1410,55 @@ test_utf8n_to_uvchr(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 @@ -1249,6 +1525,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 @@ -1457,13 +1788,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); @@ -1515,7 +1850,7 @@ refcounted_he_exists(key, level=0) IV level CODE: if (level) { - croak("level must be zero, not %"IVdf, level); + croak("level must be zero, not %" IVdf, level); } RETVAL = (cop_hints_fetch_sv(PL_curcop, key, 0, 0) != &PL_sv_placeholder); OUTPUT: @@ -1527,7 +1862,7 @@ refcounted_he_fetch(key, level=0) IV level CODE: if (level) { - croak("level must be zero, not %"IVdf, level); + croak("level must be zero, not %" IVdf, level); } RETVAL = cop_hints_fetch_sv(PL_curcop, key, 0, 0); SvREFCNT_inc(RETVAL); @@ -1540,7 +1875,7 @@ void test_force_keys(HV *hv) PREINIT: HE *he; - STRLEN count = 0; + SSize_t count = 0; PPCODE: hv_iterinit(hv); he = hv_iternext(hv); @@ -1729,17 +2064,14 @@ 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; - av_push(MY_CXT.xop_record, newSVpvf("unop:%"UVxf, PTR2UV(unop))); - av_push(MY_CXT.xop_record, newSVpvf("kid:%"UVxf, PTR2UV(kid))); + av_push(MY_CXT.xop_record, newSVpvf("unop:%" UVxf, PTR2UV(unop))); + av_push(MY_CXT.xop_record, newSVpvf("kid:%" UVxf, PTR2UV(kid))); av_push(MY_CXT.xop_record, newSVpvf("NAME:%s", OP_NAME((OP*)unop))); av_push(MY_CXT.xop_record, newSVpvf("DESC:%s", OP_DESC((OP*)unop))); @@ -1763,12 +2095,9 @@ xop_from_custom_op () UNOP *unop; XOP *xop; - NewOp(1102, unop, 1, UNOP); - unop->op_type = OP_CUSTOM; + unop = (UNOP*)mkUNOP(OP_CUSTOM, NULL); unop->op_ppaddr = pp_xop; - unop->op_flags = OPf_KIDS; unop->op_private = 0; - unop->op_first = NULL; unop->op_next = NULL; xop = Perl_custom_op_xop(aTHX_ (OP *)unop); @@ -1945,6 +2274,39 @@ mxpushu() mXPUSHu(3); 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: @@ -2056,6 +2418,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; @@ -2480,6 +2883,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) { @@ -2685,34 +3089,60 @@ test_cv_getset_call_checker() CV *troc_cv, *tsh_cv; Perl_call_checker ckfun; SV *ckobj; + U32 ckflags; CODE: -#define check_cc(cv, xckfun, xckobj) \ +#define check_cc(cv, xckfun, xckobj, xckflags) \ do { \ cv_get_call_checker((cv), &ckfun, &ckobj); \ - if (ckfun != (xckfun)) croak_fail_ne(FPTR2DPTR(void *, ckfun), xckfun); \ - if (ckobj != (xckobj)) croak_fail_ne(FPTR2DPTR(void *, ckobj), xckobj); \ + if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), xckfun); \ + if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), xckobj); \ + cv_get_call_checker_flags((cv), CALL_CHECKER_REQUIRE_GV, &ckfun, &ckobj, &ckflags); \ + if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), xckfun); \ + if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), xckobj); \ + if (ckflags != CALL_CHECKER_REQUIRE_GV) croak_fail_nei(ckflags, CALL_CHECKER_REQUIRE_GV); \ + cv_get_call_checker_flags((cv), 0, &ckfun, &ckobj, &ckflags); \ + if (ckfun != (xckfun)) croak_fail_nep(FPTR2DPTR(void *, ckfun), xckfun); \ + if (ckobj != (xckobj)) croak_fail_nep(FPTR2DPTR(void *, ckobj), xckobj); \ + if (ckflags != (xckflags)) croak_fail_nei(ckflags, (xckflags)); \ } while(0) troc_cv = get_cv("XS::APItest::test_rv2cv_op_cv", 0); tsh_cv = get_cv("XS::APItest::test_savehints", 0); - check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv); - check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv); + check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0); cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes); - check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv); - check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes); + check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV); cv_set_call_checker(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no); - check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no); - check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes); + check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no, CALL_CHECKER_REQUIRE_GV); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV); cv_set_call_checker(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv); - check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no); - check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv); + check_cc(troc_cv, THX_ck_entersub_args_scalars, &PL_sv_no, CALL_CHECKER_REQUIRE_GV); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0); cv_set_call_checker(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv); - check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv); - check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv); + check_cc(troc_cv, Perl_ck_entersub_args_proto_or_list, (SV*)troc_cv, 0); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0); if (SvMAGICAL((SV*)troc_cv) || SvMAGIC((SV*)troc_cv)) croak_fail(); if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail(); + cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list, + &PL_sv_yes, 0); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, 0); + cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list, + &PL_sv_yes, CALL_CHECKER_REQUIRE_GV); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV); + cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list, + (SV*)tsh_cv, 0); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0); + if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail(); + cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list, + &PL_sv_yes, CALL_CHECKER_REQUIRE_GV); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes, CALL_CHECKER_REQUIRE_GV); + cv_set_call_checker_flags(tsh_cv, Perl_ck_entersub_args_proto_or_list, + (SV*)tsh_cv, CALL_CHECKER_REQUIRE_GV); + check_cc(tsh_cv, Perl_ck_entersub_args_proto_or_list, (SV*)tsh_cv, 0); + if (SvMAGICAL((SV*)tsh_cv) || SvMAGIC((SV*)tsh_cv)) croak_fail(); #undef check_cc void @@ -2748,6 +3178,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) @@ -2811,24 +3246,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; @@ -2863,15 +3355,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); @@ -3190,10 +3708,72 @@ CODE: MULTICALL; } POP_MULTICALL; - PERL_UNUSED_VAR(newsp); XSRETURN_UNDEF; } +=pod + +multicall_return(): call the passed sub once in the specificed context +and return whatever it returns + +=cut + +void +multicall_return(block, context) + SV *block + I32 context +PROTOTYPE: &$ +CODE: +{ + dSP; + dMULTICALL; + GV *gv; + HV *stash; + I32 gimme = context; + CV *cv; + AV *av; + SV **p; + SSize_t i, size; + + cv = sv_2cv(block, &stash, &gv, 0); + if (cv == Nullcv) { + croak("multicall_return not a subroutine reference"); + } + PUSH_MULTICALL(cv); + + MULTICALL; + + /* copy returned values into an array so they're not freed during + * POP_MULTICALL */ + + 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 @@ -3210,11 +3790,12 @@ CODE: PERL_SET_CONTEXT(interp); POPSTACK_TO(PL_mainstack); - dounwind(-1); + if (cxstack_ix >= 0) { + dounwind(-1); + cx_popblock(cxstack); + } LEAVE_SCOPE(0); - - while (interp->Iscopestack_ix > 1) - LEAVE; + PL_scopestack_ix = oldscope; FREETMPS; perl_destruct(interp); @@ -3314,6 +3895,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; } @@ -3510,14 +4094,25 @@ test_newFOROP_without_slab() CODE: { const I32 floor = start_subparse(0,0); + 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 @@ -3560,10 +4155,11 @@ lexical_import(SV *name, CV *cv) SAVESPTR(PL_comppad_name); PL_comppad_name = PadlistNAMES(pl); SAVESPTR(PL_comppad); PL_comppad = PadlistARRAY(pl)[1]; SAVESPTR(PL_curpad); PL_curpad = PadARRAY(PL_comppad); - off = pad_add_name_sv(sv_2mortal(newSVpvf("&%"SVf,name)), + off = pad_add_name_sv(sv_2mortal(newSVpvf("&%" SVf,name)), padadd_STATE, 0, 0); SvREFCNT_dec(PL_curpad[off]); PL_curpad[off] = SvREFCNT_inc(cv); + intro_my(); LEAVE; } @@ -3582,14 +4178,113 @@ alias_av(AV *av, IV ix, SV *sv) CODE: av_store(av, ix, SvREFCNT_inc(sv)); -MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest +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 -int -AUTOLOAD(...) - INIT: - SV* comms; - SV* class_and_method; - CODE: +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 +AUTOLOAD(...) + INIT: + SV* comms; + SV* class_and_method; + CODE: PERL_UNUSED_ARG(items); class_and_method = GvSV(CvGV(cv)); comms = get_sv("main::the_method", 1); @@ -3634,6 +4329,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: @@ -3641,7 +4341,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__) @@ -3679,6 +4379,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: @@ -3687,6 +4399,13 @@ test_isBLANK_uni(UV ord) RETVAL bool +test_isBLANK_uvchr(UV ord) + CODE: + RETVAL = isBLANK_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isBLANK_LC_uvchr(UV ord) CODE: RETVAL = isBLANK_LC_uvchr(ord); @@ -3694,6 +4413,13 @@ test_isBLANK_LC_uvchr(UV ord) RETVAL bool +test_isBLANK(UV ord) + CODE: + RETVAL = isBLANK(ord); + OUTPUT: + RETVAL + +bool test_isBLANK_A(UV ord) CODE: RETVAL = isBLANK_A(ord); @@ -3715,16 +4441,36 @@ test_isBLANK_LC(UV ord) RETVAL bool -test_isBLANK_utf8(unsigned char * p) +test_isBLANK_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isBLANK_utf8(p); + + /* In this function and those that follow, the boolean 'type' + * indicates if to pass a malformed UTF-8 string to the tested macro + * (malformed by making it too short) */ + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isBLANK_utf8_safe(p, e); + } + else { + RETVAL = isBLANK_utf8(p); + } OUTPUT: RETVAL bool -test_isBLANK_LC_utf8(unsigned char * p) +test_isBLANK_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isBLANK_LC_utf8(p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isBLANK_LC_utf8_safe(p, e); + } + else { + RETVAL = isBLANK_LC_utf8(p); + } OUTPUT: RETVAL @@ -3736,9 +4482,24 @@ test_isVERTWS_uni(UV ord) RETVAL bool -test_isVERTWS_utf8(unsigned char * p) +test_isVERTWS_uvchr(UV ord) + CODE: + RETVAL = isVERTWS_uvchr(ord); + OUTPUT: + RETVAL + +bool +test_isVERTWS_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isVERTWS_utf8(p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isVERTWS_utf8_safe(p, e); + } + else { + RETVAL = isVERTWS_utf8(p); + } OUTPUT: RETVAL @@ -3750,6 +4511,13 @@ test_isUPPER_uni(UV ord) RETVAL bool +test_isUPPER_uvchr(UV ord) + CODE: + RETVAL = isUPPER_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isUPPER_LC_uvchr(UV ord) CODE: RETVAL = isUPPER_LC_uvchr(ord); @@ -3757,6 +4525,13 @@ test_isUPPER_LC_uvchr(UV ord) RETVAL bool +test_isUPPER(UV ord) + CODE: + RETVAL = isUPPER(ord); + OUTPUT: + RETVAL + +bool test_isUPPER_A(UV ord) CODE: RETVAL = isUPPER_A(ord); @@ -3778,16 +4553,32 @@ test_isUPPER_LC(UV ord) RETVAL bool -test_isUPPER_utf8(unsigned char * p) +test_isUPPER_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isUPPER_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isUPPER_utf8_safe(p, e); + } + else { + RETVAL = isUPPER_utf8(p); + } OUTPUT: RETVAL bool -test_isUPPER_LC_utf8(unsigned char * p) +test_isUPPER_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isUPPER_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isUPPER_LC_utf8_safe(p, e); + } + else { + RETVAL = isUPPER_LC_utf8(p); + } OUTPUT: RETVAL @@ -3799,6 +4590,13 @@ test_isLOWER_uni(UV ord) RETVAL bool +test_isLOWER_uvchr(UV ord) + CODE: + RETVAL = isLOWER_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isLOWER_LC_uvchr(UV ord) CODE: RETVAL = isLOWER_LC_uvchr(ord); @@ -3806,6 +4604,13 @@ test_isLOWER_LC_uvchr(UV ord) RETVAL bool +test_isLOWER(UV ord) + CODE: + RETVAL = isLOWER(ord); + OUTPUT: + RETVAL + +bool test_isLOWER_A(UV ord) CODE: RETVAL = isLOWER_A(ord); @@ -3827,16 +4632,32 @@ test_isLOWER_LC(UV ord) RETVAL bool -test_isLOWER_utf8(unsigned char * p) +test_isLOWER_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isLOWER_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isLOWER_utf8_safe(p, e); + } + else { + RETVAL = isLOWER_utf8(p); + } OUTPUT: RETVAL bool -test_isLOWER_LC_utf8(unsigned char * p) +test_isLOWER_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isLOWER_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isLOWER_LC_utf8_safe(p, e); + } + else { + RETVAL = isLOWER_LC_utf8(p); + } OUTPUT: RETVAL @@ -3848,6 +4669,13 @@ test_isALPHA_uni(UV ord) RETVAL bool +test_isALPHA_uvchr(UV ord) + CODE: + RETVAL = isALPHA_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isALPHA_LC_uvchr(UV ord) CODE: RETVAL = isALPHA_LC_uvchr(ord); @@ -3855,6 +4683,13 @@ test_isALPHA_LC_uvchr(UV ord) RETVAL bool +test_isALPHA(UV ord) + CODE: + RETVAL = isALPHA(ord); + OUTPUT: + RETVAL + +bool test_isALPHA_A(UV ord) CODE: RETVAL = isALPHA_A(ord); @@ -3876,16 +4711,32 @@ test_isALPHA_LC(UV ord) RETVAL bool -test_isALPHA_utf8(unsigned char * p) +test_isALPHA_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isALPHA_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isALPHA_utf8_safe(p, e); + } + else { + RETVAL = isALPHA_utf8(p); + } OUTPUT: RETVAL bool -test_isALPHA_LC_utf8(unsigned char * p) +test_isALPHA_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isALPHA_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isALPHA_LC_utf8_safe(p, e); + } + else { + RETVAL = isALPHA_LC_utf8(p); + } OUTPUT: RETVAL @@ -3897,6 +4748,13 @@ test_isWORDCHAR_uni(UV ord) RETVAL bool +test_isWORDCHAR_uvchr(UV ord) + CODE: + RETVAL = isWORDCHAR_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isWORDCHAR_LC_uvchr(UV ord) CODE: RETVAL = isWORDCHAR_LC_uvchr(ord); @@ -3904,6 +4762,13 @@ test_isWORDCHAR_LC_uvchr(UV ord) RETVAL bool +test_isWORDCHAR(UV ord) + CODE: + RETVAL = isWORDCHAR(ord); + OUTPUT: + RETVAL + +bool test_isWORDCHAR_A(UV ord) CODE: RETVAL = isWORDCHAR_A(ord); @@ -3925,16 +4790,32 @@ test_isWORDCHAR_LC(UV ord) RETVAL bool -test_isWORDCHAR_utf8(unsigned char * p) +test_isWORDCHAR_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isWORDCHAR_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isWORDCHAR_utf8_safe(p, e); + } + else { + RETVAL = isWORDCHAR_utf8(p); + } OUTPUT: RETVAL bool -test_isWORDCHAR_LC_utf8(unsigned char * p) +test_isWORDCHAR_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isWORDCHAR_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isWORDCHAR_LC_utf8_safe(p, e); + } + else { + RETVAL = isWORDCHAR_LC_utf8(p); + } OUTPUT: RETVAL @@ -3946,6 +4827,13 @@ test_isALPHANUMERIC_uni(UV ord) RETVAL bool +test_isALPHANUMERIC_uvchr(UV ord) + CODE: + RETVAL = isALPHANUMERIC_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isALPHANUMERIC_LC_uvchr(UV ord) CODE: RETVAL = isALPHANUMERIC_LC_uvchr(ord); @@ -3953,6 +4841,13 @@ test_isALPHANUMERIC_LC_uvchr(UV ord) RETVAL bool +test_isALPHANUMERIC(UV ord) + CODE: + RETVAL = isALPHANUMERIC(ord); + OUTPUT: + RETVAL + +bool test_isALPHANUMERIC_A(UV ord) CODE: RETVAL = isALPHANUMERIC_A(ord); @@ -3974,16 +4869,39 @@ test_isALPHANUMERIC_LC(UV ord) RETVAL bool -test_isALPHANUMERIC_utf8(unsigned char * p) +test_isALPHANUMERIC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; + CODE: + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isALPHANUMERIC_utf8_safe(p, e); + } + else { + RETVAL = isALPHANUMERIC_utf8(p); + } + OUTPUT: + RETVAL + +bool +test_isALPHANUMERIC_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isALPHANUMERIC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isALPHANUMERIC_LC_utf8_safe(p, e); + } + else { + RETVAL = isALPHANUMERIC_LC_utf8(p); + } OUTPUT: RETVAL bool -test_isALPHANUMERIC_LC_utf8(unsigned char * p) +test_isALNUM(UV ord) CODE: - RETVAL = isALPHANUMERIC_LC_utf8( p); + RETVAL = isALNUM(ord); OUTPUT: RETVAL @@ -4009,16 +4927,32 @@ test_isALNUM_LC(UV ord) RETVAL bool -test_isALNUM_utf8(unsigned char * p) +test_isALNUM_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isALNUM_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isWORDCHAR_utf8_safe(p, e); + } + else { + RETVAL = isWORDCHAR_utf8(p); + } OUTPUT: RETVAL bool -test_isALNUM_LC_utf8(unsigned char * p) +test_isALNUM_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isALNUM_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isWORDCHAR_LC_utf8_safe(p, e); + } + else { + RETVAL = isWORDCHAR_LC_utf8(p); + } OUTPUT: RETVAL @@ -4030,6 +4964,13 @@ test_isDIGIT_uni(UV ord) RETVAL bool +test_isDIGIT_uvchr(UV ord) + CODE: + RETVAL = isDIGIT_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isDIGIT_LC_uvchr(UV ord) CODE: RETVAL = isDIGIT_LC_uvchr(ord); @@ -4037,16 +4978,39 @@ test_isDIGIT_LC_uvchr(UV ord) RETVAL bool -test_isDIGIT_utf8(unsigned char * p) +test_isDIGIT_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; + CODE: + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isDIGIT_utf8_safe(p, e); + } + else { + RETVAL = isDIGIT_utf8(p); + } + OUTPUT: + RETVAL + +bool +test_isDIGIT_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isDIGIT_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isDIGIT_LC_utf8_safe(p, e); + } + else { + RETVAL = isDIGIT_LC_utf8(p); + } OUTPUT: RETVAL bool -test_isDIGIT_LC_utf8(unsigned char * p) +test_isDIGIT(UV ord) CODE: - RETVAL = isDIGIT_LC_utf8( p); + RETVAL = isDIGIT(ord); OUTPUT: RETVAL @@ -4072,111 +5036,199 @@ test_isDIGIT_LC(UV ord) RETVAL bool -test_isIDFIRST_uni(UV ord) +test_isOCTAL(UV ord) CODE: - RETVAL = isIDFIRST_uni(ord); + RETVAL = isOCTAL(ord); OUTPUT: RETVAL bool -test_isIDFIRST_LC_uvchr(UV ord) +test_isOCTAL_A(UV ord) CODE: - RETVAL = isIDFIRST_LC_uvchr(ord); + RETVAL = isOCTAL_A(ord); OUTPUT: RETVAL bool -test_isIDFIRST_A(UV ord) +test_isOCTAL_L1(UV ord) CODE: - RETVAL = isIDFIRST_A(ord); + RETVAL = isOCTAL_L1(ord); OUTPUT: RETVAL bool -test_isIDFIRST_L1(UV ord) +test_isIDFIRST_uni(UV ord) CODE: - RETVAL = isIDFIRST_L1(ord); + RETVAL = isIDFIRST_uni(ord); OUTPUT: RETVAL bool -test_isIDFIRST_LC(UV ord) +test_isIDFIRST_uvchr(UV ord) CODE: - RETVAL = isIDFIRST_LC(ord); + RETVAL = isIDFIRST_uvchr(ord); OUTPUT: RETVAL bool -test_isIDFIRST_utf8(unsigned char * p) +test_isIDFIRST_LC_uvchr(UV ord) CODE: - RETVAL = isIDFIRST_utf8( p); + RETVAL = isIDFIRST_LC_uvchr(ord); OUTPUT: RETVAL bool -test_isIDFIRST_LC_utf8(unsigned char * p) +test_isIDFIRST(UV ord) CODE: - RETVAL = isIDFIRST_LC_utf8( p); + RETVAL = isIDFIRST(ord); OUTPUT: RETVAL bool -test_isIDCONT_uni(UV ord) +test_isIDFIRST_A(UV ord) CODE: - RETVAL = isIDCONT_uni(ord); + RETVAL = isIDFIRST_A(ord); OUTPUT: RETVAL bool -test_isIDCONT_LC_uvchr(UV ord) +test_isIDFIRST_L1(UV ord) CODE: - RETVAL = isIDCONT_LC_uvchr(ord); + RETVAL = isIDFIRST_L1(ord); OUTPUT: RETVAL bool -test_isIDCONT_A(UV ord) +test_isIDFIRST_LC(UV ord) CODE: - RETVAL = isIDCONT_A(ord); + RETVAL = isIDFIRST_LC(ord); OUTPUT: RETVAL bool -test_isIDCONT_L1(UV ord) +test_isIDFIRST_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isIDCONT_L1(ord); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isIDFIRST_utf8_safe(p, e); + } + else { + RETVAL = isIDFIRST_utf8(p); + } OUTPUT: RETVAL bool -test_isIDCONT_LC(UV ord) +test_isIDFIRST_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isIDCONT_LC(ord); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isIDFIRST_LC_utf8_safe(p, e); + } + else { + RETVAL = isIDFIRST_LC_utf8(p); + } OUTPUT: RETVAL bool -test_isIDCONT_utf8(unsigned char * p) +test_isIDCONT_uni(UV ord) CODE: - RETVAL = isIDCONT_utf8( p); + RETVAL = isIDCONT_uni(ord); OUTPUT: RETVAL bool -test_isIDCONT_LC_utf8(unsigned char * p) +test_isIDCONT_uvchr(UV ord) CODE: - RETVAL = isIDCONT_LC_utf8( p); + RETVAL = isIDCONT_uvchr(ord); OUTPUT: RETVAL bool -test_isSPACE_uni(UV ord) +test_isIDCONT_LC_uvchr(UV ord) + CODE: + RETVAL = isIDCONT_LC_uvchr(ord); + OUTPUT: + RETVAL + +bool +test_isIDCONT(UV ord) + CODE: + RETVAL = isIDCONT(ord); + OUTPUT: + RETVAL + +bool +test_isIDCONT_A(UV ord) + CODE: + RETVAL = isIDCONT_A(ord); + OUTPUT: + RETVAL + +bool +test_isIDCONT_L1(UV ord) + CODE: + RETVAL = isIDCONT_L1(ord); + OUTPUT: + RETVAL + +bool +test_isIDCONT_LC(UV ord) + CODE: + RETVAL = isIDCONT_LC(ord); + OUTPUT: + RETVAL + +bool +test_isIDCONT_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; + CODE: + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isIDCONT_utf8_safe(p, e); + } + else { + RETVAL = isIDCONT_utf8(p); + } + OUTPUT: + RETVAL + +bool +test_isIDCONT_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; + CODE: + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isIDCONT_LC_utf8_safe(p, e); + } + else { + RETVAL = isIDCONT_LC_utf8(p); + } + OUTPUT: + RETVAL + +bool +test_isSPACE_uni(UV ord) CODE: RETVAL = isSPACE_uni(ord); OUTPUT: RETVAL bool +test_isSPACE_uvchr(UV ord) + CODE: + RETVAL = isSPACE_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isSPACE_LC_uvchr(UV ord) CODE: RETVAL = isSPACE_LC_uvchr(ord); @@ -4184,6 +5236,13 @@ test_isSPACE_LC_uvchr(UV ord) RETVAL bool +test_isSPACE(UV ord) + CODE: + RETVAL = isSPACE(ord); + OUTPUT: + RETVAL + +bool test_isSPACE_A(UV ord) CODE: RETVAL = isSPACE_A(ord); @@ -4205,16 +5264,32 @@ test_isSPACE_LC(UV ord) RETVAL bool -test_isSPACE_utf8(unsigned char * p) +test_isSPACE_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isSPACE_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isSPACE_utf8_safe(p, e); + } + else { + RETVAL = isSPACE_utf8(p); + } OUTPUT: RETVAL bool -test_isSPACE_LC_utf8(unsigned char * p) +test_isSPACE_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isSPACE_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isSPACE_LC_utf8_safe(p, e); + } + else { + RETVAL = isSPACE_LC_utf8(p); + } OUTPUT: RETVAL @@ -4226,6 +5301,13 @@ test_isASCII_uni(UV ord) RETVAL bool +test_isASCII_uvchr(UV ord) + CODE: + RETVAL = isASCII_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isASCII_LC_uvchr(UV ord) CODE: RETVAL = isASCII_LC_uvchr(ord); @@ -4233,6 +5315,13 @@ test_isASCII_LC_uvchr(UV ord) RETVAL bool +test_isASCII(UV ord) + CODE: + RETVAL = isASCII(ord); + OUTPUT: + RETVAL + +bool test_isASCII_A(UV ord) CODE: RETVAL = isASCII_A(ord); @@ -4254,16 +5343,38 @@ test_isASCII_LC(UV ord) RETVAL bool -test_isASCII_utf8(unsigned char * p) +test_isASCII_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isASCII_utf8( p); +#ifndef DEBUGGING + PERL_UNUSED_VAR(e); +#endif + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isASCII_utf8_safe(p, e); + } + else { + RETVAL = isASCII_utf8(p); + } OUTPUT: RETVAL bool -test_isASCII_LC_utf8(unsigned char * p) +test_isASCII_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isASCII_LC_utf8( p); +#ifndef DEBUGGING + PERL_UNUSED_VAR(e); +#endif + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isASCII_LC_utf8_safe(p, e); + } + else { + RETVAL = isASCII_LC_utf8(p); + } OUTPUT: RETVAL @@ -4275,6 +5386,13 @@ test_isCNTRL_uni(UV ord) RETVAL bool +test_isCNTRL_uvchr(UV ord) + CODE: + RETVAL = isCNTRL_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isCNTRL_LC_uvchr(UV ord) CODE: RETVAL = isCNTRL_LC_uvchr(ord); @@ -4282,6 +5400,13 @@ test_isCNTRL_LC_uvchr(UV ord) RETVAL bool +test_isCNTRL(UV ord) + CODE: + RETVAL = isCNTRL(ord); + OUTPUT: + RETVAL + +bool test_isCNTRL_A(UV ord) CODE: RETVAL = isCNTRL_A(ord); @@ -4303,16 +5428,32 @@ test_isCNTRL_LC(UV ord) RETVAL bool -test_isCNTRL_utf8(unsigned char * p) +test_isCNTRL_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isCNTRL_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isCNTRL_utf8_safe(p, e); + } + else { + RETVAL = isCNTRL_utf8(p); + } OUTPUT: RETVAL bool -test_isCNTRL_LC_utf8(unsigned char * p) +test_isCNTRL_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isCNTRL_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isCNTRL_LC_utf8_safe(p, e); + } + else { + RETVAL = isCNTRL_LC_utf8(p); + } OUTPUT: RETVAL @@ -4324,6 +5465,13 @@ test_isPRINT_uni(UV ord) RETVAL bool +test_isPRINT_uvchr(UV ord) + CODE: + RETVAL = isPRINT_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isPRINT_LC_uvchr(UV ord) CODE: RETVAL = isPRINT_LC_uvchr(ord); @@ -4331,6 +5479,13 @@ test_isPRINT_LC_uvchr(UV ord) RETVAL bool +test_isPRINT(UV ord) + CODE: + RETVAL = isPRINT(ord); + OUTPUT: + RETVAL + +bool test_isPRINT_A(UV ord) CODE: RETVAL = isPRINT_A(ord); @@ -4352,16 +5507,32 @@ test_isPRINT_LC(UV ord) RETVAL bool -test_isPRINT_utf8(unsigned char * p) +test_isPRINT_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isPRINT_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isPRINT_utf8_safe(p, e); + } + else { + RETVAL = isPRINT_utf8(p); + } OUTPUT: RETVAL bool -test_isPRINT_LC_utf8(unsigned char * p) +test_isPRINT_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isPRINT_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isPRINT_LC_utf8_safe(p, e); + } + else { + RETVAL = isPRINT_LC_utf8(p); + } OUTPUT: RETVAL @@ -4373,6 +5544,13 @@ test_isGRAPH_uni(UV ord) RETVAL bool +test_isGRAPH_uvchr(UV ord) + CODE: + RETVAL = isGRAPH_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isGRAPH_LC_uvchr(UV ord) CODE: RETVAL = isGRAPH_LC_uvchr(ord); @@ -4380,6 +5558,13 @@ test_isGRAPH_LC_uvchr(UV ord) RETVAL bool +test_isGRAPH(UV ord) + CODE: + RETVAL = isGRAPH(ord); + OUTPUT: + RETVAL + +bool test_isGRAPH_A(UV ord) CODE: RETVAL = isGRAPH_A(ord); @@ -4401,16 +5586,32 @@ test_isGRAPH_LC(UV ord) RETVAL bool -test_isGRAPH_utf8(unsigned char * p) +test_isGRAPH_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isGRAPH_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isGRAPH_utf8_safe(p, e); + } + else { + RETVAL = isGRAPH_utf8(p); + } OUTPUT: RETVAL bool -test_isGRAPH_LC_utf8(unsigned char * p) +test_isGRAPH_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isGRAPH_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isGRAPH_LC_utf8_safe(p, e); + } + else { + RETVAL = isGRAPH_LC_utf8(p); + } OUTPUT: RETVAL @@ -4422,6 +5623,13 @@ test_isPUNCT_uni(UV ord) RETVAL bool +test_isPUNCT_uvchr(UV ord) + CODE: + RETVAL = isPUNCT_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isPUNCT_LC_uvchr(UV ord) CODE: RETVAL = isPUNCT_LC_uvchr(ord); @@ -4429,6 +5637,13 @@ test_isPUNCT_LC_uvchr(UV ord) RETVAL bool +test_isPUNCT(UV ord) + CODE: + RETVAL = isPUNCT(ord); + OUTPUT: + RETVAL + +bool test_isPUNCT_A(UV ord) CODE: RETVAL = isPUNCT_A(ord); @@ -4450,16 +5665,32 @@ test_isPUNCT_LC(UV ord) RETVAL bool -test_isPUNCT_utf8(unsigned char * p) +test_isPUNCT_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isPUNCT_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isPUNCT_utf8_safe(p, e); + } + else { + RETVAL = isPUNCT_utf8(p); + } OUTPUT: RETVAL bool -test_isPUNCT_LC_utf8(unsigned char * p) +test_isPUNCT_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isPUNCT_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isPUNCT_LC_utf8_safe(p, e); + } + else { + RETVAL = isPUNCT_LC_utf8(p); + } OUTPUT: RETVAL @@ -4471,6 +5702,13 @@ test_isXDIGIT_uni(UV ord) RETVAL bool +test_isXDIGIT_uvchr(UV ord) + CODE: + RETVAL = isXDIGIT_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isXDIGIT_LC_uvchr(UV ord) CODE: RETVAL = isXDIGIT_LC_uvchr(ord); @@ -4478,6 +5716,13 @@ test_isXDIGIT_LC_uvchr(UV ord) RETVAL bool +test_isXDIGIT(UV ord) + CODE: + RETVAL = isXDIGIT(ord); + OUTPUT: + RETVAL + +bool test_isXDIGIT_A(UV ord) CODE: RETVAL = isXDIGIT_A(ord); @@ -4499,16 +5744,32 @@ test_isXDIGIT_LC(UV ord) RETVAL bool -test_isXDIGIT_utf8(unsigned char * p) +test_isXDIGIT_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isXDIGIT_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isXDIGIT_utf8_safe(p, e); + } + else { + RETVAL = isXDIGIT_utf8(p); + } OUTPUT: RETVAL bool -test_isXDIGIT_LC_utf8(unsigned char * p) +test_isXDIGIT_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isXDIGIT_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isXDIGIT_LC_utf8_safe(p, e); + } + else { + RETVAL = isXDIGIT_LC_utf8(p); + } OUTPUT: RETVAL @@ -4520,6 +5781,13 @@ test_isPSXSPC_uni(UV ord) RETVAL bool +test_isPSXSPC_uvchr(UV ord) + CODE: + RETVAL = isPSXSPC_uvchr(ord); + OUTPUT: + RETVAL + +bool test_isPSXSPC_LC_uvchr(UV ord) CODE: RETVAL = isPSXSPC_LC_uvchr(ord); @@ -4527,6 +5795,13 @@ test_isPSXSPC_LC_uvchr(UV ord) RETVAL bool +test_isPSXSPC(UV ord) + CODE: + RETVAL = isPSXSPC(ord); + OUTPUT: + RETVAL + +bool test_isPSXSPC_A(UV ord) CODE: RETVAL = isPSXSPC_A(ord); @@ -4548,16 +5823,32 @@ test_isPSXSPC_LC(UV ord) RETVAL bool -test_isPSXSPC_utf8(unsigned char * p) +test_isPSXSPC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isPSXSPC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isPSXSPC_utf8_safe(p, e); + } + else { + RETVAL = isPSXSPC_utf8(p); + } OUTPUT: RETVAL bool -test_isPSXSPC_LC_utf8(unsigned char * p) +test_isPSXSPC_LC_utf8(unsigned char * p, int type) + PREINIT: + const unsigned char * e; CODE: - RETVAL = isPSXSPC_LC_utf8( p); + if (type >= 0) { + e = p + UTF8SKIP(p) - type; + RETVAL = isPSXSPC_LC_utf8_safe(p, e); + } + else { + RETVAL = isPSXSPC_LC_utf8(p); + } OUTPUT: RETVAL @@ -4569,91 +5860,434 @@ test_isQUOTEMETA(UV ord) RETVAL UV -test_toLOWER(UV ord) +test_OFFUNISKIP(UV ord) CODE: - RETVAL = toLOWER(ord); + RETVAL = OFFUNISKIP(ord); OUTPUT: RETVAL -UV -test_toLOWER_L1(UV ord) +bool +test_OFFUNI_IS_INVARIANT(UV ord) CODE: - RETVAL = toLOWER_L1(ord); + RETVAL = OFFUNI_IS_INVARIANT(ord); OUTPUT: RETVAL -UV -test_toLOWER_LC(UV ord) +bool +test_UVCHR_IS_INVARIANT(UV ord) CODE: - RETVAL = toLOWER_LC(ord); + RETVAL = UVCHR_IS_INVARIANT(ord); OUTPUT: RETVAL -AV * -test_toLOWER_uni(UV ord) - PREINIT: - U8 s[UTF8_MAXBYTES_CASE + 1]; - STRLEN len; - AV *av; - SV *utf8; +bool +test_UTF8_IS_INVARIANT(char ch) 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; + RETVAL = UTF8_IS_INVARIANT(ch); OUTPUT: RETVAL -AV * -test_toLOWER_utf8(SV * p) - PREINIT: - U8 *input; - U8 s[UTF8_MAXBYTES_CASE + 1]; - STRLEN len; - AV *av; - SV *utf8; +UV +test_UVCHR_SKIP(UV ord) 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; + RETVAL = UVCHR_SKIP(ord); OUTPUT: RETVAL UV -test_toFOLD(UV ord) +test_UTF8_SKIP(char * ch) CODE: - RETVAL = toFOLD(ord); + RETVAL = UTF8_SKIP(ch); OUTPUT: RETVAL -UV -test_toFOLD_LC(UV ord) +bool +test_UTF8_IS_START(char ch) CODE: - RETVAL = toFOLD_LC(ord); + RETVAL = UTF8_IS_START(ch); OUTPUT: RETVAL -AV * -test_toFOLD_uni(UV ord) - PREINIT: - U8 s[UTF8_MAXBYTES_CASE + 1]; - STRLEN len; - AV *av; - SV *utf8; +bool +test_UTF8_IS_CONTINUATION(char ch) CODE: - av = newAV(); + 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); + 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_uvchr(UV ord) + PREINIT: + U8 s[UTF8_MAXBYTES_CASE + 1]; + STRLEN len; + AV *av; + SV *utf8; + CODE: + av = newAV(); + av_push(av, newSVuv(toLOWER_uvchr(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, int type) + PREINIT: + U8 *input; + U8 s[UTF8_MAXBYTES_CASE + 1]; + STRLEN len; + AV *av; + SV *utf8; + const unsigned char * e; + UV resultant_cp = UV_MAX; /* Initialized because of dumb compilers */ + CODE: + input = (U8 *) SvPV(p, len); + av = newAV(); + if (type >= 0) { + e = input + UTF8SKIP(input) - type; + resultant_cp = toLOWER_utf8_safe(input, e, s, &len); + } + else if (type == -1) { + resultant_cp = toLOWER_utf8(input, s, &len); + } +#ifndef NO_MATHOMS + else { + resultant_cp = Perl_to_utf8_lower(aTHX_ input, s, &len); + } +#endif + av_push(av, newSVuv(resultant_cp)); + + 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); @@ -4666,17 +6300,51 @@ test_toFOLD_uni(UV ord) RETVAL AV * -test_toFOLD_utf8(SV * p) +test_toFOLD_uvchr(UV ord) + PREINIT: + U8 s[UTF8_MAXBYTES_CASE + 1]; + STRLEN len; + AV *av; + SV *utf8; + CODE: + av = newAV(); + av_push(av, newSVuv(toFOLD_uvchr(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, int type) PREINIT: U8 *input; U8 s[UTF8_MAXBYTES_CASE + 1]; STRLEN len; AV *av; SV *utf8; + const unsigned char * e; + UV resultant_cp = UV_MAX; CODE: input = (U8 *) SvPV(p, len); av = newAV(); - av_push(av, newSVuv(toFOLD_utf8(input, s, &len))); + if (type >= 0) { + e = input + UTF8SKIP(input) - type; + resultant_cp = toFOLD_utf8_safe(input, e, s, &len); + } + else if (type == -1) { + resultant_cp = toFOLD_utf8(input, s, &len); + } +#ifndef NO_MATHOMS + else { + resultant_cp = Perl_to_utf8_fold(aTHX_ input, s, &len); + } +#endif + av_push(av, newSVuv(resultant_cp)); utf8 = newSVpvn((char *) s, len); SvUTF8_on(utf8); @@ -4722,17 +6390,51 @@ test_toUPPER_uni(UV ord) RETVAL AV * -test_toUPPER_utf8(SV * p) +test_toUPPER_uvchr(UV ord) + PREINIT: + U8 s[UTF8_MAXBYTES_CASE + 1]; + STRLEN len; + AV *av; + SV *utf8; + CODE: + av = newAV(); + av_push(av, newSVuv(toUPPER_uvchr(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, int type) PREINIT: U8 *input; U8 s[UTF8_MAXBYTES_CASE + 1]; STRLEN len; AV *av; SV *utf8; + const unsigned char * e; + UV resultant_cp = UV_MAX; CODE: input = (U8 *) SvPV(p, len); av = newAV(); - av_push(av, newSVuv(toUPPER_utf8(input, s, &len))); + if (type >= 0) { + e = input + UTF8SKIP(input) - type; + resultant_cp = toUPPER_utf8_safe(input, e, s, &len); + } + else if (type == -1) { + resultant_cp = toUPPER_utf8(input, s, &len); + } +#ifndef NO_MATHOMS + else { + resultant_cp = Perl_to_utf8_upper(aTHX_ input, s, &len); + } +#endif + av_push(av, newSVuv(resultant_cp)); utf8 = newSVpvn((char *) s, len); SvUTF8_on(utf8); @@ -4771,17 +6473,51 @@ test_toTITLE_uni(UV ord) RETVAL AV * -test_toTITLE_utf8(SV * p) +test_toTITLE_uvchr(UV ord) + PREINIT: + U8 s[UTF8_MAXBYTES_CASE + 1]; + STRLEN len; + AV *av; + SV *utf8; + CODE: + av = newAV(); + av_push(av, newSVuv(toTITLE_uvchr(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, int type) PREINIT: U8 *input; U8 s[UTF8_MAXBYTES_CASE + 1]; STRLEN len; AV *av; SV *utf8; + const unsigned char * e; + UV resultant_cp = UV_MAX; CODE: input = (U8 *) SvPV(p, len); av = newAV(); - av_push(av, newSVuv(toTITLE_utf8(input, s, &len))); + if (type >= 0) { + e = input + UTF8SKIP(input) - type; + resultant_cp = toTITLE_utf8_safe(input, e, s, &len); + } + else if (type == -1) { + resultant_cp = toTITLE_utf8(input, s, &len); + } +#ifndef NO_MATHOMS + else { + resultant_cp = Perl_to_utf8_title(aTHX_ input, s, &len); + } +#endif + av_push(av, newSVuv(resultant_cp)); utf8 = newSVpvn((char *) s, len); SvUTF8_on(utf8); @@ -4791,3 +6527,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 + +