__UNDEFINED__ END_EXTERN_C EXTERN_C INT2PTR MUTABLE_PTR NVTYPE PERL_GCC_BRACE_GROUPS_FORBIDDEN PERLIO_FUNCS_CAST PERLIO_FUNCS_DECL PERL_UNUSED_ARG PERL_UNUSED_CONTEXT PERL_UNUSED_DECL PERL_UNUSED_RESULT PERL_UNUSED_VAR PERL_USE_GCC_BRACE_GROUPS PTR2ul PTRV START_EXTERN_C STMT_END STMT_START SvRX UTF8_MAXBYTES WIDEST_UTYPE XSRETURN

__UNDEFINED__ cBOOL(cbool) ((cbool) ? (bool)1 : (bool)0) __UNDEFINED__ OpHAS_SIBLING(o) (cBOOL((o)->op_sibling)) __UNDEFINED__ OpSIBLING(o) (0 + (o)->op_sibling) __UNDEFINED__ OpMORESIB_set(o, sib) ((o)->op_sibling = (sib)) __UNDEFINED__ OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL) __UNDEFINED__ OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib)) __UNDEFINED__ HEf_SVKEY -2

#if defined(DEBUGGING) && !defined(__COVERITY__) __UNDEFINED__ __ASSERT_(statement) assert(statement), #else __UNDEFINED__ __ASSERT_(statement) #endif

#ifndef SvRX #if { NEED SvRX }

void * SvRX(pTHX_ SV *rv) { if (SvROK(rv)) { SV *sv = SvRV(rv); if (SvMAGICAL(sv)) { MAGIC *mg = mg_find(sv, PERL_MAGIC_qr); if (mg && mg->mg_obj) { return mg->mg_obj; } } } return 0; } #endif #endif

__UNDEFINED__ SvRXOK(sv) (!!SvRX(sv))

#ifndef PERL_UNUSED_DECL # ifdef HASATTRIBUTE # if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER) # define PERL_UNUSED_DECL # else # define PERL_UNUSED_DECL __attribute__((unused)) # endif # else # define PERL_UNUSED_DECL # endif #endif

#ifndef PERL_UNUSED_ARG # if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */ # include <note.h> # define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x)) # else # define PERL_UNUSED_ARG(x) ((void)x) # endif #endif

#ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif

#ifndef PERL_UNUSED_CONTEXT # ifdef USE_ITHREADS # define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl) # else # define PERL_UNUSED_CONTEXT # endif #endif

#ifndef PERL_UNUSED_RESULT # if defined(__GNUC__) && defined(HASATTRIBUTE_WARN_UNUSED_RESULT) # define PERL_UNUSED_RESULT(v) STMT_START { __typeof__(v) z = (v); (void)sizeof(z); } STMT_END # else # define PERL_UNUSED_RESULT(v) ((void)(v)) # endif #endif

__UNDEFINED__ NOOP /*EMPTY*/(void)0 __UNDEFINED__ dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL

#ifndef NVTYPE # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) # define NVTYPE long double # else # define NVTYPE double # endif typedef NVTYPE NV; #endif

#ifndef INT2PTR # if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE) # define PTRV UV # define INT2PTR(any,d) (any)(d) # else # if PTRSIZE == LONGSIZE # define PTRV unsigned long # else # define PTRV unsigned # endif # define INT2PTR(any,d) (any)(PTRV)(d) # endif #endif

#ifndef PTR2ul # if PTRSIZE == LONGSIZE # define PTR2ul(p) (unsigned long)(p) # else # define PTR2ul(p) INT2PTR(unsigned long,p) # endif #endif

__UNDEFINED__ PTR2nat(p) (PTRV)(p) __UNDEFINED__ NUM2PTR(any,d) (any)PTR2nat(d) __UNDEFINED__ PTR2IV(p) INT2PTR(IV,p) __UNDEFINED__ PTR2UV(p) INT2PTR(UV,p) __UNDEFINED__ PTR2NV(p) NUM2PTR(NV,p)

#undef START_EXTERN_C #undef END_EXTERN_C #undef EXTERN_C #ifdef __cplusplus # define START_EXTERN_C extern "C" { # define END_EXTERN_C } # define EXTERN_C extern "C" #else # define START_EXTERN_C # define END_EXTERN_C # define EXTERN_C extern #endif

#if defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif

#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS # endif #endif

#undef STMT_START #undef STMT_END #ifdef PERL_USE_GCC_BRACE_GROUPS # define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */ # define STMT_END ) #else # if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__) # define STMT_START if (1) # define STMT_END else (void)0 # else # define STMT_START do # define STMT_END while (0) # endif #endif

__UNDEFINED__ boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)

/* DEFSV appears first in 5.004_56 */ __UNDEFINED__ DEFSV GvSV(PL_defgv) __UNDEFINED__ SAVE_DEFSV SAVESPTR(GvSV(PL_defgv)) __UNDEFINED__ DEFSV_set(sv) (DEFSV = (sv))

