[p5sagit/p5-mst-13.2.git] / ext / Devel / PPPort / parts / inc / misc

################################################################################
##
##  $Revision: 48 $
##  $Author: mhx $
##  $Date: 2008/10/30 01:46:33 +0100 $
##
################################################################################
##
##  Version 3.x, Copyright (C) 2004-2008, 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__
PERL_UNUSED_DECL
PERL_UNUSED_ARG
PERL_UNUSED_VAR
PERL_UNUSED_CONTEXT
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
XSRETURN

=implementation

#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

__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

#  define NUM2PTR(any,d)  (any)(PTRV)(d)
#  define PTR2IV(p)       INT2PTR(IV,p)
#  define PTR2UV(p)       INT2PTR(UV,p)
#  define PTR2NV(p)       NUM2PTR(NV,p)

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

#endif /* !INT2PTR */

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

/* 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__  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
__UNDEFINED__ isALNUMC(c)	(isALPHA(c) || isDIGIT(c))
__UNDEFINED__ isASCII(c)	((c) <= 127)
__UNDEFINED__ isCNTRL(c)	((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

=xsmisc

XS(XS_Devel__PPPort_dXSTARG);  /* prototype */
XS(XS_Devel__PPPort_dXSTARG)
{
  dXSARGS;
  dXSTARG;
  IV iv;
  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;
  SP -= items;
  iv = SvIV(ST(0)) - 1;
  mPUSHi(iv);
  XSRETURN(1);
}

=xsboot

newXS("Devel::PPPort::dXSTARG", XS_Devel__PPPort_dXSTARG, file);
newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);

=xsubs

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

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"]", x));
#endif
		XPUSHs(x);
		XSRETURN(1);

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

=tests plan => 33

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) {
  eval q{
    my $_ = "Tony";
    ok(&Devel::PPPort::DEFSV(), "Fred");
    ok(&Devel::PPPort::UNDERBAR(), "Tony");
  };
}
else {
  ok(1);
  ok(1);
}

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");
Commit	Line	Data
adfe19db	1	################################################################################
adfe19db	2	##
db42c902	3	## $Revision: 48 $
adfe19db	4	## $Author: mhx $
db42c902	5	## $Date: 2008/10/30 01:46:33 +0100 $
adfe19db	6	##
	7	################################################################################
	8	##
c1a049cb	9	## Version 3.x, Copyright (C) 2004-2008, Marcus Holland-Moritz.
adfe19db	10	## Version 2.x, Copyright (C) 2001, Paul Marquess.
	11	## Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
	12	##
	13	## This program is free software; you can redistribute it and/or
	14	## modify it under the same terms as Perl itself.
	15	##
	16	################################################################################
	17
	18	=provides
	19
	20	__UNDEFINED__
	21	PERL_UNUSED_DECL
f2ab5a41	22	PERL_UNUSED_ARG
	23	PERL_UNUSED_VAR
	24	PERL_UNUSED_CONTEXT
a745474a	25	PERL_GCC_BRACE_GROUPS_FORBIDDEN
c07deaaf	26	PERL_USE_GCC_BRACE_GROUPS
9c0a17a0	27	PERLIO_FUNCS_DECL
9c0a17a0	28	PERLIO_FUNCS_CAST
adfe19db	29	NVTYPE
	30	INT2PTR
	31	PTRV
	32	NUM2PTR
c83e6f19	33	PERL_HASH
adfe19db	34	PTR2IV
	35	PTR2UV
	36	PTR2NV
	37	PTR2ul
a745474a	38	START_EXTERN_C
	39	END_EXTERN_C
	40	EXTERN_C
	41	STMT_START
	42	STMT_END
679ad62d	43	UTF8_MAXBYTES
0d0f8426	44	XSRETURN
adfe19db	45
	46	=implementation
	47
62093c1c	48	#ifndef PERL_UNUSED_DECL
	49	# ifdef HASATTRIBUTE
	50	# if (defined(__GNUC__) && defined(__cplusplus)) \|\| defined(__INTEL_COMPILER)
	51	# define PERL_UNUSED_DECL
	52	# else
	53	# define PERL_UNUSED_DECL __attribute__((unused))
	54	# endif
