################################################################################
##
## $Revision: 38 $
## $Author: mhx $
## $Date: 2007/01/02 12:32:34 +0100 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2007, 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
=implementation
#ifndef PERL_UNUSED_DECL
# ifdef HASATTRIBUTE
# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
# define PERL_UNUSED_DECL
# else
# define PERL_UNUSED_DECL __attribute__((unused))
# endif
# else
# define PERL_UNUSED_DECL
# endif
#endif
#ifndef PERL_UNUSED_ARG
# if defined(lint) && defined(S_SPLINT_S) /* www.splint.org */
# include <note.h>
# define PERL_UNUSED_ARG(x) NOTE(ARGUNUSED(x))
# else
# define PERL_UNUSED_ARG(x) ((void)x)
# endif
#endif
#ifndef PERL_UNUSED_VAR
# define PERL_UNUSED_VAR(x) ((void)x)
#endif
#ifndef PERL_UNUSED_CONTEXT
# ifdef USE_ITHREADS
# define PERL_UNUSED_CONTEXT PERL_UNUSED_ARG(my_perl)
# else
# define PERL_UNUSED_CONTEXT
# endif
#endif
__UNDEFINED__ NOOP /*EMPTY*/(void)0
__UNDEFINED__ dNOOP extern int /*@unused@*/ Perl___notused PERL_UNUSED_DECL
#ifndef NVTYPE
# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
# define NVTYPE long double
# else
# define NVTYPE double
# endif
typedef NVTYPE NV;
#endif
#ifndef INT2PTR
# if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
# define PTRV UV
# define INT2PTR(any,d) (any)(d)
# else
# if PTRSIZE == LONGSIZE
# define PTRV unsigned long
# else
# define PTRV unsigned
# endif
# define INT2PTR(any,d) (any)(PTRV)(d)
# endif
# define NUM2PTR(any,d) (any)(PTRV)(d)
# define PTR2IV(p) INT2PTR(IV,p)
# define PTR2UV(p) INT2PTR(UV,p)
# define PTR2NV(p) NUM2PTR(NV,p)
# if PTRSIZE == LONGSIZE
# define PTR2ul(p) (unsigned long)(p)
# else
# define PTR2ul(p) INT2PTR(unsigned long,p)
# endif
#endif /* !INT2PTR */
#undef START_EXTERN_C
#undef END_EXTERN_C
#undef EXTERN_C
#ifdef __cplusplus
# define START_EXTERN_C extern "C" {
# define END_EXTERN_C }
# define EXTERN_C extern "C"
#else
# define START_EXTERN_C
# define END_EXTERN_C
# define EXTERN_C extern
#endif
#if defined(PERL_GCC_PEDANTIC)
# ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
# define PERL_GCC_BRACE_GROUPS_FORBIDDEN
# endif
#endif
#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
# ifndef PERL_USE_GCC_BRACE_GROUPS
# define PERL_USE_GCC_BRACE_GROUPS
# endif
#endif
#undef STMT_START
#undef STMT_END
#ifdef PERL_USE_GCC_BRACE_GROUPS
# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
# define STMT_END )
#else
# if defined(VOIDFLAGS) && (VOIDFLAGS) && (defined(sun) || defined(__sun__)) && !defined(__GNUC__)
# define STMT_START if (1)
# define STMT_END else (void)0
# else
# define STMT_START do
# define STMT_END while (0)
# endif
#endif
__UNDEFINED__ boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
/* DEFSV appears first in 5.004_56 */
__UNDEFINED__ DEFSV GvSV(PL_defgv)
__UNDEFINED__ SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
/* Older perls (<=5.003) lack AvFILLp */
__UNDEFINED__ AvFILLp AvFILL
__UNDEFINED__ ERRSV get_sv("@",FALSE)
__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*
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 => 38
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(&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');