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

################################################################################
##
##  $Revision: 35 $
##  $Author: mhx $
##  $Date: 2006/05/19 23:57:26 +0200 $
##
################################################################################
##
##  Version 3.x, Copyright (C) 2004-2006, 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
NVTYPE
INT2PTR
PTRV
NUM2PTR
PTR2IV
PTR2UV
PTR2NV
PTR2ul
START_EXTERN_C
END_EXTERN_C
EXTERN_C
STMT_START
STMT_END
XSRETURN
/PL_\w+/

=implementation

#if { VERSION <= 5.004_05 }
/* Replace: 1 */
#  define PL_DBsingle               DBsingle
#  define PL_DBsub                  DBsub
#  define PL_Sv                     Sv
#  define PL_compiling              compiling
#  define PL_copline                copline
#  define PL_curcop                 curcop
#  define PL_curstash               curstash
#  define PL_debstash               debstash
#  define PL_defgv                  defgv
#  define PL_diehook                diehook
#  define PL_dirty                  dirty
#  define PL_dowarn                 dowarn
#  define PL_errgv                  errgv
#  define PL_hexdigit               hexdigit
#  define PL_hints                  hints
#  define PL_na	                    na
#  define PL_no_modify              no_modify
#  define PL_perl_destruct_level    perl_destruct_level
#  define PL_perldb                 perldb
#  define PL_ppaddr                 ppaddr
#  define PL_rsfp_filters           rsfp_filters
#  define PL_rsfp                   rsfp
#  define PL_stack_base             stack_base
#  define PL_stack_sp               stack_sp
#  define PL_stdingv                stdingv
#  define PL_sv_arenaroot           sv_arenaroot
#  define PL_sv_no                  sv_no
#  define PL_sv_undef               sv_undef
#  define PL_sv_yes                 sv_yes
#  define PL_tainted                tainted
#  define PL_tainting               tainting
/* Replace: 0 */
#endif

#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

#ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
#  if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC)
#    define PERL_GCC_BRACE_GROUPS_FORBIDDEN
#  endif
#endif

#undef STMT_START
#undef STMT_END
#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
#  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)

__UNDEFINED__  newSVpvn(data,len)  ((data)                                              \
                                    ? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
                                    : newSV(0))

/* 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             "_"

=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;
  PUSHs(sv_2mortal(newSViv(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
newSVpvn()
	PPCODE:
		XPUSHs(newSVpvn("test", 4));
		XPUSHs(newSVpvn("test", 2));
		XPUSHs(newSVpvn("test", 0));
		XPUSHs(newSVpvn(NULL, 2));
		XPUSHs(newSVpvn(NULL, 0));
		XSRETURN(5);

void
xsreturn(two)
	int two
	PPCODE:
		XPUSHs(newSVpvn("test1", 5));
		if (two)
		  XPUSHs(newSVpvn("test2", 5));
		if (two)
		  XSRETURN(2);
		else
		  XSRETURN(1);

SV *
PL_sv_undef()
	CODE:
		RETVAL = newSVsv(&PL_sv_undef);
	OUTPUT:
		RETVAL

SV *
PL_sv_yes()
	CODE:
		RETVAL = newSVsv(&PL_sv_yes);
	OUTPUT:
		RETVAL

SV *
PL_sv_no()
	CODE:
		RETVAL = newSVsv(&PL_sv_no);
	OUTPUT:
		RETVAL

int
PL_na(string)
	char *string
	CODE:
		PL_na = strlen(string);
		RETVAL = PL_na;
	OUTPUT:
		RETVAL

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

=tests plan => 42

use vars qw($my_sv @my_av %my_hv);

my @s = &Devel::PPPort::newSVpvn();
ok(@s == 5);
ok($s[0], "test");
ok($s[1], "te");
ok($s[2], "");
ok(!defined($s[3]));
ok(!defined($s[4]));

ok(!defined(&Devel::PPPort::PL_sv_undef()));
ok(&Devel::PPPort::PL_sv_yes());
ok(!&Devel::PPPort::PL_sv_no());
ok(&Devel::PPPort::PL_na("abcd"), 4);

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');
Commit	Line	Data
adfe19db MHM	1	################################################################################
adfe19db MHM	2	##
f2ab5a41	3	## $Revision: 35 $
adfe19db	4	## $Author: mhx $
f2ab5a41	5	## $Date: 2006/05/19 23:57:26 +0200 $
adfe19db MHM	6	##
	7	################################################################################
	8	##
0d0f8426	9	## Version 3.x, Copyright (C) 2004-2006, 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
adfe19db MHM	26	NVTYPE
	27	INT2PTR
	28	PTRV
	29	NUM2PTR
	30	PTR2IV
	31	PTR2UV
	32	PTR2NV
	33	PTR2ul
a745474a MHM	34	START_EXTERN_C
	35	END_EXTERN_C
	36	EXTERN_C
	37	STMT_START
	38	STMT_END
0d0f8426	39	XSRETURN
adfe19db MHM	40	/PL_\w+/
	41
	42	=implementation
	43
0d0f8426	44	#if { VERSION <= 5.004_05 }
adfe19db	45	/* Replace: 1 */
96ad942f MHM	46	# define PL_DBsingle DBsingle
	47	# define PL_DBsub DBsub
	48	# define PL_Sv Sv
	49	# define PL_compiling compiling
	50	# define PL_copline copline
	51	# define PL_curcop curcop
	52	# define PL_curstash curstash
	53	# define PL_debstash debstash
	54	# define PL_defgv defgv
	55	# define PL_diehook diehook
	56	# define PL_dirty dirty
	57	# define PL_dowarn dowarn
	58	# define PL_errgv errgv
	59	# define PL_hexdigit hexdigit
	60	# define PL_hints hints
	61	# define PL_na na
	62	# define PL_no_modify no_modify
	63	# define PL_perl_destruct_level perl_destruct_level
	64	# define PL_perldb perldb
	65	# define PL_ppaddr ppaddr
	66	# define PL_rsfp_filters rsfp_filters
	67	# define PL_rsfp rsfp
	68	# define PL_stack_base stack_base
	69	# define PL_stack_sp stack_sp
	70	# define PL_stdingv stdingv
	71	# define PL_sv_arenaroot sv_arenaroot
	72	# define PL_sv_no sv_no
	73	# define PL_sv_undef sv_undef
	74	# define PL_sv_yes sv_yes
	75	# define PL_tainted tainted
	76	# define PL_tainting tainting