adfe19db	55	# else
62093c1c	56	# define PERL_UNUSED_DECL
adfe19db	57	# endif
adfe19db	58	#endif
adfe19db	59
f2ab5a41	60	#ifndef PERL_UNUSED_ARG
	61	# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
	62	# include <note.h>
	63	# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
	64	# else
	65	# define PERL_UNUSED_ARG(x) ((void)x)
	66	# endif
	67	#endif
	68
	69	#ifndef PERL_UNUSED_VAR
	70	# define PERL_UNUSED_VAR(x) ((void)x)
	71	#endif
	72
	73	#ifndef PERL_UNUSED_CONTEXT
	74	# ifdef USE_ITHREADS
	75	# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
	76	# else
	77	# define PERL_UNUSED_CONTEXT
	78	# endif
	79	#endif
	80
	81	__UNDEFINED__ NOOP /EMPTY/(void)0
	82	__UNDEFINED__ dNOOP extern int /@unused@/ Perl___notused PERL_UNUSED_DECL
adfe19db	83
	84	#ifndef NVTYPE
	85	# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
	86	# define NVTYPE long double
	87	# else
	88	# define NVTYPE double
	89	# endif
	90	typedef NVTYPE NV;
	91	#endif
	92
	93	#ifndef INT2PTR
	94
	95	# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
	96	# define PTRV UV
	97	# define INT2PTR(any,d) (any)(d)
	98	# else
	99	# if PTRSIZE == LONGSIZE
	100	# define PTRV unsigned long
	101	# else
	102	# define PTRV unsigned
	103	# endif
	104	# define INT2PTR(any,d) (any)(PTRV)(d)
	105	# endif
	106
	107	# define NUM2PTR(any,d) (any)(PTRV)(d)
	108	# define PTR2IV(p) INT2PTR(IV,p)
	109	# define PTR2UV(p) INT2PTR(UV,p)
	110	# define PTR2NV(p) NUM2PTR(NV,p)
	111
	112	# if PTRSIZE == LONGSIZE
	113	# define PTR2ul(p) (unsigned long)(p)
	114	# else
4a582685	115	# define PTR2ul(p) INT2PTR(unsigned long,p)
adfe19db	116	# endif
	117
	118	#endif /* !INT2PTR */
	119
a745474a	120	#undef START_EXTERN_C
	121	#undef END_EXTERN_C
	122	#undef EXTERN_C
	123	#ifdef __cplusplus
	124	# define START_EXTERN_C extern "C" {
	125	# define END_EXTERN_C }
	126	# define EXTERN_C extern "C"
	127	#else
	128	# define START_EXTERN_C
	129	# define END_EXTERN_C
	130	# define EXTERN_C extern
	131	#endif
	132
c07deaaf	133	#if defined(PERL_GCC_PEDANTIC)
c07deaaf	134	# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
a745474a	135	# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
	136	# endif
	137	#endif
	138
c07deaaf	139	#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
	140	# ifndef PERL_USE_GCC_BRACE_GROUPS
	141	# define PERL_USE_GCC_BRACE_GROUPS
	142	# endif
	143	#endif
	144
a745474a	145	#undef STMT_START
a745474a	146	#undef STMT_END
c07deaaf	147	#ifdef PERL_USE_GCC_BRACE_GROUPS
a745474a	148	# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
	149	# define STMT_END )
	150	#else
	151	# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) \|\| defined(__sun__)) && !defined(__GNUC__)
	152	# define STMT_START if (1)
	153	# define STMT_END else (void)0
	154	# else
	155	# define STMT_START do
	156	# define STMT_END while (0)
	157	# endif
	158	#endif
	159
adfe19db	160	__UNDEFINED__ boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
	161
	162	/* DEFSV appears first in 5.004_56 */
	163	__UNDEFINED__ DEFSV GvSV(PL_defgv)
	164	__UNDEFINED__ SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
	165
	166	/* Older perls (<=5.003) lack AvFILLp */
	167	__UNDEFINED__ AvFILLp AvFILL
	168
	169	__UNDEFINED__ ERRSV get_sv("@",FALSE)
	170
adfe19db	171	/* Hint: gv_stashpvn
	172	* This function's backport doesn't support the length parameter, but
	173	* rather ignores it. Portability can only be ensured if the length
	174	* parameter is used for speed reasons, but the length can always be
	175	* correctly computed from the string argument.
	176	*/
	177
	178	__UNDEFINED__ gv_stashpvn(str,len,create) gv_stashpv(str,create)
	179
	180	/* Replace: 1 */
	181	__UNDEFINED__ get_cv perl_get_cv
	182	__UNDEFINED__ get_sv perl_get_sv
	183	__UNDEFINED__ get_av perl_get_av
	184	__UNDEFINED__ get_hv perl_get_hv
	185	/* Replace: 0 */
	186
