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

################################################################################
##
##  $Revision: 51 $
##  $Author: mhx $
##  $Date: 2009/01/23 18:28:31 +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

#  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))
__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
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 => 38

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