adfe19db MHM	77	/* Replace: 0 */
	78	#endif
	79
62093c1c NC	80	#ifndef PERL_UNUSED_DECL
	81	# ifdef HASATTRIBUTE
	82	# if (defined(__GNUC__) && defined(__cplusplus)) \|\| defined(__INTEL_COMPILER)
	83	# define PERL_UNUSED_DECL
	84	# else
	85	# define PERL_UNUSED_DECL __attribute__((unused))
	86	# endif
adfe19db	87	# else
62093c1c	88	# define PERL_UNUSED_DECL
adfe19db	89	# endif
adfe19db MHM	90	#endif
adfe19db MHM	91
f2ab5a41 MHM	92	#ifndef PERL_UNUSED_ARG
	93	# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
	94	# include <note.h>
	95	# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
	96	# else
	97	# define PERL_UNUSED_ARG(x) ((void)x)
	98	# endif
	99	#endif
	100
	101	#ifndef PERL_UNUSED_VAR
	102	# define PERL_UNUSED_VAR(x) ((void)x)
	103	#endif
	104
	105	#ifndef PERL_UNUSED_CONTEXT
	106	# ifdef USE_ITHREADS
	107	# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
	108	# else
	109	# define PERL_UNUSED_CONTEXT
	110	# endif
	111	#endif
	112
	113	__UNDEFINED__ NOOP /EMPTY/(void)0
	114	__UNDEFINED__ dNOOP extern int /@unused@/ Perl___notused PERL_UNUSED_DECL
adfe19db MHM	115
	116	#ifndef NVTYPE
	117	# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
	118	# define NVTYPE long double
	119	# else
	120	# define NVTYPE double
	121	# endif
	122	typedef NVTYPE NV;
	123	#endif
	124
	125	#ifndef INT2PTR
	126
	127	# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
	128	# define PTRV UV
	129	# define INT2PTR(any,d) (any)(d)
	130	# else
	131	# if PTRSIZE == LONGSIZE
	132	# define PTRV unsigned long
	133	# else
	134	# define PTRV unsigned
	135	# endif
	136	# define INT2PTR(any,d) (any)(PTRV)(d)
	137	# endif
	138
	139	# define NUM2PTR(any,d) (any)(PTRV)(d)
	140	# define PTR2IV(p) INT2PTR(IV,p)
	141	# define PTR2UV(p) INT2PTR(UV,p)
	142	# define PTR2NV(p) NUM2PTR(NV,p)
	143
	144	# if PTRSIZE == LONGSIZE
	145	# define PTR2ul(p) (unsigned long)(p)
	146	# else