/* Older perls (<=5.003) lack AvFILLp */ __UNDEFINED__ AvFILLp AvFILL

__UNDEFINED__ av_tindex AvFILL __UNDEFINED__ av_top_index AvFILL

__UNDEFINED__ ERRSV get_sv("@",FALSE)

/* Hint: gv_stashpvn * This function's backport doesn't support the length parameter, but * rather ignores it. Portability can only be ensured if the length * parameter is used for speed reasons, but the length can always be * correctly computed from the string argument. */

__UNDEFINED__ gv_stashpvn(str,len,create) gv_stashpv(str,create)

/* Replace: 1 */ __UNDEFINED__ get_cv perl_get_cv __UNDEFINED__ get_sv perl_get_sv __UNDEFINED__ get_av perl_get_av __UNDEFINED__ get_hv perl_get_hv /* Replace: 0 */

__UNDEFINED__ dUNDERBAR dNOOP __UNDEFINED__ UNDERBAR DEFSV

__UNDEFINED__ dAX I32 ax = MARK - PL_stack_base + 1 __UNDEFINED__ dITEMS I32 items = SP - MARK

__UNDEFINED__ dXSTARG SV * targ = sv_newmortal()

__UNDEFINED__ dAXMARK I32 ax = POPMARK; \ register SV ** const mark = PL_stack_base + ax++

__UNDEFINED__ XSprePUSH (sp = PL_stack_base + ax - 1)

#if { VERSION < 5.005 } # undef XSRETURN # define XSRETURN(off) \ STMT_START { \ PL_stack_sp = PL_stack_base + ax + ((off) - 1); \ return; \ } STMT_END #endif

__UNDEFINED__ XSPROTO(name) void name(pTHX_ CV* cv) __UNDEFINED__ SVfARG(p) ((void*)(p))

__UNDEFINED__ PERL_ABS(x) ((x) < 0 ? -(x) : (x))

__UNDEFINED__ dVAR dNOOP

__UNDEFINED__ SVf "_"

__UNDEFINED__ UTF8_MAXBYTES UTF8_MAXLEN

__UNDEFINED__ CPERLscope(x) x

__UNDEFINED__ PERL_HASH(hash,str,len) \ STMT_START { \ const char *s_PeRlHaSh = str; \ I32 i_PeRlHaSh = len; \ U32 hash_PeRlHaSh = 0; \ while (i_PeRlHaSh--) \ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \ (hash) = hash_PeRlHaSh; \ } STMT_END

#ifndef PERLIO_FUNCS_DECL # ifdef PERLIO_FUNCS_CONST # define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs) # else # define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs # define PERLIO_FUNCS_CAST(funcs) (funcs) # endif #endif

/* provide these typedefs for older perls */ #if { VERSION < 5.9.3 }

# ifdef ARGSproto typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto); # else typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX); # endif

typedef OP* (CPERLscope(*Perl_check_t)) (pTHX_ OP*);

#endif

#ifndef WIDEST_UTYPE # ifdef QUADKIND # ifdef U64TYPE # define WIDEST_UTYPE U64TYPE # else # define WIDEST_UTYPE Quad_t # endif # else # define WIDEST_UTYPE U32 # endif #endif

#ifdef EBCDIC

/* This is the first version where these macros are fully correct. Relying on * the C library functions, as earlier releases did, causes problems with * locales */ # if { VERSION < 5.22.0 } # undef isALNUM # undef isALNUM_A # undef isALNUMC # undef isALNUMC_A # undef isALPHA # undef isALPHA_A # undef isALPHANUMERIC # undef isALPHANUMERIC_A # undef isASCII # undef isASCII_A # undef isBLANK # undef isBLANK_A # undef isCNTRL # undef isCNTRL_A # undef isDIGIT # undef isDIGIT_A # undef isGRAPH # undef isGRAPH_A # undef isIDCONT # undef isIDCONT_A # undef isIDFIRST # undef isIDFIRST_A # undef isLOWER # undef isLOWER_A # undef isOCTAL # undef isOCTAL_A # undef isPRINT # undef isPRINT_A # undef isPSXSPC # undef isPSXSPC_A # undef isPUNCT # undef isPUNCT_A # undef isSPACE # undef isSPACE_A # undef isUPPER # undef isUPPER_A # undef isWORDCHAR # undef isWORDCHAR_A # undef isXDIGIT # undef isXDIGIT_A # endif

__UNDEFINED__ isASCII(c) (isCNTRL(c) || isPRINT(c))

       /* The below is accurate for all EBCDIC code pages supported by
        * all the versions of Perl overridden by this */
