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

################################################################################
##
##  $Revision: 36 $
##  $Author: mhx $
##  $Date: 2006/05/22 00:51:01 +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
PERL_USE_GCC_BRACE_GROUPS
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

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

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