4a582685	147	# define PTR2ul(p) INT2PTR(unsigned long,p)
adfe19db MHM	148	# endif
	149
	150	#endif /* !INT2PTR */
	151
a745474a MHM	152	#undef START_EXTERN_C
	153	#undef END_EXTERN_C
	154	#undef EXTERN_C
	155	#ifdef __cplusplus
	156	# define START_EXTERN_C extern "C" {
	157	# define END_EXTERN_C }
	158	# define EXTERN_C extern "C"
	159	#else
	160	# define START_EXTERN_C
	161	# define END_EXTERN_C
	162	# define EXTERN_C extern
	163	#endif
	164
	165	#ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
	166	# if defined(__STRICT_ANSI__) && defined(PERL_GCC_PEDANTIC)
	167	# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
	168	# endif
	169	#endif
	170
	171	#undef STMT_START
	172	#undef STMT_END
	173	#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
	174	# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
	175	# define STMT_END )
	176	#else
	177	# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) \|\| defined(__sun__)) && !defined(__GNUC__)
	178	# define STMT_START if (1)
	179	# define STMT_END else (void)0
	180	# else
	181	# define STMT_START do
	182	# define STMT_END while (0)
	183	# endif
	184	#endif
	185
adfe19db MHM	186	__UNDEFINED__ boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
	187
	188	/* DEFSV appears first in 5.004_56 */
	189	__UNDEFINED__ DEFSV GvSV(PL_defgv)
	190	__UNDEFINED__ SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
	191
	192	/* Older perls (<=5.003) lack AvFILLp */
	193	__UNDEFINED__ AvFILLp AvFILL
	194
	195	__UNDEFINED__ ERRSV get_sv("@",FALSE)
	196
	197	__UNDEFINED__ newSVpvn(data,len) ((data) \
	198	? ((len) ? newSVpv((data), (len)) : newSVpv("", 0)) \
	199	: newSV(0))
	200
	201	/* Hint: gv_stashpvn
	202	* This function's backport doesn't support the length parameter, but
	203	* rather ignores it. Portability can only be ensured if the length
	204	* parameter is used for speed reasons, but the length can always be
	205	* correctly computed from the string argument.
	206	*/
	207
	208	__UNDEFINED__ gv_stashpvn(str,len,create) gv_stashpv(str,create)
	209
	210	/* Replace: 1 */
	211	__UNDEFINED__ get_cv perl_get_cv
	212	__UNDEFINED__ get_sv perl_get_sv
	213	__UNDEFINED__ get_av perl_get_av
	214	__UNDEFINED__ get_hv perl_get_hv
	215	/* Replace: 0 */
	216
adfe19db MHM	217	__UNDEFINED__ dUNDERBAR dNOOP
	218	__UNDEFINED__ UNDERBAR DEFSV
	219
	220	__UNDEFINED__ dAX I32 ax = MARK - PL_stack_base + 1
	221	__UNDEFINED__ dITEMS I32 items = SP - MARK
	222
9132e1a3 MHM	223	__UNDEFINED__ dXSTARG SV * targ = sv_newmortal()
9132e1a3 MHM	224
0d0f8426 MHM	225	__UNDEFINED__ dAXMARK I32 ax = POPMARK; \
	226	register SV ** const mark = PL_stack_base + ax++
	227
	228
	229	__UNDEFINED__ XSprePUSH (sp = PL_stack_base + ax - 1)
	230
	231	#if { VERSION < 5.005 }
	232	# undef XSRETURN
	233	# define XSRETURN(off) \
	234	STMT_START { \
	235	PL_stack_sp = PL_stack_base + ax + ((off) - 1); \
	236	return; \
	237	} STMT_END
	238	#endif
	239
f2ab5a41 MHM	240	__UNDEFINED__ PERL_ABS(x) ((x) < 0 ? -(x) : (x))
	241
	242	__UNDEFINED__ dVAR dNOOP
	243
	244	__UNDEFINED__ SVf "_"
	245
9132e1a3 MHM	246	=xsmisc
	247
	248	XS(XS_Devel__PPPort_dXSTARG); /* prototype */
	249	XS(XS_Devel__PPPort_dXSTARG)
	250	{
	251	dXSARGS;
	252	dXSTARG;
2dd69576	253	IV iv;
9132e1a3	254	SP -= items;
2dd69576	255	iv = SvIV(ST(0)) + 1;
9132e1a3 MHM	256	PUSHi(iv);
	257	XSRETURN(1);
	258	}
	259