__UNDEFINED__ isCNTRL(c)    (    (c) == '\0' || (c) == '\a' || (c) == '\b'      \
                            ||  (c) == '\f' || (c) == '\n' || (c) == '\r'      \
                            ||  (c) == '\t' || (c) == '\v'                     \
                            || ((c) <= 3 && (c) >= 1) /* SOH, STX, ETX */      \
                            ||  (c) == 7    /* U+7F DEL */                     \
                            || ((c) <= 0x13 && (c) >= 0x0E) /* SO, SI */       \
                                                     /* DLE, DC[1-3] */        \
                            ||  (c) == 0x18 /* U+18 CAN */                     \
                            ||  (c) == 0x19 /* U+19 EOM */                     \
                            || ((c) <= 0x1F && (c) >= 0x1C) /* [FGRU]S */      \
                            ||  (c) == 0x26 /* U+17 ETB */                     \
                            ||  (c) == 0x27 /* U+1B ESC */                     \
                            ||  (c) == 0x2D /* U+05 ENQ */                     \
                            ||  (c) == 0x2E /* U+06 ACK */                     \
                            ||  (c) == 0x32 /* U+16 SYN */                     \
                            ||  (c) == 0x37 /* U+04 EOT */                     \
                            ||  (c) == 0x3C /* U+14 DC4 */                     \
                            ||  (c) == 0x3D /* U+15 NAK */                     \
                            ||  (c) == 0x3F /* U+1A SUB */                     \
                           )
/* The ordering of the tests in this and isUPPER are to exclude most characters
* early */
__UNDEFINED__ isLOWER(c)    (        (c) >= 'a' && (c) <= 'z'                   \
                            &&  (   (c) <= 'i'                                 \
                                || ((c) >= 'j' && (c) <= 'r')                  \
                                ||  (c) >= 's'))
__UNDEFINED__ isUPPER(c)    (        (c) >= 'A' && (c) <= 'Z'                   \
                            && (    (c) <= 'I'                                 \
                                || ((c) >= 'J' && (c) <= 'R')                  \
                                ||  (c) >= 'S'))

#else /* Above is EBCDIC; below is ASCII */

# if { VERSION < 5.4.0 } /* The implementation of these in older perl versions can give wrong results if * the C program locale is set to other than the C locale */ # undef isALNUM # undef isALNUM_A # undef isALPHA # undef isALPHA_A # undef isDIGIT # undef isDIGIT_A # undef isIDFIRST # undef isIDFIRST_A # undef isLOWER # undef isLOWER_A # undef isUPPER # undef isUPPER_A # endif

# if { VERSION < 5.8.0 } /* Hint: isCNTRL * Earlier perls omitted DEL */ # undef isCNTRL # endif

# if { VERSION < 5.10.0 } /* Hint: isPRINT * The implementation in older perl versions includes all of the * isSPACE() characters, which is wrong. The version provided by * Devel::PPPort always overrides a present buggy version. */ # undef isPRINT # undef isPRINT_A # endif

# if { VERSION < 5.14.0 } /* Hint: isASCII * The implementation in older perl versions always returned true if the * parameter was a signed char */ # undef isASCII # undef isASCII_A # endif

# if { VERSION < 5.20.0 } /* Hint: isSPACE * The implementation in older perl versions didn't include \v */ # undef isSPACE # undef isSPACE_A # endif

__UNDEFINED__ isASCII(c) ((WIDEST_UTYPE) (c) <= 127) __UNDEFINED__ isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) __UNDEFINED__ isLOWER(c) ((c) >= 'a' && (c) <= 'z') __UNDEFINED__ isUPPER(c) ((c) <= 'Z' && (c) >= 'A') #endif /* Below are definitions common to EBCDIC and ASCII */

__UNDEFINED__ isALNUM(c) isWORDCHAR(c) __UNDEFINED__ isALNUMC(c) isALPHANUMERIC(c) __UNDEFINED__ isALPHA(c) (isUPPER(c) || isLOWER(c)) __UNDEFINED__ isALPHANUMERIC(c) (isALPHA(c) || isDIGIT(c)) __UNDEFINED__ isBLANK(c) ((c) == ' ' || (c) == '\t') __UNDEFINED__ isDIGIT(c) ((c) <= '9' && (c) >= '0') __UNDEFINED__ isGRAPH(c) (isWORDCHAR(c) || isPUNCT(c)) __UNDEFINED__ isIDCONT(c) isWORDCHAR(c) __UNDEFINED__ isIDFIRST(c) (isALPHA(c) || (c) == '_') __UNDEFINED__ isOCTAL(c) (((WIDEST_UTYPE)((c)) & ~7) == '0') __UNDEFINED__ isPRINT(c) (isGRAPH(c) || (c) == ' ') __UNDEFINED__ isPSXSPC(c) isSPACE(c) __UNDEFINED__ isPUNCT(c) ( (c) == '-' || (c) == '!' || (c) == '"' \ || (c) == '#' || (c) == '$' || (c) == '%' \ || (c) == '&' || (c) == '\'' || (c) == '(' \ || (c) == ')' || (c) == '*' || (c) == '+' \ || (c) == ',' || (c) == '.' || (c) == '/' \ || (c) == ':' || (c) == ';' || (c) == '<' \ || (c) == '=' || (c) == '>' || (c) == '?' \ || (c) == '@' || (c) == '[' || (c) == '\\' \ || (c) == ']' || (c) == '^' || (c) == '_' \ || (c) == '`' || (c) == '{' || (c) == '|' \ || (c) == '}' || (c) == '~') __UNDEFINED__ isSPACE(c) ( isBLANK(c) || (c) == '\n' || (c) == '\r' \ || (c) == '\v' || (c) == '\f') __UNDEFINED__ isWORDCHAR(c) (isALPHANUMERIC(c) || (c) == '_') __UNDEFINED__ isXDIGIT(c) ( isDIGIT(c) \ || ((c) >= 'a' && (c) <= 'f') \ || ((c) >= 'A' && (c) <= 'F'))

