[perl5.git] / ext / Devel-PPPort / parts / inc / misc

################################################################################
##
##  $Revision: 52 $
##  $Author: mhx $
##  $Date: 2009/03/15 06:51:00 +0100 $
##
################################################################################
##
##  Version 3.x, Copyright (C) 2004-2009, 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
#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__  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
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"]", 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 => 39

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

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