#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
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) {
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;
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 <s> 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]; <retlen> 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
+
MODULE = XS::APItest:Overload PACKAGE = XS::APItest::Overload
void
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( (1<<31) + 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
test_force_keys(HV *hv)
PREINIT:
HE *he;
- STRLEN count = 0;
+ SSize_t count = 0;
PPCODE:
hv_iterinit(hv);
he = hv_iternext(hv);
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:
}
XPUSHs( gv ? (SV*)gv : &PL_sv_undef);
+SV *
+gv_const_sv(SV *name)
+ PREINIT:
+ GV *gv;
+ CODE:
+ if (SvPOK(name)) {
+ HV *stash = gv_stashpv("main",0);
+ HE *he = hv_fetch_ent(stash, name, 0, 0);
+ gv = (GV *)HeVAL(he);
+ }
+ else {
+ gv = (GV *)name;
+ }
+ RETVAL = gv_const_sv(gv);
+ if (!RETVAL)
+ XSRETURN_EMPTY;
+ RETVAL = newSVsv(RETVAL);
+ OUTPUT:
+ RETVAL
+
void
whichsig_type(namesv, type)
SV* namesv
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)
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;
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);
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;
+
+ PERL_UNUSED_VAR(newsp);
+
+ 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
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);
CvROOT(PL_compcv) = (OP *)1;
o = newFOROP(0, 0, newOP(OP_PUSHMARK, 0), 0, 0);
#ifdef PERL_OP_PARENT
- if (cLOOPx(cUNOPo->op_first)->op_last->op_sibling
+ if (cLOOPx(cUNOPo->op_first)->op_last->op_sibparent
!= cUNOPo->op_first)
{
Perl_warn(aTHX_ "Op parent pointer is stale");
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);
+
MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
int
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
+
+UV
test_toLOWER(UV ord)
CODE:
RETVAL = toLOWER(ord);
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
+
+
https://perl5.git.perl.org / perl5.git / blobdiff