__UNDEFINED__ isALNUM_A isALNUM __UNDEFINED__ isALNUMC_A isALNUMC __UNDEFINED__ isALPHA_A isALPHA __UNDEFINED__ isALPHANUMERIC_A isALPHANUMERIC __UNDEFINED__ isASCII_A isASCII __UNDEFINED__ isBLANK_A isBLANK __UNDEFINED__ isCNTRL_A isCNTRL __UNDEFINED__ isDIGIT_A isDIGIT __UNDEFINED__ isGRAPH_A isGRAPH __UNDEFINED__ isIDCONT_A isIDCONT __UNDEFINED__ isIDFIRST_A isIDFIRST __UNDEFINED__ isLOWER_A isLOWER __UNDEFINED__ isOCTAL_A isOCTAL __UNDEFINED__ isPRINT_A isPRINT __UNDEFINED__ isPSXSPC_A isPSXSPC __UNDEFINED__ isPUNCT_A isPUNCT __UNDEFINED__ isSPACE_A isSPACE __UNDEFINED__ isUPPER_A isUPPER __UNDEFINED__ isWORDCHAR_A isWORDCHAR __UNDEFINED__ isXDIGIT_A isXDIGIT

/* Until we figure out how to support this in older perls... */ #if { VERSION >= 5.8.0 }

__UNDEFINED__ HeUTF8(he) ((HeKLEN(he) == HEf_SVKEY) ? \ SvUTF8(HeKEY_sv(he)) : \ (U32)HeKUTF8(he))

#endif

__UNDEFINED__ C_ARRAY_LENGTH(a) (sizeof(a)/sizeof((a)[0])) __UNDEFINED__ C_ARRAY_END(a) ((a) + C_ARRAY_LENGTH(a))

__UNDEFINED__ LIKELY(x) (x) __UNDEFINED__ UNLIKELY(x) (x)

__UNDEFINED__ UNICODE_REPLACEMENT 0xFFFD

#ifndef MUTABLE_PTR #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define MUTABLE_PTR(p) ({ void *_p = (p); _p; }) #else # define MUTABLE_PTR(p) ((void *) (p)) #endif #endif

__UNDEFINED__ MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p))

typedef XSPROTO(XSPROTO_test_t); typedef XSPROTO_test_t *XSPROTO_test_t_ptr;

XS(XS_Devel__PPPort_dXSTARG); /* prototype */ XS(XS_Devel__PPPort_dXSTARG) { dXSARGS; dXSTARG; IV iv;

PERL_UNUSED_VAR(cv);
SP -= items;
iv = SvIV(ST(0)) + 1;
PUSHi(iv);
XSRETURN(1);
}

XS(XS_Devel__PPPort_dAXMARK); /* prototype */ XS(XS_Devel__PPPort_dAXMARK) { dSP; dAXMARK; dITEMS; IV iv;

PERL_UNUSED_VAR(cv);
SP -= items;
iv = SvIV(ST(0)) - 1;
mPUSHi(iv);
XSRETURN(1);
}

#define NEED_SvRX

{ XSPROTO_test_t_ptr p = &XS_Devel__PPPort_dXSTARG; newXS("Devel::PPPort::dXSTARG", *p, file); } newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);

int OpSIBLING_tests() PREINIT: OP *x; OP *kid; OP *middlekid; OP *lastkid; int count = 0; int failures = 0; int i; CODE: x = newOP(OP_PUSHMARK, 0);

		/* No siblings yet! */
		if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
			failures++; warn("Op should not have had a sib");
		}


		/* Add 2 siblings */
		kid = x;

		for (i = 0; i < 2; i++) {
			OP *newsib = newOP(OP_PUSHMARK, 0);
			OpMORESIB_set(kid, newsib);

			kid = OpSIBLING(kid);
			lastkid = kid;
		}
                middlekid = OpSIBLING(x);

		/* Should now have a sibling */
		if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
			failures++; warn("Op should have had a sib after moresib_set");
		}

		/* Count the siblings */
		for (kid = OpSIBLING(x); kid; kid = OpSIBLING(kid)) {
			count++;
		}

		if (count != 2) {
			failures++; warn("Kid had %d sibs, expected 2", count);
		}

		if (OpHAS_SIBLING(lastkid) || OpSIBLING(lastkid)) {
			failures++; warn("Last kid should not have a sib");
		}

		/* Really sets the parent, and says 'no more siblings' */
		OpLASTSIB_set(x, lastkid);

		if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
			failures++; warn("OpLASTSIB_set failed?");
		}

		/* Restore the kid */
		OpMORESIB_set(x, lastkid);

		/* Try to remove it again */
		OpLASTSIB_set(x, NULL);

		if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
			failures++; warn("OpLASTSIB_set with NULL failed?");
		}

		/* Try to restore with maybesib_set */
		OpMAYBESIB_set(x, lastkid, NULL);

		if (! OpHAS_SIBLING(x) || ! OpSIBLING(x) ) {
			failures++; warn("Op should have had a sib after maybesibset");
		}

                op_free(lastkid);
                op_free(middlekid);
                op_free(x);
		RETVAL = failures;
	OUTPUT:
		RETVAL

