################################################################################
##
## 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
UTF8_ALLOW_ANYUV
UTF8_ALLOW_EMPTY
UTF8_ALLOW_CONTINUATION
UTF8_ALLOW_NON_CONTINUATION
UTF8_ALLOW_SHORT
UTF8_ALLOW_LONG
UTF8_ALLOW_OVERFLOW
UTF8_ALLOW_ANY
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
__UNDEFINED__ SvRX(rv) (SvROK((rv)) ? (SvMAGICAL(SvRV((rv))) ? (mg_find(SvRV((rv)), PERL_MAGIC_qr) ? mg_find(SvRV((rv)), PERL_MAGIC_qr)->mg_obj : NULL) : NULL) : NULL)
__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__ UTF8_ALLOW_ANYUV 0
__UNDEFINED__ UTF8_ALLOW_EMPTY 0x0001
__UNDEFINED__ UTF8_ALLOW_CONTINUATION 0x0002
__UNDEFINED__ UTF8_ALLOW_NON_CONTINUATION 0x0004
__UNDEFINED__ UTF8_ALLOW_SHORT 0x0008
__UNDEFINED__ UTF8_ALLOW_LONG 0x0010
__UNDEFINED__ UTF8_ALLOW_OVERFLOW 0x0080
__UNDEFINED__ UTF8_ALLOW_ANY ( UTF8_ALLOW_CONTINUATION \
|UTF8_ALLOW_NON_CONTINUATION \
|UTF8_ALLOW_SHORT \
|UTF8_ALLOW_LONG \
|UTF8_ALLOW_OVERFLOW)
__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))
=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
int returnint(int x)
#if !defined(PERL_MICRO) && defined __GNUC__ && !defined(__INTEL_COMPILER)
# if __GNUC__ == 3 && __GNUC_MINOR__ >= 4 || __GNUC__ > 3 /* 3.4 -> */
__attribute__((warn_unused_result))
# endif
#endif
;
int returnint(int x) { return x * x; }
=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");
}
OpMAYBESIB_set(x, (OP*)NULL, NULL);
if (OpHAS_SIBLING(x) || OpSIBLING(x)) {
failures++; warn("OpMAYBESIB_set with NULL failed?");
}
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 = SvTRUEx(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_ARG(x);
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 */
bool
test_isBLANK(ord)
UV ord
CODE:
RETVAL = isBLANK(ord);
OUTPUT:
RETVAL
bool
test_isBLANK_A(ord)
UV ord
CODE:
RETVAL = isBLANK_A(ord);
OUTPUT:
RETVAL
bool
test_isUPPER(ord)
UV ord
CODE:
RETVAL = isUPPER(ord);
OUTPUT:
RETVAL
bool
test_isUPPER_A(ord)
UV ord
CODE:
RETVAL = isUPPER_A(ord);
OUTPUT:
RETVAL
bool
test_isLOWER(ord)
UV ord
CODE:
RETVAL = isLOWER(ord);
OUTPUT:
RETVAL
bool
test_isLOWER_A(ord)
UV ord
CODE:
RETVAL = isLOWER_A(ord);
OUTPUT:
RETVAL
bool
test_isALPHA(ord)
UV ord
CODE:
RETVAL = isALPHA(ord);
OUTPUT:
RETVAL
bool
test_isALPHA_A(ord)
UV ord
CODE:
RETVAL = isALPHA_A(ord);
OUTPUT:
RETVAL
bool
test_isWORDCHAR(ord)
UV ord
CODE:
RETVAL = isWORDCHAR(ord);
OUTPUT:
RETVAL
bool
test_isWORDCHAR_A(ord)
UV ord
CODE:
RETVAL = isWORDCHAR_A(ord);
OUTPUT:
RETVAL
bool
test_isALPHANUMERIC(ord)
UV ord
CODE:
RETVAL = isALPHANUMERIC(ord);
OUTPUT:
RETVAL
bool
test_isALPHANUMERIC_A(ord)
UV ord
CODE:
RETVAL = isALPHANUMERIC_A(ord);
OUTPUT:
RETVAL
bool
test_isALNUM(ord)
UV ord
CODE:
RETVAL = isALNUM(ord);
OUTPUT:
RETVAL
bool
test_isALNUM_A(ord)
UV ord
CODE:
RETVAL = isALNUM_A(ord);
OUTPUT:
RETVAL
bool
test_isDIGIT(ord)
UV ord
CODE:
RETVAL = isDIGIT(ord);
OUTPUT:
RETVAL
bool
test_isDIGIT_A(ord)
UV ord
CODE:
RETVAL = isDIGIT_A(ord);
OUTPUT:
RETVAL
bool
test_isOCTAL(ord)
UV ord
CODE:
RETVAL = isOCTAL(ord);
OUTPUT:
RETVAL
bool
test_isOCTAL_A(ord)
UV ord
CODE:
RETVAL = isOCTAL_A(ord);
OUTPUT:
RETVAL
bool
test_isIDFIRST(ord)
UV ord
CODE:
RETVAL = isIDFIRST(ord);
OUTPUT:
RETVAL
bool
test_isIDFIRST_A(ord)
UV ord
CODE:
RETVAL = isIDFIRST_A(ord);
OUTPUT:
RETVAL
bool
test_isIDCONT(ord)
UV ord
CODE:
RETVAL = isIDCONT(ord);
OUTPUT:
RETVAL
bool
test_isIDCONT_A(ord)
UV ord
CODE:
RETVAL = isIDCONT_A(ord);
OUTPUT:
RETVAL
bool
test_isSPACE(ord)
UV ord
CODE:
RETVAL = isSPACE(ord);
OUTPUT:
RETVAL
bool
test_isSPACE_A(ord)
UV ord
CODE:
RETVAL = isSPACE_A(ord);
OUTPUT:
RETVAL
bool
test_isASCII(ord)
UV ord
CODE:
RETVAL = isASCII(ord);
OUTPUT:
RETVAL
bool
test_isASCII_A(ord)
UV ord
CODE:
RETVAL = isASCII_A(ord);
OUTPUT:
RETVAL
bool
test_isCNTRL(ord)
UV ord
CODE:
RETVAL = isCNTRL(ord);
OUTPUT:
RETVAL
bool
test_isCNTRL_A(ord)
UV ord
CODE:
RETVAL = isCNTRL_A(ord);
OUTPUT:
RETVAL
bool
test_isPRINT(ord)
UV ord
CODE:
RETVAL = isPRINT(ord);
OUTPUT:
RETVAL
bool
test_isPRINT_A(ord)
UV ord
CODE:
RETVAL = isPRINT_A(ord);
OUTPUT:
RETVAL
bool
test_isGRAPH(ord)
UV ord
CODE:
RETVAL = isGRAPH(ord);
OUTPUT:
RETVAL
bool
test_isGRAPH_A(ord)
UV ord
CODE:
RETVAL = isGRAPH_A(ord);
OUTPUT:
RETVAL
bool
test_isPUNCT(ord)
UV ord
CODE:
RETVAL = isPUNCT(ord);
OUTPUT:
RETVAL
bool
test_isPUNCT_A(ord)
UV ord
CODE:
RETVAL = isPUNCT_A(ord);
OUTPUT:
RETVAL
bool
test_isXDIGIT(ord)
UV ord
CODE:
RETVAL = isXDIGIT(ord);
OUTPUT:
RETVAL
bool
test_isXDIGIT_A(ord)
UV ord
CODE:
RETVAL = isXDIGIT_A(ord);
OUTPUT:
RETVAL
bool
test_isPSXSPC(ord)
UV ord
CODE:
RETVAL = isPSXSPC(ord);
OUTPUT:
RETVAL
bool
test_isPSXSPC_A(ord)
UV ord
CODE:
RETVAL = isPSXSPC_A(ord);
OUTPUT:
RETVAL
STRLEN
av_tindex(av)
SV *av
CODE:
RETVAL = av_tindex((AV*)SvRV(av));
OUTPUT:
RETVAL
STRLEN
av_top_index(av)
SV *av
CODE:
RETVAL = av_top_index((AV*)SvRV(av));
OUTPUT:
RETVAL
=tests plan => 129
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"));
}
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);