################################################################################
##
##  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
##  Version 2.x, Copyright (C) 2001, Paul Marquess.
##  Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
##
##  This program is free software; you can redistribute it and/or
##  modify it under the same terms as Perl itself.
##
################################################################################

=provides

__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

=implementation

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

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

=xsmisc

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

=xsinit

#define NEED_SvRX

=xsboot

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

=xsubs

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

=tests plan => 128

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