int SvRXOK(sv) SV *sv CODE: RETVAL = SvRXOK(sv); OUTPUT: RETVAL

int ptrtests() PREINIT: int var, *p = &var;

CODE:
        RETVAL = 0;
        RETVAL += PTR2nat(p) != 0       ?  1 : 0;
        RETVAL += PTR2ul(p) != 0UL      ?  2 : 0;
        RETVAL += PTR2UV(p) != (UV) 0   ?  4 : 0;
        RETVAL += PTR2IV(p) != (IV) 0   ?  8 : 0;
        RETVAL += PTR2NV(p) != (NV) 0   ? 16 : 0;
        RETVAL += p > NUM2PTR(int *, 0) ? 32 : 0;

OUTPUT:
        RETVAL

int gv_stashpvn(name, create) char *name I32 create CODE: RETVAL = gv_stashpvn(name, strlen(name), create) != NULL; OUTPUT: RETVAL

int get_sv(name, create) char *name I32 create CODE: RETVAL = get_sv(name, create) != NULL; OUTPUT: RETVAL

int get_av(name, create) char *name I32 create CODE: RETVAL = get_av(name, create) != NULL; OUTPUT: RETVAL

int get_hv(name, create) char *name I32 create CODE: RETVAL = get_hv(name, create) != NULL; OUTPUT: RETVAL

int get_cv(name, create) char *name I32 create CODE: RETVAL = get_cv(name, create) != NULL; OUTPUT: RETVAL

void xsreturn(two) int two PPCODE: mXPUSHp("test1", 5); if (two) mXPUSHp("test2", 5); if (two) XSRETURN(2); else XSRETURN(1);

SV* boolSV(value) int value CODE: RETVAL = newSVsv(boolSV(value)); OUTPUT: RETVAL

SV* DEFSV() CODE: RETVAL = newSVsv(DEFSV); OUTPUT: RETVAL

void DEFSV_modify() PPCODE: XPUSHs(sv_mortalcopy(DEFSV)); ENTER; SAVE_DEFSV; DEFSV_set(newSVpvs("DEFSV")); XPUSHs(sv_mortalcopy(DEFSV)); /* Yes, this leaks the above scalar; 5.005 with threads for some reason */ /* frees it upon LEAVE, thus mortalizing it causes "attempt to free..." */ /* sv_2mortal(DEFSV); */ LEAVE; XPUSHs(sv_mortalcopy(DEFSV)); XSRETURN(3);

int ERRSV() CODE: RETVAL = SvTRUE(ERRSV); OUTPUT: RETVAL

SV* UNDERBAR() CODE: { dUNDERBAR; RETVAL = newSVsv(UNDERBAR); } OUTPUT: RETVAL

void prepush() CODE: { dXSTARG; XSprePUSH; PUSHi(42); XSRETURN(1); }

int PERL_ABS(a) int a

void SVf(x) SV *x PPCODE: #if { VERSION >= 5.004 } x = sv_2mortal(newSVpvf("[%" SVf "]", SVfARG(x))); #endif XPUSHs(x); XSRETURN(1);

void Perl_ppaddr_t(string) char *string PREINIT: Perl_ppaddr_t lower; PPCODE: lower = PL_ppaddr[OP_LC]; mXPUSHs(newSVpv(string, 0)); PUTBACK; ENTER; (void)*(lower)(aTHXR); SPAGAIN; LEAVE; XSRETURN(1);

#if { VERSION >= 5.8.0 }

void check_HeUTF8(utf8_key) SV *utf8_key; PREINIT: HV *hash; HE *ent; STRLEN klen; char *key; PPCODE: hash = newHV();

key = SvPV(utf8_key, klen);
if (SvUTF8(utf8_key)) klen *= -1;
hv_store(hash, key, klen, newSVpvs("string"), 0);
hv_iterinit(hash);
ent = hv_iternext(hash);
assert(ent);
mXPUSHp((HeUTF8(ent) == 0 ? "norm" : "utf8"), 4);
hv_undef(hash);

#endif

void check_c_array() PREINIT: int x[] = { 10, 11, 12, 13 }; PPCODE: mXPUSHi(C_ARRAY_LENGTH(x)); /* 4 */ mXPUSHi(*(C_ARRAY_END(x)-1)); /* 13 */