adfe19db	187	__UNDEFINED__ dUNDERBAR dNOOP
	188	__UNDEFINED__ UNDERBAR DEFSV
	189
	190	__UNDEFINED__ dAX I32 ax = MARK - PL_stack_base + 1
	191	__UNDEFINED__ dITEMS I32 items = SP - MARK
	192
9132e1a3	193	__UNDEFINED__ dXSTARG SV * targ = sv_newmortal()
9132e1a3	194
0d0f8426	195	__UNDEFINED__ dAXMARK I32 ax = POPMARK; \
	196	register SV ** const mark = PL_stack_base + ax++
	197
	198
	199	__UNDEFINED__ XSprePUSH (sp = PL_stack_base + ax - 1)
	200
	201	#if { VERSION < 5.005 }
	202	# undef XSRETURN
	203	# define XSRETURN(off) \
	204	STMT_START { \
	205	PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
	206	return; \
	207	} STMT_END
	208	#endif
	209
f2ab5a41	210	__UNDEFINED__ PERL_ABS(x) ((x) < 0 ? -(x) : (x))
	211
	212	__UNDEFINED__ dVAR dNOOP
	213
	214	__UNDEFINED__ SVf "_"
	215
c83e6f19	216	__UNDEFINED__ UTF8_MAXBYTES UTF8_MAXLEN
c83e6f19	217
fd7af155	218	__UNDEFINED__ CPERLscope(x) x
fd7af155	219
c83e6f19	220	__UNDEFINED__ PERL_HASH(hash,str,len) \
	221	STMT_START { \
	222	const char *s_PeRlHaSh = str; \
	223	I32 i_PeRlHaSh = len; \
	224	U32 hash_PeRlHaSh = 0; \
	225	while (i_PeRlHaSh--) \
	226	hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
	227	(hash) = hash_PeRlHaSh; \
	228	} STMT_END
679ad62d	229
9c0a17a0	230	#ifndef PERLIO_FUNCS_DECL
	231	# ifdef PERLIO_FUNCS_CONST
	232	# define PERLIO_FUNCS_DECL(funcs) const PerlIO_funcs funcs
	233	# define PERLIO_FUNCS_CAST(funcs) (PerlIO_funcs*)(funcs)
	234	# else
	235	# define PERLIO_FUNCS_DECL(funcs) PerlIO_funcs funcs
	236	# define PERLIO_FUNCS_CAST(funcs) (funcs)
	237	# endif
	238	#endif
	239
fd7af155	240	/* provide these typedefs for older perls */
	241	#if { VERSION < 5.9.3 }
	242
	243	# ifdef ARGSproto
	244	typedef OP* (CPERLscope(*Perl_ppaddr_t))(ARGSproto);
	245	# else
	246	typedef OP* (CPERLscope(*Perl_ppaddr_t))(pTHX);
	247	# endif
	248
	249	typedef OP* (CPERLscope(Perl_check_t)) (pTHX_ OP);
	250
	251	#endif
	252