0d0f8426 MHM	260	XS(XS_Devel__PPPort_dAXMARK); /* prototype */
	261	XS(XS_Devel__PPPort_dAXMARK)
	262	{
	263	dSP;
	264	dAXMARK;
	265	dITEMS;
	266	IV iv;
	267	SP -= items;
	268	iv = SvIV(ST(0)) - 1;
	269	PUSHs(sv_2mortal(newSViv(iv)));
	270	XSRETURN(1);
	271	}
	272
9132e1a3 MHM	273	=xsboot
	274
	275	newXS("Devel::PPPort::dXSTARG", XS_Devel__PPPort_dXSTARG, file);
0d0f8426	276	newXS("Devel::PPPort::dAXMARK", XS_Devel__PPPort_dAXMARK, file);
9132e1a3	277
adfe19db MHM	278	=xsubs
	279
	280	int
	281	gv_stashpvn(name, create)
	282	char *name
	283	I32 create
	284	CODE:
	285	RETVAL = gv_stashpvn(name, strlen(name), create) != NULL;
	286	OUTPUT:
	287	RETVAL
	288
	289	int
	290	get_sv(name, create)
	291	char *name
	292	I32 create
	293	CODE:
	294	RETVAL = get_sv(name, create) != NULL;
	295	OUTPUT:
	296	RETVAL
	297
	298	int
	299	get_av(name, create)
	300	char *name
	301	I32 create
	302	CODE:
	303	RETVAL = get_av(name, create) != NULL;
	304	OUTPUT:
	305	RETVAL
	306
	307	int
	308	get_hv(name, create)
	309	char *name
	310	I32 create
	311	CODE:
	312	RETVAL = get_hv(name, create) != NULL;
	313	OUTPUT:
	314	RETVAL
	315
	316	int
	317	get_cv(name, create)
	318	char *name
	319	I32 create
	320	CODE:
	321	RETVAL = get_cv(name, create) != NULL;
	322	OUTPUT:
	323	RETVAL
	324
	325	void
	326	newSVpvn()
	327	PPCODE:
	328	XPUSHs(newSVpvn("test", 4));
	329	XPUSHs(newSVpvn("test", 2));
	330	XPUSHs(newSVpvn("test", 0));
	331	XPUSHs(newSVpvn(NULL, 2));
	332	XPUSHs(newSVpvn(NULL, 0));
	333	XSRETURN(5);
	334
0d0f8426 MHM	335	void
	336	xsreturn(two)
	337	int two
	338	PPCODE:
	339	XPUSHs(newSVpvn("test1", 5));
	340	if (two)
	341	XPUSHs(newSVpvn("test2", 5));
	342	if (two)
	343	XSRETURN(2);
	344	else
	345	XSRETURN(1);
	346
adfe19db MHM	347	SV *
	348	PL_sv_undef()
	349	CODE:
	350	RETVAL = newSVsv(&PL_sv_undef);
	351	OUTPUT:
	352	RETVAL
	353
	354	SV *
	355	PL_sv_yes()
	356	CODE:
	357	RETVAL = newSVsv(&PL_sv_yes);
	358	OUTPUT:
	359	RETVAL
	360
	361	SV *
	362	PL_sv_no()
	363	CODE:
	364	RETVAL = newSVsv(&PL_sv_no);
	365	OUTPUT:
	366	RETVAL
	367
	368	int
	369	PL_na(string)
	370	char *string
	371	CODE:
	372	PL_na = strlen(string);
	373	RETVAL = PL_na;
	374	OUTPUT:
	375	RETVAL
	376
	377	SV*
	378	boolSV(value)
	379	int value
	380	CODE:
	381	RETVAL = newSVsv(boolSV(value));
	382	OUTPUT:
	383	RETVAL
	384
	385	SV*
	386	DEFSV()
	387	CODE:
	388	RETVAL = newSVsv(DEFSV);
	389	OUTPUT:
	390	RETVAL
	391
	392	int
	393	ERRSV()
	394	CODE:
	395	RETVAL = SvTRUE(ERRSV);
	396	OUTPUT:
	397	RETVAL
	398
	399	SV*
	400	UNDERBAR()
	401	CODE:
	402	{
	403	dUNDERBAR;
	404	RETVAL = newSVsv(UNDERBAR);
	405	}
	406	OUTPUT:
	407	RETVAL
	408