bool test_isBLANK(UV ord) CODE: RETVAL = isBLANK(ord); OUTPUT: RETVAL

bool test_isBLANK_A(UV ord) CODE: RETVAL = isBLANK_A(ord); OUTPUT: RETVAL

bool test_isUPPER(UV ord) CODE: RETVAL = isUPPER(ord); OUTPUT: RETVAL

bool test_isUPPER_A(UV ord) CODE: RETVAL = isUPPER_A(ord); OUTPUT: RETVAL

bool test_isLOWER(UV ord) CODE: RETVAL = isLOWER(ord); OUTPUT: RETVAL

bool test_isLOWER_A(UV ord) CODE: RETVAL = isLOWER_A(ord); OUTPUT: RETVAL

bool test_isALPHA(UV ord) CODE: RETVAL = isALPHA(ord); OUTPUT: RETVAL

bool test_isALPHA_A(UV ord) CODE: RETVAL = isALPHA_A(ord); OUTPUT: RETVAL

bool test_isWORDCHAR(UV ord) CODE: RETVAL = isWORDCHAR(ord); OUTPUT: RETVAL

bool test_isWORDCHAR_A(UV ord) CODE: RETVAL = isWORDCHAR_A(ord); OUTPUT: RETVAL

bool test_isALPHANUMERIC(UV ord) CODE: RETVAL = isALPHANUMERIC(ord); OUTPUT: RETVAL

bool test_isALPHANUMERIC_A(UV ord) CODE: RETVAL = isALPHANUMERIC_A(ord); OUTPUT: RETVAL

bool test_isALNUM(UV ord) CODE: RETVAL = isALNUM(ord); OUTPUT: RETVAL

bool test_isALNUM_A(UV ord) CODE: RETVAL = isALNUM_A(ord); OUTPUT: RETVAL

bool test_isDIGIT(UV ord) CODE: RETVAL = isDIGIT(ord); OUTPUT: RETVAL

bool test_isDIGIT_A(UV ord) CODE: RETVAL = isDIGIT_A(ord); OUTPUT: RETVAL

bool test_isOCTAL(UV ord) CODE: RETVAL = isOCTAL(ord); OUTPUT: RETVAL

bool test_isOCTAL_A(UV ord) CODE: RETVAL = isOCTAL_A(ord); OUTPUT: RETVAL

bool test_isIDFIRST(UV ord) CODE: RETVAL = isIDFIRST(ord); OUTPUT: RETVAL

bool test_isIDFIRST_A(UV ord) CODE: RETVAL = isIDFIRST_A(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_isSPACE(UV ord) CODE: RETVAL = isSPACE(ord); OUTPUT: RETVAL

bool test_isSPACE_A(UV ord) CODE: RETVAL = isSPACE_A(ord); OUTPUT: RETVAL

bool test_isASCII(UV ord) CODE: RETVAL = isASCII(ord); OUTPUT: RETVAL

bool test_isASCII_A(UV ord) CODE: RETVAL = isASCII_A(ord); OUTPUT: RETVAL

bool test_isCNTRL(UV ord) CODE: RETVAL = isCNTRL(ord); OUTPUT: RETVAL

bool test_isCNTRL_A(UV ord) CODE: RETVAL = isCNTRL_A(ord); OUTPUT: RETVAL

bool test_isPRINT(UV ord) CODE: RETVAL = isPRINT(ord); OUTPUT: RETVAL

bool test_isPRINT_A(UV ord) CODE: RETVAL = isPRINT_A(ord); OUTPUT: RETVAL

bool test_isGRAPH(UV ord) CODE: RETVAL = isGRAPH(ord); OUTPUT: RETVAL

bool test_isGRAPH_A(UV ord) CODE: RETVAL = isGRAPH_A(ord); OUTPUT: RETVAL

bool test_isPUNCT(UV ord) CODE: RETVAL = isPUNCT(ord); OUTPUT: RETVAL

bool test_isPUNCT_A(UV ord) CODE: RETVAL = isPUNCT_A(ord); OUTPUT: RETVAL

bool test_isXDIGIT(UV ord) CODE: RETVAL = isXDIGIT(ord); OUTPUT: RETVAL

bool test_isXDIGIT_A(UV ord) CODE: RETVAL = isXDIGIT_A(ord); OUTPUT: RETVAL

bool test_isPSXSPC(UV ord) CODE: RETVAL = isPSXSPC(ord); OUTPUT: RETVAL

bool test_isPSXSPC_A(UV ord) CODE: RETVAL = isPSXSPC_A(ord); OUTPUT: RETVAL

STRLEN av_tindex(av) AV *av CODE: RETVAL = av_tindex(av); OUTPUT: RETVAL

STRLEN av_top_index(av) AV *av CODE: RETVAL = av_top_index(av); OUTPUT: RETVAL

use vars qw($my_sv @my_av %my_hv);

ok(&Devel::PPPort::boolSV(1)); ok(!&Devel::PPPort::boolSV(0));

$_ = "Fred"; ok(&Devel::PPPort::DEFSV(), "Fred"); ok(&Devel::PPPort::UNDERBAR(), "Fred");

if ("$]" >= 5.009002 && "$]" < 5.023 && "$]" < 5.023004) { eval q{ no warnings "deprecated"; no if $^V > v5.17.9, warnings => "experimental::lexical_topic"; my $_ = "Tony"; ok(&Devel::PPPort::DEFSV(), "Fred"); ok(&Devel::PPPort::UNDERBAR(), "Tony"); }; } else { ok(1); ok(1); }

my @r = &Devel::PPPort::DEFSV_modify();

ok(@r == 3); ok($r[0], 'Fred'); ok($r[1], 'DEFSV'); ok($r[2], 'Fred');

ok(&Devel::PPPort::DEFSV(), "Fred");

eval { 1 }; ok(!&Devel::PPPort::ERRSV()); eval { cannot_call_this_one() }; ok(&Devel::PPPort::ERRSV());

ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0)); ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0)); ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));