db42c902	253	__UNDEFINED__ isPSXSPC(c) (isSPACE(c) \|\| (c) == '\v')
	254	__UNDEFINED__ isBLANK(c) ((c) == ' ' \|\| (c) == '\t')
	255	#ifdef EBCDIC
	256	__UNDEFINED__ isALNUMC(c) isalnum(c)
	257	__UNDEFINED__ isASCII(c) isascii(c)
	258	__UNDEFINED__ isCNTRL(c) iscntrl(c)
	259	__UNDEFINED__ isGRAPH(c) isgraph(c)
	260	__UNDEFINED__ isPRINT(c) isprint(c)
	261	__UNDEFINED__ isPUNCT(c) ispunct(c)
	262	__UNDEFINED__ isXDIGIT(c) isxdigit(c)
	263	#else
	264	# if { VERSION < 5.10.0 }
	265	/* Hint: isPRINT
	266	* The implementation in older perl versions includes all of the
	267	* isSPACE() characters, which is wrong. The version provided by
	268	* Devel::PPPort always overrides a present buggy version.
	269	*/
	270	# undef isPRINT
	271	# endif
	272	__UNDEFINED__ isALNUMC(c) (isALPHA(c) \|\| isDIGIT(c))
	273	__UNDEFINED__ isASCII(c) ((c) <= 127)
	274	__UNDEFINED__ isCNTRL(c) ((c) < ' ' \|\| (c) == 127)
	275	__UNDEFINED__ isGRAPH(c) (isALNUM(c) \|\| isPUNCT(c))
	276	__UNDEFINED__ isPRINT(c) (((c) >= 32 && (c) < 127))
	277	__UNDEFINED__ isPUNCT(c) (((c) >= 33 && (c) <= 47) \|\| ((c) >= 58 && (c) <= 64) \|\| ((c) >= 91 && (c) <= 96) \|\| ((c) >= 123 && (c) <= 126))
	278	__UNDEFINED__ isXDIGIT(c) (isDIGIT(c) \|\| ((c) >= 'a' && (c) <= 'f') \|\| ((c) >= 'A' && (c) <= 'F'))
	279	#endif
	280
9132e1a3	281	=xsmisc
	282
	283	XS(XS_Devel__PPPort_dXSTARG); /* prototype */
	284	XS(XS_Devel__PPPort_dXSTARG)
	285	{
	286	dXSARGS;
	287	dXSTARG;
2dd69576	288	IV iv;
9132e1a3	289	SP -= items;
2dd69576	290	iv = SvIV(ST(0)) + 1;
9132e1a3	291	PUSHi(iv);
	292	XSRETURN(1);
	293	}
	294
0d0f8426	295	XS(XS_Devel__PPPort_dAXMARK); /* prototype */
	296	XS(XS_Devel__PPPort_dAXMARK)
	297	{
	298	dSP;
	299	dAXMARK;
	300	dITEMS;
	301	IV iv;
	302	SP -= items;
	303	iv = SvIV(ST(0)) - 1;
c1a049cb	304	mPUSHi(iv);
0d0f8426	305	XSRETURN(1);
	306	}
	307
9132e1a3	308	=xsboot
	309
	310	newXS("Devel::PPPort::dXSTARG", XS_Devel__PPPort_dXSTARG, file);
0d0f8426	311	newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
9132e1a3	312
adfe19db	313	=xsubs
	314
	315	int
	316	gv_stashpvn(name, create)
	317	char *name
	318	I32 create
	319	CODE:
	320	RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
	321	OUTPUT:
	322	RETVAL
	323
	324	int
	325	get_sv(name, create)
	326	char *name
	327	I32 create
	328	CODE:
	329	RETVAL = get_sv(name, create) != NULL;
	330	OUTPUT:
	331	RETVAL
	332
	333	int
	334	get_av(name, create)
	335	char *name
	336	I32 create
	337	CODE:
	338	RETVAL = get_av(name, create) != NULL;
	339	OUTPUT:
	340	RETVAL
	341
	342	int
	343	get_hv(name, create)
	344	char *name
	345	I32 create
	346	CODE:
	347	RETVAL = get_hv(name, create) != NULL;
	348	OUTPUT:
	349	RETVAL
	350
	351	int
	352	get_cv(name, create)
	353	char *name
	354	I32 create
	355	CODE:
	356	RETVAL = get_cv(name, create) != NULL;
	357	OUTPUT:
	358	RETVAL
	359
	360	void
0d0f8426	361	xsreturn(two)
	362	int two
	363	PPCODE:
c1a049cb	364	mXPUSHp("test1", 5);
0d0f8426	365	if (two)
c1a049cb	366	mXPUSHp("test2", 5);
0d0f8426	367	if (two)
	368	XSRETURN(2);
	369	else
	370	XSRETURN(1);
	371
adfe19db	372	SV*
	373	boolSV(value)
	374	int value
	375	CODE:
	376	RETVAL = newSVsv(boolSV(value));
	377	OUTPUT:
	378	RETVAL
	379
	380	SV*
	381	DEFSV()
	382	CODE:
	383	RETVAL = newSVsv(DEFSV);
	384	OUTPUT:
	385	RETVAL
	386
	387	int
	388	ERRSV()
	389	CODE:
	390	RETVAL = SvTRUE(ERRSV);
	391	OUTPUT:
	392	RETVAL
	393
	394	SV*
	395	UNDERBAR()
	396	CODE:
	397	{
	398	dUNDERBAR;
	399	RETVAL = newSVsv(UNDERBAR);
	400	}
	401	OUTPUT:
	402	RETVAL
	403
