__UNDEFINED__ PERL_UNUSED_DECL PERL_UNUSED_ARG PERL_UNUSED_VAR PERL_UNUSED_CONTEXT PERL_UNUSED_RESULT PERL_GCC_BRACE_GROUPS_FORBIDDEN PERL_USE_GCC_BRACE_GROUPS PERLIO_FUNCS_DECL PERLIO_FUNCS_CAST NVTYPE INT2PTR PTRV NUM2PTR PERL_HASH PTR2IV PTR2UV PTR2NV PTR2ul START_EXTERN_C END_EXTERN_C EXTERN_C STMT_START STMT_END UTF8_MAXBYTES WIDEST_UTYPE XSRETURN HeUTF8 C_ARRAY_LENGTH C_ARRAY_END SvRX SvRXOK PERL_MAGIC_qr cBOOL OpHAS_SIBLING OpSIBLING OpMORESIB_set OpLASTSIB_set OpMAYBESIB_set

__UNDEFINED__ PERL_MAGIC_qr 'r'

__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))

#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__ 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

__UNDEFINED__ isPSXSPC(c) (isSPACE(c) || (c) == '\v') __UNDEFINED__ isBLANK(c) ((c) == ' ' || (c) == '\t') #ifdef EBCDIC __UNDEFINED__ isALNUMC(c) isalnum(c) __UNDEFINED__ isASCII(c) isascii(c) __UNDEFINED__ isCNTRL(c) iscntrl(c) __UNDEFINED__ isGRAPH(c) isgraph(c) __UNDEFINED__ isPRINT(c) isprint(c) __UNDEFINED__ isPUNCT(c) ispunct(c) __UNDEFINED__ isXDIGIT(c) isxdigit(c) #else # 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 # endif

#ifdef HAS_QUAD # ifdef U64TYPE # define WIDEST_UTYPE U64TYPE # else # define WIDEST_UTYPE Quad_t # endif #else # define WIDEST_UTYPE U32 #endif

__UNDEFINED__ isALNUMC(c) (isALPHA(c) || isDIGIT(c)) __UNDEFINED__ isASCII(c) ((WIDEST_UTYPE) (c) <= 127) __UNDEFINED__ isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) __UNDEFINED__ isGRAPH(c) (isALNUM(c) || isPUNCT(c)) __UNDEFINED__ isPRINT(c) (((c) >= 32 && (c) < 127)) __UNDEFINED__ isPUNCT(c) (((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64) || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126)) __UNDEFINED__ isXDIGIT(c) (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F')) #endif

/* 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))

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

int returnint(int x) __attribute__((warn_unused_result)); int returnint(int x) { return x * x; }

{ 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 *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;
	}

	/* 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");
	}

	OpMAYBESIB_set(x, NULL, NULL);

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

	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_unused_return(x) int x; PPCODE: PERL_UNUSED_RESULT(returnint(3)); mXPUSHp("Yay", 3);

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 */

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); }

# Lame test, just make sure this still works ok(&Devel::PPPort::check_unused_return(3), "Yay");

@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")); }

cpanm Devel::PPPort

perl -MCPAN -e shell
install Devel::PPPort