$my_sv = 1; ok(&Devel::PPPort::get_sv('my_sv', 0)); ok(!&Devel::PPPort::get_sv('not_my_sv', 0)); ok(&Devel::PPPort::get_sv('not_my_sv', 1));

@my_av = (1); ok(&Devel::PPPort::get_av('my_av', 0)); ok(!&Devel::PPPort::get_av('not_my_av', 0)); ok(&Devel::PPPort::get_av('not_my_av', 1));

%my_hv = (a=>1); ok(&Devel::PPPort::get_hv('my_hv', 0)); ok(!&Devel::PPPort::get_hv('not_my_hv', 0)); ok(&Devel::PPPort::get_hv('not_my_hv', 1));

sub my_cv { 1 }; ok(&Devel::PPPort::get_cv('my_cv', 0)); ok(!&Devel::PPPort::get_cv('not_my_cv', 0)); ok(&Devel::PPPort::get_cv('not_my_cv', 1));

ok(Devel::PPPort::dXSTARG(42), 43); ok(Devel::PPPort::dAXMARK(4711), 4710);

ok(Devel::PPPort::prepush(), 42);

ok(join(':', Devel::PPPort::xsreturn(0)), 'test1'); ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');

ok(Devel::PPPort::PERL_ABS(42), 42); ok(Devel::PPPort::PERL_ABS(-13), 13);

ok(Devel::PPPort::SVf(42), "$]" >= 5.004 ? '[42]' : '42'); ok(Devel::PPPort::SVf('abc'), "$]" >= 5.004 ? '[abc]' : 'abc');

ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo");

ok(&Devel::PPPort::ptrtests(), 63);

ok(&Devel::PPPort::OpSIBLING_tests(), 0);

if ("$]" >= 5.009000) { eval q{ ok(&Devel::PPPort::check_HeUTF8("hello"), "norm"); ok(&Devel::PPPort::check_HeUTF8("\N{U+263a}"), "utf8"); }; } else { ok(1, 1); ok(1, 1); }

@r = &Devel::PPPort::check_c_array(); ok($r[0], 4); ok($r[1], "13");

ok(!Devel::PPPort::SvRXOK("")); ok(!Devel::PPPort::SvRXOK(bless [], "Regexp"));

if ("$]" < 5.005) { skip 'no qr// objects in this perl', 0; skip 'no qr// objects in this perl', 0; } else { my $qr = eval 'qr/./'; ok(Devel::PPPort::SvRXOK($qr)); ok(Devel::PPPort::SvRXOK(bless $qr, "Surprise")); }

ok( Devel::PPPort::test_isBLANK(ord(" "))); ok(! Devel::PPPort::test_isBLANK(ord("\n")));

ok( Devel::PPPort::test_isBLANK_A(ord("\t"))); ok(! Devel::PPPort::test_isBLANK_A(ord("\r")));

ok( Devel::PPPort::test_isUPPER(ord("A"))); ok(! Devel::PPPort::test_isUPPER(ord("a")));

ok( Devel::PPPort::test_isUPPER_A(ord("Z")));

# One of these two is uppercase in EBCDIC; the other in Latin1, but neither are # ASCII uppercase. ok(! Devel::PPPort::test_isUPPER_A(ord(0xDC))); ok(! Devel::PPPort::test_isUPPER_A(ord(0xFC)));

ok( Devel::PPPort::test_isLOWER(ord("b"))); ok(! Devel::PPPort::test_isLOWER(ord("B")));

ok( Devel::PPPort::test_isLOWER_A(ord("y")));

# One of these two is lowercase in EBCDIC; the other in Latin1, but neither are # ASCII lowercase. ok(! Devel::PPPort::test_isLOWER_A(ord(0xDC))); ok(! Devel::PPPort::test_isLOWER_A(ord(0xFC)));

ok( Devel::PPPort::test_isALPHA(ord("C"))); ok(! Devel::PPPort::test_isALPHA(ord("1")));