0d0f8426	404	void
	405	prepush()
	406	CODE:
	407	{
	408	dXSTARG;
	409	XSprePUSH;
1d175cda	410	PUSHi(42);
0d0f8426	411	XSRETURN(1);
	412	}
	413
f2ab5a41	414	int
	415	PERL_ABS(a)
	416	int a
	417
	418	void
	419	SVf(x)
	420	SV *x
	421	PPCODE:
	422	#if { VERSION >= 5.004 }
c1a049cb	423	x = sv_2mortal(newSVpvf("[%"SVf"]", x));
f2ab5a41	424	#endif
	425	XPUSHs(x);
	426	XSRETURN(1);
	427
fd7af155	428	void
	429	Perl_ppaddr_t(string)
	430	char *string
	431	PREINIT:
	432	Perl_ppaddr_t lower;
	433	PPCODE:
	434	lower = PL_ppaddr[OP_LC];
	435	PUSHMARK(SP);
	436	mXPUSHs(newSVpv(string, 0));
	437	PUTBACK;
	438	ENTER;
	439	(void)*(lower)(aTHXR);
	440	SPAGAIN;
	441	LEAVE;
	442	XSRETURN(1);
	443
	444	=tests plan => 33
adfe19db	445
	446	use vars qw($my_sv @my_av %my_hv);
	447
adfe19db	448	ok(&Devel::PPPort::boolSV(1));
	449	ok(!&Devel::PPPort::boolSV(0));
	450
	451	$_ = "Fred";
	452	ok(&Devel::PPPort::DEFSV(), "Fred");
	453	ok(&Devel::PPPort::UNDERBAR(), "Fred");
	454
0d0f8426	455	if ($] >= 5.009002) {
	456	eval q{
	457	my $_ = "Tony";
	458	ok(&Devel::PPPort::DEFSV(), "Fred");
	459	ok(&Devel::PPPort::UNDERBAR(), "Tony");
	460	};
	461	}
	462	else {
	463	ok(1);
	464	ok(1);
	465	}
	466
adfe19db	467	eval { 1 };
	468	ok(!&Devel::PPPort::ERRSV());
	469	eval { cannot_call_this_one() };
	470	ok(&Devel::PPPort::ERRSV());
	471
	472	ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
	473	ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
	474	ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
	475
	476	$my_sv = 1;
	477	ok(&Devel::PPPort::get_sv('my_sv', 0));
	478	ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
	479	ok(&Devel::PPPort::get_sv('not_my_sv', 1));
	480
	481	@my_av = (1);
	482	ok(&Devel::PPPort::get_av('my_av', 0));
	483	ok(!&Devel::PPPort::get_av('not_my_av', 0));
	484	ok(&Devel::PPPort::get_av('not_my_av', 1));
	485
	486	%my_hv = (a=>1);
	487	ok(&Devel::PPPort::get_hv('my_hv', 0));
	488	ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
	489	ok(&Devel::PPPort::get_hv('not_my_hv', 1));
	490
	491	sub my_cv { 1 };
	492	ok(&Devel::PPPort::get_cv('my_cv', 0));
	493	ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
	494	ok(&Devel::PPPort::get_cv('not_my_cv', 1));
	495
9132e1a3	496	ok(Devel::PPPort::dXSTARG(42), 43);
0d0f8426	497	ok(Devel::PPPort::dAXMARK(4711), 4710);
	498
	499	ok(Devel::PPPort::prepush(), 42);
9132e1a3	500
0d0f8426	501	ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
0d0f8426	502	ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
f2ab5a41	503
	504	ok(Devel::PPPort::PERL_ABS(42), 42);
	505	ok(Devel::PPPort::PERL_ABS(-13), 13);
	506
	507	ok(Devel::PPPort::SVf(42), $] >= 5.004 ? '[42]' : '42');
	508	ok(Devel::PPPort::SVf('abc'), $] >= 5.004 ? '[abc]' : 'abc');
	509
fd7af155	510	ok(&Devel::PPPort::Perl_ppaddr_t("FOO"), "foo");
fd7af155	511