0d0f8426 MHM	409	void
	410	prepush()
	411	CODE:
	412	{
	413	dXSTARG;
	414	XSprePUSH;
	415	PUSHi(42);
	416	XSRETURN(1);
	417	}
	418
f2ab5a41 MHM	419	int
	420	PERL_ABS(a)
	421	int a
	422
	423	void
	424	SVf(x)
	425	SV *x
	426	PPCODE:
	427	#if { VERSION >= 5.004 }
	428	x = newSVpvf("[%"SVf"]", x);
	429	#endif
	430	XPUSHs(x);
	431	XSRETURN(1);
	432
	433	=tests plan => 42
adfe19db MHM	434
	435	use vars qw($my_sv @my_av %my_hv);
	436
	437	my @s = &Devel::PPPort::newSVpvn();
	438	ok(@s == 5);
	439	ok($s[0], "test");
	440	ok($s[1], "te");
	441	ok($s[2], "");
	442	ok(!defined($s[3]));
	443	ok(!defined($s[4]));
	444
	445	ok(!defined(&Devel::PPPort::PL_sv_undef()));
	446	ok(&Devel::PPPort::PL_sv_yes());
	447	ok(!&Devel::PPPort::PL_sv_no());
	448	ok(&Devel::PPPort::PL_na("abcd"), 4);
	449
	450	ok(&Devel::PPPort::boolSV(1));
	451	ok(!&Devel::PPPort::boolSV(0));
	452
	453	$_ = "Fred";
	454	ok(&Devel::PPPort::DEFSV(), "Fred");
	455	ok(&Devel::PPPort::UNDERBAR(), "Fred");
	456
0d0f8426 MHM	457	if ($] >= 5.009002) {
	458	eval q{
	459	my $_ = "Tony";
	460	ok(&Devel::PPPort::DEFSV(), "Fred");
	461	ok(&Devel::PPPort::UNDERBAR(), "Tony");
	462	};
	463	}
	464	else {
	465	ok(1);
	466	ok(1);
	467	}
	468
adfe19db MHM	469	eval { 1 };
	470	ok(!&Devel::PPPort::ERRSV());
	471	eval { cannot_call_this_one() };
	472	ok(&Devel::PPPort::ERRSV());
	473
	474	ok(&Devel::PPPort::gv_stashpvn('Devel::PPPort', 0));
	475	ok(!&Devel::PPPort::gv_stashpvn('does::not::exist', 0));
	476	ok(&Devel::PPPort::gv_stashpvn('does::not::exist', 1));
	477
	478	$my_sv = 1;
	479	ok(&Devel::PPPort::get_sv('my_sv', 0));
	480	ok(!&Devel::PPPort::get_sv('not_my_sv', 0));
	481	ok(&Devel::PPPort::get_sv('not_my_sv', 1));
	482
	483	@my_av = (1);
	484	ok(&Devel::PPPort::get_av('my_av', 0));
	485	ok(!&Devel::PPPort::get_av('not_my_av', 0));
	486	ok(&Devel::PPPort::get_av('not_my_av', 1));
	487
	488	%my_hv = (a=>1);
	489	ok(&Devel::PPPort::get_hv('my_hv', 0));
	490	ok(!&Devel::PPPort::get_hv('not_my_hv', 0));
	491	ok(&Devel::PPPort::get_hv('not_my_hv', 1));
	492
	493	sub my_cv { 1 };
	494	ok(&Devel::PPPort::get_cv('my_cv', 0));
	495	ok(!&Devel::PPPort::get_cv('not_my_cv', 0));
	496	ok(&Devel::PPPort::get_cv('not_my_cv', 1));
	497
9132e1a3	498	ok(Devel::PPPort::dXSTARG(42), 43);
0d0f8426 MHM	499	ok(Devel::PPPort::dAXMARK(4711), 4710);
	500
	501	ok(Devel::PPPort::prepush(), 42);
9132e1a3	502
0d0f8426 MHM	503	ok(join(':', Devel::PPPort::xsreturn(0)), 'test1');
0d0f8426 MHM	504	ok(join(':', Devel::PPPort::xsreturn(1)), 'test1:test2');
f2ab5a41 MHM	505
	506	ok(Devel::PPPort::PERL_ABS(42), 42);
	507	ok(Devel::PPPort::PERL_ABS(-13), 13);
	508
	509	ok(Devel::PPPort::SVf(42), $] >= 5.004 ? '[42]' : '42');
	510	ok(Devel::PPPort::SVf('abc'), $] >= 5.004 ? '[abc]' : 'abc');
	511