ok( Devel::PPPort::test_isALPHA_A(ord("x"))); ok(! Devel::PPPort::test_isALPHA_A(0xDC));

ok( Devel::PPPort::test_isWORDCHAR(ord("_"))); ok(! Devel::PPPort::test_isWORDCHAR(ord("@")));

ok( Devel::PPPort::test_isWORDCHAR_A(ord("2"))); ok(! Devel::PPPort::test_isWORDCHAR_A(0xFC));

ok( Devel::PPPort::test_isALPHANUMERIC(ord("4"))); ok(! Devel::PPPort::test_isALPHANUMERIC(ord("_")));

ok( Devel::PPPort::test_isALPHANUMERIC_A(ord("l"))); ok(! Devel::PPPort::test_isALPHANUMERIC_A(0xDC));

ok( Devel::PPPort::test_isALNUM(ord("c"))); ok(! Devel::PPPort::test_isALNUM(ord("}")));

ok( Devel::PPPort::test_isALNUM_A(ord("5"))); ok(! Devel::PPPort::test_isALNUM_A(0xFC));

ok( Devel::PPPort::test_isDIGIT(ord("6"))); ok(! Devel::PPPort::test_isDIGIT(ord("_")));

ok( Devel::PPPort::test_isDIGIT_A(ord("7"))); ok(! Devel::PPPort::test_isDIGIT_A(0xDC));

ok( Devel::PPPort::test_isOCTAL(ord("7"))); ok(! Devel::PPPort::test_isOCTAL(ord("8")));

ok( Devel::PPPort::test_isOCTAL_A(ord("0"))); ok(! Devel::PPPort::test_isOCTAL_A(ord("9")));

ok( Devel::PPPort::test_isIDFIRST(ord("D"))); ok(! Devel::PPPort::test_isIDFIRST(ord("1")));

ok( Devel::PPPort::test_isIDFIRST_A(ord("_"))); ok(! Devel::PPPort::test_isIDFIRST_A(0xFC));

ok( Devel::PPPort::test_isIDCONT(ord("e"))); ok(! Devel::PPPort::test_isIDCONT(ord("@")));

ok( Devel::PPPort::test_isIDCONT_A(ord("2"))); ok(! Devel::PPPort::test_isIDCONT_A(0xDC));

ok( Devel::PPPort::test_isSPACE(ord(" "))); ok(! Devel::PPPort::test_isSPACE(ord("_")));

ok( Devel::PPPort::test_isSPACE_A(ord("\cK"))); ok(! Devel::PPPort::test_isSPACE_A(ord("F")));

# This stresses the edge for ASCII machines, but happens to work on EBCDIC as # well ok( Devel::PPPort::test_isASCII(0x7F)); ok(! Devel::PPPort::test_isASCII(0x80));

ok( Devel::PPPort::test_isASCII_A(ord("9")));

# B6 is the PARAGRAPH SIGN in ASCII and EBCDIC ok(! Devel::PPPort::test_isASCII_A(0xB6));

ok( Devel::PPPort::test_isCNTRL(ord("\e"))); ok(! Devel::PPPort::test_isCNTRL(ord(" ")));

ok( Devel::PPPort::test_isCNTRL_A(ord("\a"))); ok(! Devel::PPPort::test_isCNTRL_A(0xB6));

ok( Devel::PPPort::test_isPRINT(ord(" "))); ok(! Devel::PPPort::test_isPRINT(ord("\n")));

ok( Devel::PPPort::test_isPRINT_A(ord("G"))); ok(! Devel::PPPort::test_isPRINT_A(0xB6));

ok( Devel::PPPort::test_isGRAPH(ord("h"))); ok(! Devel::PPPort::test_isGRAPH(ord(" ")));

ok( Devel::PPPort::test_isGRAPH_A(ord("i"))); ok(! Devel::PPPort::test_isGRAPH_A(0xB6));

ok( Devel::PPPort::test_isPUNCT(ord("#"))); ok(! Devel::PPPort::test_isPUNCT(ord(" ")));

ok( Devel::PPPort::test_isPUNCT_A(ord("*"))); ok(! Devel::PPPort::test_isPUNCT_A(0xB6));

ok( Devel::PPPort::test_isXDIGIT(ord("A"))); ok(! Devel::PPPort::test_isXDIGIT(ord("_")));

ok( Devel::PPPort::test_isXDIGIT_A(ord("9"))); ok(! Devel::PPPort::test_isXDIGIT_A(0xDC));

ok( Devel::PPPort::test_isPSXSPC(ord(" "))); ok(! Devel::PPPort::test_isPSXSPC(ord("k")));

ok( Devel::PPPort::test_isPSXSPC_A(ord("\cK"))); ok(! Devel::PPPort::test_isPSXSPC_A(0xFC));

ok(&Devel::PPPort::av_top_index([1,2,3]), 2); ok(&Devel::PPPort::av_tindex([1,2,3,4]), 3);

cpanm Devel::PPPort

perl -MCPAN -e shell
install Devel::PPPort