dslinux/user/perl/ext/Devel/PPPort/parts/inc MY_CXT SvPV call cop exception format grok limits mPUSH magic misc newCONSTSUB newRV ppphbin ppphdoc ppphtest sv_xpvf threads uv version
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 17:59:18 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/ext/Devel/PPPort/parts/inc
In directory antilope:/tmp/cvs-serv17422/ext/Devel/PPPort/parts/inc
Added Files:
MY_CXT SvPV call cop exception format grok limits mPUSH magic
misc newCONSTSUB newRV ppphbin ppphdoc ppphtest sv_xpvf
threads uv version
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: cop ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:15 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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__
=implementation
#ifdef USE_ITHREADS
__UNDEFINED__ CopFILE(c) ((c)->cop_file)
__UNDEFINED__ CopFILEGV(c) (CopFILE(c) ? gv_fetchfile(CopFILE(c)) : Nullgv)
__UNDEFINED__ CopFILE_set(c,pv) ((c)->cop_file = savepv(pv))
__UNDEFINED__ CopFILESV(c) (CopFILE(c) ? GvSV(gv_fetchfile(CopFILE(c))) : Nullsv)
__UNDEFINED__ CopFILEAV(c) (CopFILE(c) ? GvAV(gv_fetchfile(CopFILE(c))) : Nullav)
__UNDEFINED__ CopSTASHPV(c) ((c)->cop_stashpv)
__UNDEFINED__ CopSTASHPV_set(c,pv) ((c)->cop_stashpv = ((pv) ? savepv(pv) : Nullch))
__UNDEFINED__ CopSTASH(c) (CopSTASHPV(c) ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv)
__UNDEFINED__ CopSTASH_set(c,hv) CopSTASHPV_set(c, (hv) ? HvNAME(hv) : Nullch)
__UNDEFINED__ CopSTASH_eq(c,hv) ((hv) && (CopSTASHPV(c) == HvNAME(hv) \
|| (CopSTASHPV(c) && HvNAME(hv) \
&& strEQ(CopSTASHPV(c), HvNAME(hv)))))
#else
__UNDEFINED__ CopFILEGV(c) ((c)->cop_filegv)
__UNDEFINED__ CopFILEGV_set(c,gv) ((c)->cop_filegv = (GV*)SvREFCNT_inc(gv))
__UNDEFINED__ CopFILE_set(c,pv) CopFILEGV_set((c), gv_fetchfile(pv))
__UNDEFINED__ CopFILESV(c) (CopFILEGV(c) ? GvSV(CopFILEGV(c)) : Nullsv)
__UNDEFINED__ CopFILEAV(c) (CopFILEGV(c) ? GvAV(CopFILEGV(c)) : Nullav)
__UNDEFINED__ CopFILE(c) (CopFILESV(c) ? SvPVX(CopFILESV(c)) : Nullch)
__UNDEFINED__ CopSTASH(c) ((c)->cop_stash)
__UNDEFINED__ CopSTASH_set(c,hv) ((c)->cop_stash = (hv))
__UNDEFINED__ CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch)
__UNDEFINED__ CopSTASHPV_set(c,pv) CopSTASH_set((c), gv_stashpv(pv,GV_ADD))
__UNDEFINED__ CopSTASH_eq(c,hv) (CopSTASH(c) == (hv))
#endif /* USE_ITHREADS */
=xsubs
char *
CopSTASHPV()
CODE:
RETVAL = CopSTASHPV(PL_curcop);
OUTPUT:
RETVAL
char *
CopFILE()
CODE:
RETVAL = CopFILE(PL_curcop);
OUTPUT:
RETVAL
=tests plan => 2
my $package;
{
package MyPackage;
$package = &Devel::PPPort::CopSTASHPV();
}
print "# $package\n";
ok($package, "MyPackage");
my $file = &Devel::PPPort::CopFILE();
print "# $file\n";
ok($file =~ /cop/i);
--- NEW FILE: limits ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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
PERL_UCHAR_MIN
PERL_UCHAR_MAX
PERL_USHORT_MIN
PERL_USHORT_MAX
PERL_SHORT_MAX
PERL_SHORT_MIN
PERL_UINT_MAX
PERL_UINT_MIN
PERL_INT_MAX
PERL_INT_MIN
PERL_ULONG_MAX
PERL_ULONG_MIN
PERL_LONG_MAX
PERL_LONG_MIN
PERL_UQUAD_MAX
PERL_UQUAD_MIN
PERL_QUAD_MAX
PERL_QUAD_MIN
IVSIZE
UVSIZE
IVTYPE
UVTYPE
=implementation
#ifdef I_LIMITS
# include <limits.h>
#endif
#ifndef PERL_UCHAR_MIN
# define PERL_UCHAR_MIN ((unsigned char)0)
#endif
#ifndef PERL_UCHAR_MAX
# ifdef UCHAR_MAX
# define PERL_UCHAR_MAX ((unsigned char)UCHAR_MAX)
# else
# ifdef MAXUCHAR
# define PERL_UCHAR_MAX ((unsigned char)MAXUCHAR)
# else
# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
# endif
# endif
#endif
#ifndef PERL_USHORT_MIN
# define PERL_USHORT_MIN ((unsigned short)0)
#endif
#ifndef PERL_USHORT_MAX
# ifdef USHORT_MAX
# define PERL_USHORT_MAX ((unsigned short)USHORT_MAX)
# else
# ifdef MAXUSHORT
# define PERL_USHORT_MAX ((unsigned short)MAXUSHORT)
# else
# ifdef USHRT_MAX
# define PERL_USHORT_MAX ((unsigned short)USHRT_MAX)
# else
# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
# endif
# endif
# endif
#endif
#ifndef PERL_SHORT_MAX
# ifdef SHORT_MAX
# define PERL_SHORT_MAX ((short)SHORT_MAX)
# else
# ifdef MAXSHORT /* Often used in <values.h> */
# define PERL_SHORT_MAX ((short)MAXSHORT)
# else
# ifdef SHRT_MAX
# define PERL_SHORT_MAX ((short)SHRT_MAX)
# else
# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
# endif
# endif
# endif
#endif
#ifndef PERL_SHORT_MIN
# ifdef SHORT_MIN
# define PERL_SHORT_MIN ((short)SHORT_MIN)
# else
# ifdef MINSHORT
# define PERL_SHORT_MIN ((short)MINSHORT)
# else
# ifdef SHRT_MIN
# define PERL_SHORT_MIN ((short)SHRT_MIN)
# else
# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
# endif
# endif
# endif
#endif
#ifndef PERL_UINT_MAX
# ifdef UINT_MAX
# define PERL_UINT_MAX ((unsigned int)UINT_MAX)
# else
# ifdef MAXUINT
# define PERL_UINT_MAX ((unsigned int)MAXUINT)
# else
# define PERL_UINT_MAX (~(unsigned int)0)
# endif
# endif
#endif
#ifndef PERL_UINT_MIN
# define PERL_UINT_MIN ((unsigned int)0)
#endif
#ifndef PERL_INT_MAX
# ifdef INT_MAX
# define PERL_INT_MAX ((int)INT_MAX)
# else
# ifdef MAXINT /* Often used in <values.h> */
# define PERL_INT_MAX ((int)MAXINT)
# else
# define PERL_INT_MAX ((int)(PERL_UINT_MAX >> 1))
# endif
# endif
#endif
#ifndef PERL_INT_MIN
# ifdef INT_MIN
# define PERL_INT_MIN ((int)INT_MIN)
# else
# ifdef MININT
# define PERL_INT_MIN ((int)MININT)
# else
# define PERL_INT_MIN (-PERL_INT_MAX - ((3 & -1) == 3))
# endif
# endif
#endif
#ifndef PERL_ULONG_MAX
# ifdef ULONG_MAX
# define PERL_ULONG_MAX ((unsigned long)ULONG_MAX)
# else
# ifdef MAXULONG
# define PERL_ULONG_MAX ((unsigned long)MAXULONG)
# else
# define PERL_ULONG_MAX (~(unsigned long)0)
# endif
# endif
#endif
#ifndef PERL_ULONG_MIN
# define PERL_ULONG_MIN ((unsigned long)0L)
#endif
#ifndef PERL_LONG_MAX
# ifdef LONG_MAX
# define PERL_LONG_MAX ((long)LONG_MAX)
# else
# ifdef MAXLONG
# define PERL_LONG_MAX ((long)MAXLONG)
# else
# define PERL_LONG_MAX ((long) (PERL_ULONG_MAX >> 1))
# endif
# endif
#endif
#ifndef PERL_LONG_MIN
# ifdef LONG_MIN
# define PERL_LONG_MIN ((long)LONG_MIN)
# else
# ifdef MINLONG
# define PERL_LONG_MIN ((long)MINLONG)
# else
# define PERL_LONG_MIN (-PERL_LONG_MAX - ((3 & -1) == 3))
# endif
# endif
#endif
#if defined(HAS_QUAD) && (defined(convex) || defined(uts))
# ifndef PERL_UQUAD_MAX
# ifdef ULONGLONG_MAX
# define PERL_UQUAD_MAX ((unsigned long long)ULONGLONG_MAX)
# else
# ifdef MAXULONGLONG
# define PERL_UQUAD_MAX ((unsigned long long)MAXULONGLONG)
# else
# define PERL_UQUAD_MAX (~(unsigned long long)0)
# endif
# endif
# endif
# ifndef PERL_UQUAD_MIN
# define PERL_UQUAD_MIN ((unsigned long long)0L)
# endif
# ifndef PERL_QUAD_MAX
# ifdef LONGLONG_MAX
# define PERL_QUAD_MAX ((long long)LONGLONG_MAX)
# else
# ifdef MAXLONGLONG
# define PERL_QUAD_MAX ((long long)MAXLONGLONG)
# else
# define PERL_QUAD_MAX ((long long) (PERL_UQUAD_MAX >> 1))
# endif
# endif
# endif
# ifndef PERL_QUAD_MIN
# ifdef LONGLONG_MIN
# define PERL_QUAD_MIN ((long long)LONGLONG_MIN)
# else
# ifdef MINLONGLONG
# define PERL_QUAD_MIN ((long long)MINLONGLONG)
# else
# define PERL_QUAD_MIN (-PERL_QUAD_MAX - ((3 & -1) == 3))
# endif
# endif
# endif
#endif
/* This is based on code from 5.003 perl.h */
#ifdef HAS_QUAD
# ifdef cray
__UNDEFINED__ IVTYPE int
__UNDEFINED__ IV_MIN PERL_INT_MIN
__UNDEFINED__ IV_MAX PERL_INT_MAX
__UNDEFINED__ UV_MIN PERL_UINT_MIN
__UNDEFINED__ UV_MAX PERL_UINT_MAX
# ifdef INTSIZE
__UNDEFINED__ IVSIZE INTSIZE
# endif
# else
# if defined(convex) || defined(uts)
__UNDEFINED__ IVTYPE long long
__UNDEFINED__ IV_MIN PERL_QUAD_MIN
__UNDEFINED__ IV_MAX PERL_QUAD_MAX
__UNDEFINED__ UV_MIN PERL_UQUAD_MIN
__UNDEFINED__ UV_MAX PERL_UQUAD_MAX
# ifdef LONGLONGSIZE
__UNDEFINED__ IVSIZE LONGLONGSIZE
# endif
# else
__UNDEFINED__ IVTYPE long
__UNDEFINED__ IV_MIN PERL_LONG_MIN
__UNDEFINED__ IV_MAX PERL_LONG_MAX
__UNDEFINED__ UV_MIN PERL_ULONG_MIN
__UNDEFINED__ UV_MAX PERL_ULONG_MAX
# ifdef LONGSIZE
__UNDEFINED__ IVSIZE LONGSIZE
# endif
# endif
# endif
__UNDEFINED__ IVSIZE 8
__UNDEFINED__ PERL_QUAD_MIN IV_MIN
__UNDEFINED__ PERL_QUAD_MAX IV_MAX
__UNDEFINED__ PERL_UQUAD_MIN UV_MIN
__UNDEFINED__ PERL_UQUAD_MAX UV_MAX
#else
__UNDEFINED__ IVTYPE long
__UNDEFINED__ IV_MIN PERL_LONG_MIN
__UNDEFINED__ IV_MAX PERL_LONG_MAX
__UNDEFINED__ UV_MIN PERL_ULONG_MIN
__UNDEFINED__ UV_MAX PERL_ULONG_MAX
#endif
#ifndef IVSIZE
# ifdef LONGSIZE
# define IVSIZE LONGSIZE
# else
# define IVSIZE 4 /* A bold guess, but the best we can make. */
# endif
#endif
__UNDEFINED__ UVTYPE unsigned IVTYPE
__UNDEFINED__ UVSIZE IVSIZE
=xsubs
IV
iv_size()
CODE:
RETVAL = IVSIZE == sizeof(IV);
OUTPUT:
RETVAL
IV
uv_size()
CODE:
RETVAL = UVSIZE == sizeof(UV);
OUTPUT:
RETVAL
IV
iv_type()
CODE:
RETVAL = sizeof(IVTYPE) == sizeof(IV);
OUTPUT:
RETVAL
IV
uv_type()
CODE:
RETVAL = sizeof(UVTYPE) == sizeof(UV);
OUTPUT:
RETVAL
=tests plan => 4
ok(&Devel::PPPort::iv_size());
ok(&Devel::PPPort::uv_size());
ok(&Devel::PPPort::iv_type());
ok(&Devel::PPPort::uv_type());
--- NEW FILE: exception ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:15 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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
dXCPT
XCPT_TRY_START
XCPT_TRY_END
XCPT_CATCH
XCPT_RETHROW
=implementation
#ifdef NO_XSLOCKS
# ifdef dJMPENV
# define dXCPT dJMPENV; int rEtV = 0
# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0)
# define XCPT_TRY_END JMPENV_POP;
# define XCPT_CATCH if (rEtV != 0)
# define XCPT_RETHROW JMPENV_JUMP(rEtV)
# else
# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0
# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0)
# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf);
# define XCPT_CATCH if (rEtV != 0)
# define XCPT_RETHROW Siglongjmp(top_env, rEtV)
# endif
#endif
=xsmisc
/* defined in module3.c */
int exception(int throw_e);
=xsubs
int
exception(throw_e)
int throw_e
OUTPUT:
RETVAL
=tests plan => 7
my $rv;
$Devel::PPPort::exception_caught = undef;
$rv = eval { &Devel::PPPort::exception(0) };
ok($@, '');
ok(defined $rv);
ok($rv, 42);
ok($Devel::PPPort::exception_caught, 0);
$Devel::PPPort::exception_caught = undef;
$rv = eval { &Devel::PPPort::exception(1) };
ok($@, "boo\n");
ok(not defined $rv);
ok($Devel::PPPort::exception_caught, 1);
--- NEW FILE: newCONSTSUB ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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
newCONSTSUB
=implementation
/* Hint: newCONSTSUB
* Returns a CV* as of perl-5.7.1. This return value is not supported
* by Devel::PPPort.
*/
/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
#if { VERSION < 5.004_63 } && { VERSION != 5.004_05 }
#if { NEED newCONSTSUB }
void
newCONSTSUB(HV *stash, char *name, SV *sv)
{
U32 oldhints = PL_hints;
HV *old_cop_stash = PL_curcop->cop_stash;
HV *old_curstash = PL_curstash;
line_t oldline = PL_curcop->cop_line;
PL_curcop->cop_line = PL_copline;
PL_hints &= ~HINT_BLOCK_SCOPE;
if (stash)
PL_curstash = PL_curcop->cop_stash = stash;
newSUB(
#if { VERSION < 5.003_22 }
start_subparse(),
#elif { VERSION == 5.003_22 }
start_subparse(0),
#else /* 5.003_23 onwards */
start_subparse(FALSE, 0),
#endif
newSVOP(OP_CONST, 0, newSVpv(name,0)),
newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
);
PL_hints = oldhints;
PL_curcop->cop_stash = old_cop_stash;
PL_curstash = old_curstash;
PL_curcop->cop_line = oldline;
}
#endif
#endif
=xsinit
#define NEED_newCONSTSUB
=xsmisc
void call_newCONSTSUB_1(void)
{
#ifdef PERL_NO_GET_CONTEXT
dTHX;
#endif
newCONSTSUB(gv_stashpv("Devel::PPPort", FALSE), "test_value_1", newSViv(1));
}
extern void call_newCONSTSUB_2(void);
extern void call_newCONSTSUB_3(void);
=xsubs
void
call_newCONSTSUB_1()
void
call_newCONSTSUB_2()
void
call_newCONSTSUB_3()
=tests plan => 3
&Devel::PPPort::call_newCONSTSUB_1();
ok(&Devel::PPPort::test_value_1(), 1);
&Devel::PPPort::call_newCONSTSUB_2();
ok(&Devel::PPPort::test_value_2(), 2);
&Devel::PPPort::call_newCONSTSUB_3();
ok(&Devel::PPPort::test_value_3(), 3);
--- NEW FILE: ppphdoc ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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
=dontwarn
NEED_function
NEED_function_GLOBAL
DPPP_NAMESPACE
=implementation
=pod
=head1 NAME
ppport.h - Perl/Pollution/Portability version __VERSION__
=head1 SYNOPSIS
perl ppport.h [options] [source files]
Searches current directory for files if no [source files] are given
--help show short help
--patch=file write one patch file with changes
--copy=suffix write changed copies with suffix
--diff=program use diff program and options
--compat-version=version provide compatibility with Perl version
--cplusplus accept C++ comments
--quiet don't output anything except fatal errors
--nodiag don't show diagnostics
--nohints don't show hints
--nochanges don't suggest changes
--nofilter don't filter input files
--list-provided list provided API
--list-unsupported list unsupported API
--api-info=name show Perl API portability information
=head1 COMPATIBILITY
This version of F<ppport.h> is designed to support operation with Perl
installations back to __MIN_PERL__, and has been tested up to __MAX_PERL__.
=head1 OPTIONS
=head2 --help
Display a brief usage summary.
=head2 --patch=I<file>
If this option is given, a single patch file will be created if
any changes are suggested. This requires a working diff program
to be installed on your system.
=head2 --copy=I<suffix>
If this option is given, a copy of each file will be saved with
the given suffix that contains the suggested changes. This does
not require any external programs.
If neither C<--patch> or C<--copy> are given, the default is to
simply print the diffs for each file. This requires either
C<Text::Diff> or a C<diff> program to be installed.
=head2 --diff=I<program>
Manually set the diff program and options to use. The default
is to use C<Text::Diff>, when installed, and output unified
context diffs.
=head2 --compat-version=I<version>
Tell F<ppport.h> to check for compatibility with the given
Perl version. The default is to check for compatibility with Perl
version __MIN_PERL__. You can use this option to reduce the output
of F<ppport.h> if you intend to be backward compatible only
up to a certain Perl version.
=head2 --cplusplus
Usually, F<ppport.h> will detect C++ style comments and
replace them with C style comments for portability reasons.
Using this option instructs F<ppport.h> to leave C++
comments untouched.
=head2 --quiet
Be quiet. Don't print anything except fatal errors.
=head2 --nodiag
Don't output any diagnostic messages. Only portability
alerts will be printed.
=head2 --nohints
Don't output any hints. Hints often contain useful portability
notes.
=head2 --nochanges
Don't suggest any changes. Only give diagnostic output and hints
unless these are also deactivated.
=head2 --nofilter
Don't filter the list of input files. By default, files not looking
like source code (i.e. not *.xs, *.c, *.cc, *.cpp or *.h) are skipped.
=head2 --list-provided
Lists the API elements for which compatibility is provided by
F<ppport.h>. Also lists if it must be explicitly requested,
if it has dependencies, and if there are hints for it.
=head2 --list-unsupported
Lists the API elements that are known not to be supported by
F<ppport.h> and below which version of Perl they probably
won't be available or work.
=head2 --api-info=I<name>
Show portability information for API elements matching I<name>.
If I<name> is surrounded by slashes, it is interpreted as a regular
expression.
=head1 DESCRIPTION
In order for a Perl extension (XS) module to be as portable as possible
across differing versions of Perl itself, certain steps need to be taken.
=over 4
=item *
Including this header is the first major one. This alone will give you
access to a large part of the Perl API that hasn't been available in
earlier Perl releases. Use
perl ppport.h --list-provided
to see which API elements are provided by ppport.h.
=item *
You should avoid using deprecated parts of the API. For example, using
global Perl variables without the C<PL_> prefix is deprecated. Also,
some API functions used to have a C<perl_> prefix. Using this form is
also deprecated. You can safely use the supported API, as F<ppport.h>
will provide wrappers for older Perl versions.
=item *
If you use one of a few functions that were not present in earlier
versions of Perl, and that can't be provided using a macro, you have
to explicitly request support for these functions by adding one or
more C<#define>s in your source code before the inclusion of F<ppport.h>.
These functions will be marked C<explicit> in the list shown by
C<--list-provided>.
Depending on whether you module has a single or multiple files that
use such functions, you want either C<static> or global variants.
For a C<static> function, use:
#define NEED_function
For a global function, use:
#define NEED_function_GLOBAL
Note that you mustn't have more than one global request for one
function in your project.
__EXPLICIT_API__
To avoid namespace conflicts, you can change the namespace of the
explicitly exported functions using the C<DPPP_NAMESPACE> macro.
Just C<#define> the macro before including C<ppport.h>:
#define DPPP_NAMESPACE MyOwnNamespace_
#include "ppport.h"
The default namespace is C<DPPP_>.
=back
The good thing is that most of the above can be checked by running
F<ppport.h> on your source code. See the next section for
details.
=head1 EXAMPLES
To verify whether F<ppport.h> is needed for your module, whether you
should make any changes to your code, and whether any special defines
should be used, F<ppport.h> can be run as a Perl script to check your
source code. Simply say:
perl ppport.h
The result will usually be a list of patches suggesting changes
that should at least be acceptable, if not necessarily the most
efficient solution, or a fix for all possible problems.
If you know that your XS module uses features only available in
newer Perl releases, if you're aware that it uses C++ comments,
and if you want all suggestions as a single patch file, you could
use something like this:
perl ppport.h --compat-version=5.6.0 --cplusplus --patch=test.diff
If you only want your code to be scanned without any suggestions
for changes, use:
perl ppport.h --nochanges
You can specify a different C<diff> program or options, using
the C<--diff> option:
perl ppport.h --diff='diff -C 10'
This would output context diffs with 10 lines of context.
To display portability information for the C<newSVpvn> function,
use:
perl ppport.h --api-info=newSVpvn
Since the argument to C<--api-info> can be a regular expression,
you can use
perl ppport.h --api-info=/_nomg$/
to display portability information for all C<_nomg> functions or
perl ppport.h --api-info=/./
to display information for all known API elements.
=head1 BUGS
If this version of F<ppport.h> is causing failure during
the compilation of this module, please check if newer versions
of either this module or C<Devel::PPPort> are available on CPAN
before sending a bug report.
If F<ppport.h> was generated using the latest version of
C<Devel::PPPort> and is causing failure of this module, please
file a bug report using the CPAN Request Tracker at L<http://rt.cpan.org/>.
Please include the following information:
=over 4
=item 1.
The complete output from running "perl -V"
=item 2.
This file.
=item 3.
The name and version of the module you were trying to build.
=item 4.
A full log of the build that failed.
=item 5.
Any other information that you think could be relevant.
=back
For the latest version of this code, please get the C<Devel::PPPort>
module from CPAN.
=head1 COPYRIGHT
Version 3.x, Copyright (c) 2004-2005, 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.
=head1 SEE ALSO
See L<Devel::PPPort>.
--- NEW FILE: misc ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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_GCC_BRACE_GROUPS_FORBIDDEN
NVTYPE
INT2PTR
PTRV
NUM2PTR
PTR2IV
PTR2UV
PTR2NV
PTR2ul
START_EXTERN_C
END_EXTERN_C
EXTERN_C
STMT_START
STMT_END
/PL_\w+/
=implementation
#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
/* 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
__UNDEFINED__ NOOP (void)0
__UNDEFINED__ dNOOP extern int 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 */
#ifdef HAS_MEMCMP
__UNDEFINED__ memNE(s1,s2,l) (memcmp(s1,s2,l))
__UNDEFINED__ memEQ(s1,s2,l) (!memcmp(s1,s2,l))
#else
__UNDEFINED__ memNE(s1,s2,l) (bcmp(s1,s2,l))
__UNDEFINED__ memEQ(s1,s2,l) (!bcmp(s1,s2,l))
#endif
__UNDEFINED__ MoveD(s,d,n,t) memmove((char*)(d),(char*)(s), (n) * sizeof(t))
__UNDEFINED__ CopyD(s,d,n,t) memcpy((char*)(d),(char*)(s), (n) * sizeof(t))
#ifdef HAS_MEMSET
__UNDEFINED__ ZeroD(d,n,t) memzero((char*)(d), (n) * sizeof(t))
#else
__UNDEFINED__ ZeroD(d,n,t) ((void)memzero((char*)(d), (n) * sizeof(t)),d)
#endif
__UNDEFINED__ Poison(d,n,t) (void)memset((char*)(d), 0xAB, (n) * sizeof(t))
__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()
=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);
}
=xsboot
newXS("Devel::PPPort::dXSTARG", XS_Devel__PPPort_dXSTARG, 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);
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
=tests plan => 32
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");
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);
--- NEW FILE: newRV ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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
newRV_inc
newRV_noinc
=implementation
__UNDEFINED__ newRV_inc(sv) newRV(sv) /* Replace */
#ifndef newRV_noinc
#if { NEED newRV_noinc }
SV *
newRV_noinc(SV *sv)
{
SV *rv = (SV *)newRV(sv);
SvREFCNT_dec(sv);
return rv;
}
#endif
#endif
=xsinit
#define NEED_newRV_noinc
=xsubs
U32
newRV_inc_REFCNT()
PREINIT:
SV *sv, *rv;
CODE:
sv = newSViv(42);
rv = newRV_inc(sv);
SvREFCNT_dec(sv);
RETVAL = SvREFCNT(sv);
sv_2mortal(rv);
OUTPUT:
RETVAL
U32
newRV_noinc_REFCNT()
PREINIT:
SV *sv, *rv;
CODE:
sv = newSViv(42);
rv = newRV_noinc(sv);
RETVAL = SvREFCNT(sv);
sv_2mortal(rv);
OUTPUT:
RETVAL
=tests plan => 2
ok(&Devel::PPPort::newRV_inc_REFCNT, 1);
ok(&Devel::PPPort::newRV_noinc_REFCNT, 1);
--- NEW FILE: sv_xpvf ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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
vnewSVpvf
sv_vcatpvf
sv_vsetpvf
sv_catpvf_mg
sv_catpvf_mg_nocontext
sv_vcatpvf_mg
sv_setpvf_mg
sv_setpvf_mg_nocontext
sv_vsetpvf_mg
=implementation
#if { VERSION >= 5.004 } && !defined(vnewSVpvf)
#if { NEED vnewSVpvf }
SV *
vnewSVpvf(pTHX_ const char *pat, va_list *args)
{
register SV *sv = newSV(0);
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
return sv;
}
#endif
#endif
/* sv_vcatpvf depends on sv_vcatpvfn */
#if { VERSION >= 5.004 } && !defined(sv_vcatpvf)
# define sv_vcatpvf(sv, pat, args) sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
#endif
/* sv_vsetpvf depends on sv_vsetpvfn */
#if { VERSION >= 5.004 } && !defined(sv_vsetpvf)
# define sv_vsetpvf(sv, pat, args) sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*))
#endif
/* sv_catpvf_mg depends on sv_vcatpvfn, sv_catpvf_mg_nocontext */
#if { VERSION >= 5.004 } && !defined(sv_catpvf_mg)
#if { NEED sv_catpvf_mg }
void
sv_catpvf_mg(pTHX_ SV *sv, const char *pat, ...)
{
va_list args;
va_start(args, pat);
sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
/* sv_catpvf_mg_nocontext depends on sv_vcatpvfn */
#ifdef PERL_IMPLICIT_CONTEXT
#if { VERSION >= 5.004 } && !defined(sv_catpvf_mg_nocontext)
#if { NEED sv_catpvf_mg_nocontext }
void
sv_catpvf_mg_nocontext(SV *sv, const char *pat, ...)
{
dTHX;
va_list args;
va_start(args, pat);
sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
#endif
#ifndef sv_catpvf_mg
# ifdef PERL_IMPLICIT_CONTEXT
# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
# else
# define sv_catpvf_mg Perl_sv_catpvf_mg
# endif
#endif
/* sv_vcatpvf_mg depends on sv_vcatpvfn */
#if { VERSION >= 5.004 } && !defined(sv_vcatpvf_mg)
# define sv_vcatpvf_mg(sv, pat, args) \
STMT_START { \
sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
SvSETMAGIC(sv); \
} STMT_END
#endif
/* sv_setpvf_mg depends on sv_vsetpvfn, sv_setpvf_mg_nocontext */
#if { VERSION >= 5.004 } && !defined(sv_setpvf_mg)
#if { NEED sv_setpvf_mg }
void
sv_setpvf_mg(pTHX_ SV *sv, const char *pat, ...)
{
va_list args;
va_start(args, pat);
sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
/* sv_setpvf_mg_nocontext depends on sv_vsetpvfn */
#ifdef PERL_IMPLICIT_CONTEXT
#if { VERSION >= 5.004 } && !defined(sv_setpvf_mg_nocontext)
#if { NEED sv_setpvf_mg_nocontext }
void
sv_setpvf_mg_nocontext(SV *sv, const char *pat, ...)
{
dTHX;
va_list args;
va_start(args, pat);
sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
SvSETMAGIC(sv);
va_end(args);
}
#endif
#endif
#endif
#ifndef sv_setpvf_mg
# ifdef PERL_IMPLICIT_CONTEXT
# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
# else
# define sv_setpvf_mg Perl_sv_setpvf_mg
# endif
#endif
/* sv_vsetpvf_mg depends on sv_vsetpvfn */
#if { VERSION >= 5.004 } && !defined(sv_vsetpvf_mg)
# define sv_vsetpvf_mg(sv, pat, args) \
STMT_START { \
sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); \
SvSETMAGIC(sv); \
} STMT_END
#endif
=xsinit
#define NEED_vnewSVpvf
#define NEED_sv_catpvf_mg
#define NEED_sv_catpvf_mg_nocontext
#define NEED_sv_setpvf_mg
#define NEED_sv_setpvf_mg_nocontext
=xsmisc
static SV * test_vnewSVpvf(pTHX_ const char *pat, ...)
{
SV *sv;
va_list args;
va_start(args, pat);
#if { VERSION >= 5.004 }
sv = vnewSVpvf(pat, &args);
#else
sv = newSVpv(pat, 0);
#endif
va_end(args);
return sv;
}
static void test_sv_vcatpvf(pTHX_ SV *sv, const char *pat, ...)
{
va_list args;
va_start(args, pat);
#if { VERSION >= 5.004 }
sv_vcatpvf(sv, pat, &args);
#else
sv_catpv(sv, pat);
#endif
va_end(args);
}
static void test_sv_vsetpvf(pTHX_ SV *sv, const char *pat, ...)
{
va_list args;
va_start(args, pat);
#if { VERSION >= 5.004 }
sv_vsetpvf(sv, pat, &args);
#else
sv_setpv(sv, pat);
#endif
va_end(args);
}
=xsubs
SV *
vnewSVpvf()
CODE:
RETVAL = test_vnewSVpvf(aTHX_ "%s-%d", "Perl", 42);
OUTPUT:
RETVAL
SV *
sv_vcatpvf(sv)
SV *sv
CODE:
RETVAL = newSVsv(sv);
test_sv_vcatpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42);
OUTPUT:
RETVAL
SV *
sv_vsetpvf(sv)
SV *sv
CODE:
RETVAL = newSVsv(sv);
test_sv_vsetpvf(aTHX_ RETVAL, "%s-%d", "Perl", 42);
OUTPUT:
RETVAL
void
sv_catpvf_mg(sv)
SV *sv
CODE:
#if { VERSION >= 5.004 }
sv_catpvf_mg(sv, "%s-%d", "Perl", 42);
#endif
void
Perl_sv_catpvf_mg(sv)
SV *sv
CODE:
#if { VERSION >= 5.004 }
Perl_sv_catpvf_mg(aTHX_ sv, "%s-%d", "-Perl", 43);
#endif
void
sv_catpvf_mg_nocontext(sv)
SV *sv
CODE:
#if { VERSION >= 5.004 }
#ifdef PERL_IMPLICIT_CONTEXT
sv_catpvf_mg_nocontext(sv, "%s-%d", "-Perl", 44);
#else
sv_catpvf_mg(sv, "%s-%d", "-Perl", 44);
#endif
#endif
void
sv_setpvf_mg(sv)
SV *sv
CODE:
#if { VERSION >= 5.004 }
sv_setpvf_mg(sv, "%s-%d", "mhx", 42);
#endif
void
Perl_sv_setpvf_mg(sv)
SV *sv
CODE:
#if { VERSION >= 5.004 }
Perl_sv_setpvf_mg(aTHX_ sv, "%s-%d", "foo", 43);
#endif
void
sv_setpvf_mg_nocontext(sv)
SV *sv
CODE:
#if { VERSION >= 5.004 }
#ifdef PERL_IMPLICIT_CONTEXT
sv_setpvf_mg_nocontext(sv, "%s-%d", "bar", 44);
#else
sv_setpvf_mg(sv, "%s-%d", "bar", 44);
#endif
#endif
=tests plan => 9
use Tie::Hash;
my %h;
tie %h, 'Tie::StdHash';
$h{foo} = 'foo-';
$h{bar} = '';
ok(&Devel::PPPort::vnewSVpvf(), $] >= 5.004 ? 'Perl-42' : '%s-%d');
ok(&Devel::PPPort::sv_vcatpvf('1-2-3-'), $] >= 5.004 ? '1-2-3-Perl-42' : '1-2-3-%s-%d');
ok(&Devel::PPPort::sv_vsetpvf('1-2-3-'), $] >= 5.004 ? 'Perl-42' : '%s-%d');
&Devel::PPPort::sv_catpvf_mg($h{foo});
ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42' : 'foo-');
&Devel::PPPort::Perl_sv_catpvf_mg($h{foo});
ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43' : 'foo-');
&Devel::PPPort::sv_catpvf_mg_nocontext($h{foo});
ok($h{foo}, $] >= 5.004 ? 'foo-Perl-42-Perl-43-Perl-44' : 'foo-');
&Devel::PPPort::sv_setpvf_mg($h{bar});
ok($h{bar}, $] >= 5.004 ? 'mhx-42' : '');
&Devel::PPPort::Perl_sv_setpvf_mg($h{bar});
ok($h{bar}, $] >= 5.004 ? 'foo-43' : '');
&Devel::PPPort::sv_setpvf_mg_nocontext($h{bar});
ok($h{bar}, $] >= 5.004 ? 'bar-44' : '');
--- NEW FILE: format ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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
/^#\s*define\s+(\w+)/
=implementation
#ifndef IVdf
# if IVSIZE == LONGSIZE
# define IVdf "ld"
# define UVuf "lu"
# define UVof "lo"
# define UVxf "lx"
# define UVXf "lX"
# else
# if IVSIZE == INTSIZE
# define IVdf "d"
# define UVuf "u"
# define UVof "o"
# define UVxf "x"
# define UVXf "X"
# endif
# endif
#endif
#ifndef NVef
# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
# define NVef PERL_PRIeldbl
# define NVff PERL_PRIfldbl
# define NVgf PERL_PRIgldbl
# else
# define NVef "e"
# define NVff "f"
# define NVgf "g"
# endif
#endif
--- NEW FILE: uv ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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
sv_setuv
newSVuv
__UNDEFINED__
=implementation
#ifndef sv_setuv
# define sv_setuv(sv, uv) \
STMT_START { \
UV TeMpUv = uv; \
if (TeMpUv <= IV_MAX) \
sv_setiv(sv, TeMpUv); \
else \
sv_setnv(sv, (double)TeMpUv); \
} STMT_END
#endif
#ifndef newSVuv
# define newSVuv(uv) ((uv) <= IV_MAX ? newSViv((IV)uv) : newSVnv((NV)uv))
#endif
__UNDEFINED__ sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv)))
__UNDEFINED__ SvUVX(sv) ((UV)SvIVX(sv))
__UNDEFINED__ SvUVXx(sv) SvUVX(sv)
__UNDEFINED__ SvUV(sv) (SvIOK(sv) ? SvUVX(sv) : sv_2uv(sv))
__UNDEFINED__ SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv))
/* Hint: sv_uv
* Always use the SvUVx() macro instead of sv_uv().
*/
__UNDEFINED__ sv_uv(sv) SvUVx(sv)
__UNDEFINED__ XST_mUV(i,v) (ST(i) = sv_2mortal(newSVuv(v)) )
__UNDEFINED__ XSRETURN_UV(v) STMT_START { XST_mUV(0,v); XSRETURN(1); } STMT_END
__UNDEFINED__ PUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); PUSHTARG; } STMT_END
__UNDEFINED__ XPUSHu(u) STMT_START { sv_setuv(TARG, (UV)(u)); XPUSHTARG; } STMT_END
=xsubs
SV *
sv_setuv(uv)
UV uv
CODE:
RETVAL = newSViv(1);
sv_setuv(RETVAL, uv);
OUTPUT:
RETVAL
SV *
newSVuv(uv)
UV uv
CODE:
RETVAL = newSVuv(uv);
OUTPUT:
RETVAL
UV
sv_2uv(sv)
SV *sv
CODE:
RETVAL = sv_2uv(sv);
OUTPUT:
RETVAL
UV
SvUVx(sv)
SV *sv
CODE:
sv--;
RETVAL = SvUVx(++sv);
OUTPUT:
RETVAL
void
XSRETURN_UV()
PPCODE:
XSRETURN_UV(42);
void
PUSHu()
PREINIT:
dTARG;
PPCODE:
TARG = sv_newmortal();
EXTEND(SP, 1);
PUSHu(42);
XSRETURN(1);
void
XPUSHu()
PREINIT:
dTARG;
PPCODE:
TARG = sv_newmortal();
XPUSHu(43);
XSRETURN(1);
=tests plan => 10
ok(&Devel::PPPort::sv_setuv(42), 42);
ok(&Devel::PPPort::newSVuv(123), 123);
ok(&Devel::PPPort::sv_2uv("4711"), 4711);
ok(&Devel::PPPort::sv_2uv("1735928559"), 1735928559);
ok(&Devel::PPPort::SvUVx("1735928559"), 1735928559);
ok(&Devel::PPPort::SvUVx(1735928559), 1735928559);
ok(&Devel::PPPort::SvUVx(0xdeadbeef), 0xdeadbeef);
ok(&Devel::PPPort::XSRETURN_UV(), 42);
ok(&Devel::PPPort::PUSHu(), 42);
ok(&Devel::PPPort::XPUSHu(), 43);
--- NEW FILE: ppphbin ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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
=implementation
=cut
use strict;
my %opt = (
quiet => 0,
diag => 1,
hints => 1,
changes => 1,
cplusplus => 0,
filter => 1,
);
my($ppport) = $0 =~ /([\w.]+)$/;
my $LF = '(?:\r\n|[\r\n])'; # line feed
my $HS = "[ \t]"; # horizontal whitespace
eval {
require Getopt::Long;
Getopt::Long::GetOptions(\%opt, qw(
help quiet diag! filter! hints! changes! cplusplus
patch=s copy=s diff=s compat-version=s
list-provided list-unsupported api-info=s
)) or usage();
};
if ($@ and grep /^-/, @ARGV) {
usage() if "@ARGV" =~ /^--?h(?:elp)?$/;
die "Getopt::Long not found. Please don't use any options.\n";
}
usage() if $opt{help};
if (exists $opt{'compat-version'}) {
my($r,$v,$s) = eval { parse_version($opt{'compat-version'}) };
if ($@) {
die "Invalid version number format: '$opt{'compat-version'}'\n";
}
die "Only Perl 5 is supported\n" if $r != 5;
die "Invalid version number: $opt{'compat-version'}\n" if $v >= 1000 || $s >= 1000;
$opt{'compat-version'} = sprintf "%d.%03d%03d", $r, $v, $s;
}
else {
$opt{'compat-version'} = 5;
}
# Never use C comments in this file!!!!!
my $ccs = '/'.'*';
my $cce = '*'.'/';
my $rccs = quotemeta $ccs;
my $rcce = quotemeta $cce;
my %API = map { /^(\w+)\|([^|]*)\|([^|]*)\|(\w*)$/
? ( $1 => {
($2 ? ( base => $2 ) : ()),
($3 ? ( todo => $3 ) : ()),
(index($4, 'v') >= 0 ? ( varargs => 1 ) : ()),
(index($4, 'p') >= 0 ? ( provided => 1 ) : ()),
(index($4, 'n') >= 0 ? ( nothxarg => 1 ) : ()),
} )
: die "invalid spec: $_" } qw(
__PERL_API__
);
if (exists $opt{'list-unsupported'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{todo};
print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
}
exit 0;
}
# Scan for possible replacement candidates
my(%replace, %need, %hints, %depends);
my $replace = 0;
my $hint = '';
while (<DATA>) {
if ($hint) {
if (m{^\s*\*\s(.*?)\s*$}) {
$hints{$hint} ||= ''; # suppress warning with older perls
$hints{$hint} .= "$1\n";
}
else {
$hint = '';
}
}
$hint = $1 if m{^\s*$rccs\sHint:\s+(\w+)\s*$};
$replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$};
$replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)};
$replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce};
$replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$};
if (m{^\s*$rccs\s+(\w+)\s+depends\s+on\s+(\w+(\s*,\s*\w+)*)\s+$rcce\s*$}) {
push @{$depends{$1}}, map { s/\s+//g; $_ } split /,/, $2;
}
$need{$1} = 1 if m{^#if\s+defined\(NEED_(\w+)(?:_GLOBAL)?\)};
}
if (exists $opt{'api-info'}) {
my $f;
my $count = 0;
my $match = $opt{'api-info'} =~ m!^/(.*)/$! ? $1 : "^\Q$opt{'api-info'}\E\$";
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $f =~ /$match/;
print "\n=== $f ===\n\n";
my $info = 0;
if ($API{$f}{base} || $API{$f}{todo}) {
my $base = format_version($API{$f}{base} || $API{$f}{todo});
print "Supported at least starting from perl-$base.\n";
$info++;
}
if ($API{$f}{provided}) {
my $todo = $API{$f}{todo} ? format_version($API{$f}{todo}) : "__MIN_PERL__";
print "Support by $ppport provided back to perl-$todo.\n";
print "Support needs to be explicitly requested by NEED_$f.\n" if exists $need{$f};
print "Depends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f};
print "$hints{$f}" if exists $hints{$f};
$info++;
}
unless ($info) {
print "No portability information available.\n";
}
$count++;
}
if ($count > 0) {
print "\n";
}
else {
print "Found no API matching '$opt{'api-info'}'.\n";
}
exit 0;
}
if (exists $opt{'list-provided'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{provided};
my @flags;
push @flags, 'explicit' if exists $need{$f};
push @flags, 'depend' if exists $depends{$f};
push @flags, 'hint' if exists $hints{$f};
my $flags = @flags ? ' ['.join(', ', @flags).']' : '';
print "$f$flags\n";
}
exit 0;
}
my @files;
my @srcext = qw( xs c h cc cpp );
my $srcext = join '|', @srcext;
if (@ARGV) {
my %seen;
@files = grep { -f && !exists $seen{$_} } map { glob $_ } @ARGV;
}
else {
eval {
require File::Find;
File::Find::find(sub {
$File::Find::name =~ /\.($srcext)$/i
and push @files, $File::Find::name;
}, '.');
};
if ($@) {
@files = map { glob "*.$_" } @srcext;
}
}
if (!@ARGV || $opt{filter}) {
my(@in, @out);
my %xsc = map { /(.*)\.xs$/ ? ("$1.c" => 1, "$1.cc" => 1) : () } @files;
for (@files) {
my $out = exists $xsc{$_} || /\b\Q$ppport\E$/i || !/\.($srcext)$/i;
push @{ $out ? \@out : \@in }, $_;
}
if (@ARGV && @out) {
warning("Skipping the following files (use --nofilter to avoid this):\n| ", join "\n| ", @out);
}
@files = @in;
}
unless (@files) {
die "No input files given!\n";
}
my(%files, %global, %revreplace);
%revreplace = reverse %replace;
my $filename;
my $patch_opened = 0;
for $filename (@files) {
unless (open IN, "<$filename") {
warn "Unable to read from $filename: $!\n";
next;
}
info("Scanning $filename ...");
my $c = do { local $/; <IN> };
close IN;
my %file = (orig => $c, changes => 0);
# temporarily remove C comments from the code
my @ccom;
$c =~ s{
(
[^"'/]+
|
(?:"[^"\\]*(?:\\.[^"\\]*)*" [^"'/]*)+
|
(?:'[^'\\]*(?:\\.[^'\\]*)*' [^"'/]*)+
)
|
(/ (?:
\*[^*]*\*+(?:[^$ccs][^*]*\*+)* /
|
/[^\r\n]*
))
}{
defined $2 and push @ccom, $2;
defined $1 ? $1 : "$ccs$#ccom$cce";
}egsx;
$file{ccom} = \@ccom;
$file{code} = $c;
$file{has_inc_ppport} = ($c =~ /#.*include.*\Q$ppport\E/);
my $func;
for $func (keys %API) {
my $match = $func;
$match .= "|$revreplace{$func}" if exists $revreplace{$func};
if ($c =~ /\b(?:Perl_)?($match)\b/) {
$file{uses_replace}{$1}++ if exists $revreplace{$func} && $1 eq $revreplace{$func};
$file{uses_Perl}{$func}++ if $c =~ /\bPerl_$func\b/;
if (exists $API{$func}{provided}) {
if (!exists $API{$func}{base} || $API{$func}{base} > $opt{'compat-version'}) {
$file{uses}{$func}++;
my @deps = rec_depend($func);
if (@deps) {
$file{uses_deps}{$func} = \@deps;
for (@deps) {
$file{uses}{$_} = 0 unless exists $file{uses}{$_};
}
}
for ($func, @deps) {
if (exists $need{$_}) {
$file{needs}{$_} = 'static';
}
}
}
}
if (exists $API{$func}{todo} && $API{$func}{todo} > $opt{'compat-version'}) {
if ($c =~ /\b$func\b/) {
$file{uses_todo}{$func}++;
}
}
}
}
while ($c =~ /^$HS*#$HS*define$HS+(NEED_(\w+?)(_GLOBAL)?)\b/mg) {
if (exists $need{$2}) {
$file{defined $3 ? 'needed_global' : 'needed_static'}{$2}++;
}
else {
warning("Possibly wrong #define $1 in $filename");
}
}
for (qw(uses needs uses_todo needed_global needed_static)) {
for $func (keys %{$file{$_}}) {
push @{$global{$_}{$func}}, $filename;
}
}
$files{$filename} = \%file;
}
# Globally resolve NEED_'s
my $need;
for $need (keys %{$global{needs}}) {
if (@{$global{needs}{$need}} > 1) {
my @targets = @{$global{needs}{$need}};
my @t = grep $files{$_}{needed_global}{$need}, @targets;
@targets = @t if @t;
@t = grep /\.xs$/i, @targets;
@targets = @t if @t;
my $target = shift @targets;
$files{$target}{needs}{$need} = 'global';
for (@{$global{needs}{$need}}) {
$files{$_}{needs}{$need} = 'extern' if $_ ne $target;
}
}
}
for $filename (@files) {
exists $files{$filename} or next;
info("=== Analyzing $filename ===");
my %file = %{$files{$filename}};
my $func;
my $c = $file{code};
for $func (sort keys %{$file{uses_Perl}}) {
if ($API{$func}{varargs}) {
my $changes = ($c =~ s{\b(Perl_$func\s*\(\s*)(?!aTHX_?)(\)|[^\s)]*\))}
{ $1 . ($2 eq ')' ? 'aTHX' : 'aTHX_ ') . $2 }ge);
if ($changes) {
warning("Doesn't pass interpreter argument aTHX to Perl_$func");
$file{changes} += $changes;
}
}
else {
warning("Uses Perl_$func instead of $func");
$file{changes} += ($c =~ s{\bPerl_$func(\s*)\((\s*aTHX_?)?\s*}
{$func$1(}g);
}
}
for $func (sort keys %{$file{uses_replace}}) {
warning("Uses $func instead of $replace{$func}");
$file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
}
for $func (sort keys %{$file{uses}}) {
next unless $file{uses}{$func}; # if it's only a dependency
if (exists $file{uses_deps}{$func}) {
diag("Uses $func, which depends on ", join(', ', @{$file{uses_deps}{$func}}));
}
elsif (exists $replace{$func}) {
warning("Uses $func instead of $replace{$func}");
$file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g);
}
else {
diag("Uses $func");
}
hint($func);
}
for $func (sort keys %{$file{uses_todo}}) {
warning("Uses $func, which may not be portable below perl ",
format_version($API{$func}{todo}));
}
for $func (sort keys %{$file{needed_static}}) {
my $message = '';
if (not exists $file{uses}{$func}) {
$message = "No need to define NEED_$func if $func is never used";
}
elsif (exists $file{needs}{$func} && $file{needs}{$func} ne 'static') {
$message = "No need to define NEED_$func when already needed globally";
}
if ($message) {
diag($message);
$file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_$func\b.*$LF//mg);
}
}
for $func (sort keys %{$file{needed_global}}) {
my $message = '';
if (not exists $global{uses}{$func}) {
$message = "No need to define NEED_${func}_GLOBAL if $func is never used";
}
elsif (exists $file{needs}{$func}) {
if ($file{needs}{$func} eq 'extern') {
$message = "No need to define NEED_${func}_GLOBAL when already needed globally";
}
elsif ($file{needs}{$func} eq 'static') {
$message = "No need to define NEED_${func}_GLOBAL when only used in this file";
}
}
if ($message) {
diag($message);
$file{changes} += ($c =~ s/^$HS*#$HS*define$HS+NEED_${func}_GLOBAL\b.*$LF//mg);
}
}
$file{needs_inc_ppport} = keys %{$file{uses}};
if ($file{needs_inc_ppport}) {
my $pp = '';
for $func (sort keys %{$file{needs}}) {
my $type = $file{needs}{$func};
next if $type eq 'extern';
my $suffix = $type eq 'global' ? '_GLOBAL' : '';
unless (exists $file{"needed_$type"}{$func}) {
if ($type eq 'global') {
diag("Files [@{$global{needs}{$func}}] need $func, adding global request");
}
else {
diag("File needs $func, adding static request");
}
$pp .= "#define NEED_$func$suffix\n";
}
}
if ($pp && ($c =~ s/^(?=$HS*#$HS*define$HS+NEED_\w+)/$pp/m)) {
$pp = '';
$file{changes}++;
}
unless ($file{has_inc_ppport}) {
diag("Needs to include '$ppport'");
$pp .= qq(#include "$ppport"\n)
}
if ($pp) {
$file{changes} += ($c =~ s/^($HS*#$HS*define$HS+NEED_\w+.*?)^/$1$pp/ms)
|| ($c =~ s/^(?=$HS*#$HS*include.*\Q$ppport\E)/$pp/m)
|| ($c =~ s/^($HS*#$HS*include.*XSUB.*\s*?)^/$1$pp/m)
|| ($c =~ s/^/$pp/);
}
}
else {
if ($file{has_inc_ppport}) {
diag("No need to include '$ppport'");
$file{changes} += ($c =~ s/^$HS*?#$HS*include.*\Q$ppport\E.*?$LF//m);
}
}
# put back in our C comments
my $ix;
my $cppc = 0;
my @ccom = @{$file{ccom}};
for $ix (0 .. $#ccom) {
if (!$opt{cplusplus} && $ccom[$ix] =~ s!^//!!) {
$cppc++;
$file{changes} += $c =~ s/$rccs$ix$rcce/$ccs$ccom[$ix] $cce/;
}
else {
$c =~ s/$rccs$ix$rcce/$ccom[$ix]/;
}
}
if ($cppc) {
my $s = $cppc != 1 ? 's' : '';
warning("Uses $cppc C++ style comment$s, which is not portable");
}
if ($file{changes}) {
if (exists $opt{copy}) {
my $newfile = "$filename$opt{copy}";
if (-e $newfile) {
error("'$newfile' already exists, refusing to write copy of '$filename'");
}
else {
local *F;
if (open F, ">$newfile") {
info("Writing copy of '$filename' with changes to '$newfile'");
print F $c;
close F;
}
else {
error("Cannot open '$newfile' for writing: $!");
}
}
}
elsif (exists $opt{patch} || $opt{changes}) {
if (exists $opt{patch}) {
unless ($patch_opened) {
if (open PATCH, ">$opt{patch}") {
$patch_opened = 1;
}
else {
error("Cannot open '$opt{patch}' for writing: $!");
delete $opt{patch};
$opt{changes} = 1;
goto fallback;
}
}
mydiff(\*PATCH, $filename, $c);
}
else {
fallback:
info("Suggested changes:");
mydiff(\*STDOUT, $filename, $c);
}
}
else {
my $s = $file{changes} == 1 ? '' : 's';
info("$file{changes} potentially required change$s detected");
}
}
else {
info("Looks good");
}
}
close PATCH if $patch_opened;
exit 0;
#######################################################################
sub mydiff
{
local *F = shift;
my($file, $str) = @_;
my $diff;
if (exists $opt{diff}) {
$diff = run_diff($opt{diff}, $file, $str);
}
if (!defined $diff and can_use('Text::Diff')) {
$diff = Text::Diff::diff($file, \$str, { STYLE => 'Unified' });
$diff = <<HEADER . $diff;
--- $file
+++ $file.patched
HEADER
}
if (!defined $diff) {
$diff = run_diff('diff -u', $file, $str);
}
if (!defined $diff) {
$diff = run_diff('diff', $file, $str);
}
if (!defined $diff) {
error("Cannot generate a diff. Please install Text::Diff or use --copy.");
return;
}
print F $diff;
}
sub run_diff
{
my($prog, $file, $str) = @_;
my $tmp = 'dppptemp';
my $suf = 'aaa';
my $diff = '';
local *F;
while (-e "$tmp.$suf") { $suf++ }
$tmp = "$tmp.$suf";
if (open F, ">$tmp") {
print F $str;
close F;
if (open F, "$prog $file $tmp |") {
while (<F>) {
s/\Q$tmp\E/$file.patched/;
$diff .= $_;
}
close F;
unlink $tmp;
return $diff;
}
unlink $tmp;
}
else {
error("Cannot open '$tmp' for writing: $!");
}
return undef;
}
sub can_use
{
eval "use @_;";
return $@ eq '';
}
sub rec_depend
{
my $func = shift;
my %seen;
return () unless exists $depends{$func};
grep !$seen{$_}++, map { ($_, rec_depend($_)) } @{$depends{$func}};
}
sub parse_version
{
my $ver = shift;
if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
return ($1, $2, $3);
}
elsif ($ver !~ /^\d+\.[\d_]+$/) {
die "cannot parse version '$ver'\n";
}
$ver =~ s/_//g;
$ver =~ s/$/000000/;
my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
$v = int $v;
$s = int $s;
if ($r < 5 || ($r == 5 && $v < 6)) {
if ($s % 10) {
die "cannot parse version '$ver'\n";
}
}
return ($r, $v, $s);
}
sub format_version
{
my $ver = shift;
$ver =~ s/$/000000/;
my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
$v = int $v;
$s = int $s;
if ($r < 5 || ($r == 5 && $v < 6)) {
if ($s % 10) {
die "invalid version '$ver'\n";
}
$s /= 10;
$ver = sprintf "%d.%03d", $r, $v;
$s > 0 and $ver .= sprintf "_%02d", $s;
return $ver;
}
return sprintf "%d.%d.%d", $r, $v, $s;
}
sub info
{
$opt{quiet} and return;
print @_, "\n";
}
sub diag
{
$opt{quiet} and return;
$opt{diag} and print @_, "\n";
}
sub warning
{
$opt{quiet} and return;
print "*** ", @_, "\n";
}
sub error
{
print "*** ERROR: ", @_, "\n";
}
my %given_hints;
sub hint
{
$opt{quiet} and return;
$opt{hints} or return;
my $func = shift;
exists $hints{$func} or return;
$given_hints{$func}++ and return;
my $hint = $hints{$func};
$hint =~ s/^/ /mg;
print " --- hint for $func ---\n", $hint;
}
sub usage
{
my($usage) = do { local(@ARGV,$/)=($0); <> } =~ /^=head\d$HS+SYNOPSIS\s*^(.*?)\s*^=/ms;
my %M = ( 'I' => '*' );
$usage =~ s/^\s*perl\s+\S+/$^X $0/;
$usage =~ s/([A-Z])<([^>]+)>/$M{$1}$2$M{$1}/g;
print <<ENDUSAGE;
Usage: $usage
See perldoc $0 for details.
ENDUSAGE
exit 2;
}
--- NEW FILE: grok ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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
grok_hex
grok_oct
grok_bin
grok_numeric_radix
grok_number
__UNDEFINED__
=implementation
__UNDEFINED__ IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
__UNDEFINED__ IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
__UNDEFINED__ IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
__UNDEFINED__ IN_LOCALE (IN_PERL_COMPILETIME ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
__UNDEFINED__ IS_NUMBER_IN_UV 0x01
__UNDEFINED__ IS_NUMBER_GREATER_THAN_UV_MAX 0x02
__UNDEFINED__ IS_NUMBER_NOT_INT 0x04
__UNDEFINED__ IS_NUMBER_NEG 0x08
__UNDEFINED__ IS_NUMBER_INFINITY 0x10
__UNDEFINED__ IS_NUMBER_NAN 0x20
/* GROK_NUMERIC_RADIX depends on grok_numeric_radix */
__UNDEFINED__ GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
__UNDEFINED__ PERL_SCAN_GREATER_THAN_UV_MAX 0x02
__UNDEFINED__ PERL_SCAN_SILENT_ILLDIGIT 0x04
__UNDEFINED__ PERL_SCAN_ALLOW_UNDERSCORES 0x01
__UNDEFINED__ PERL_SCAN_DISALLOW_PREFIX 0x02
#ifndef grok_numeric_radix
#if { NEED grok_numeric_radix }
bool
grok_numeric_radix(pTHX_ const char **sp, const char *send)
{
#ifdef USE_LOCALE_NUMERIC
#ifdef PL_numeric_radix_sv
if (PL_numeric_radix_sv && IN_LOCALE) {
STRLEN len;
char* radix = SvPV(PL_numeric_radix_sv, len);
if (*sp + len <= send && memEQ(*sp, radix, len)) {
*sp += len;
return TRUE;
}
}
#else
/* older perls don't have PL_numeric_radix_sv so the radix
* must manually be requested from locale.h
*/
#include <locale.h>
dTHR; /* needed for older threaded perls */
struct lconv *lc = localeconv();
char *radix = lc->decimal_point;
if (radix && IN_LOCALE) {
STRLEN len = strlen(radix);
if (*sp + len <= send && memEQ(*sp, radix, len)) {
*sp += len;
return TRUE;
}
}
#endif /* PERL_VERSION */
#endif /* USE_LOCALE_NUMERIC */
/* always try "." if numeric radix didn't match because
* we may have data from different locales mixed */
if (*sp < send && **sp == '.') {
++*sp;
return TRUE;
}
return FALSE;
}
#endif
#endif
/* grok_number depends on grok_numeric_radix */
#ifndef grok_number
#if { NEED grok_number }
int
grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
{
const char *s = pv;
const char *send = pv + len;
const UV max_div_10 = UV_MAX / 10;
const char max_mod_10 = UV_MAX % 10;
int numtype = 0;
int sawinf = 0;
int sawnan = 0;
while (s < send && isSPACE(*s))
s++;
if (s == send) {
return 0;
} else if (*s == '-') {
s++;
numtype = IS_NUMBER_NEG;
}
else if (*s == '+')
s++;
if (s == send)
return 0;
/* next must be digit or the radix separator or beginning of infinity */
if (isDIGIT(*s)) {
/* UVs are at least 32 bits, so the first 9 decimal digits cannot
overflow. */
UV value = *s - '0';
/* This construction seems to be more optimiser friendly.
(without it gcc does the isDIGIT test and the *s - '0' separately)
With it gcc on arm is managing 6 instructions (6 cycles) per digit.
In theory the optimiser could deduce how far to unroll the loop
before checking for overflow. */
if (++s < send) {
int digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
digit = *s - '0';
if (digit >= 0 && digit <= 9) {
value = value * 10 + digit;
if (++s < send) {
/* Now got 9 digits, so need to check
each time for overflow. */
digit = *s - '0';
while (digit >= 0 && digit <= 9
&& (value < max_div_10
|| (value == max_div_10
&& digit <= max_mod_10))) {
value = value * 10 + digit;
if (++s < send)
digit = *s - '0';
else
break;
}
if (digit >= 0 && digit <= 9
&& (s < send)) {
/* value overflowed.
skip the remaining digits, don't
worry about setting *valuep. */
do {
s++;
} while (s < send && isDIGIT(*s));
numtype |=
IS_NUMBER_GREATER_THAN_UV_MAX;
goto skip_value;
}
}
}
}
}
}
}
}
}
}
}
}
}
}
}
}
}
}
numtype |= IS_NUMBER_IN_UV;
if (valuep)
*valuep = value;
skip_value:
if (GROK_NUMERIC_RADIX(&s, send)) {
numtype |= IS_NUMBER_NOT_INT;
while (s < send && isDIGIT(*s)) /* optional digits after the radix */
s++;
}
}
else if (GROK_NUMERIC_RADIX(&s, send)) {
numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
/* no digits before the radix means we need digits after it */
if (s < send && isDIGIT(*s)) {
do {
s++;
} while (s < send && isDIGIT(*s));
if (valuep) {
/* integer approximation is valid - it's 0. */
*valuep = 0;
}
}
else
return 0;
} else if (*s == 'I' || *s == 'i') {
s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
s++; if (s < send && (*s == 'I' || *s == 'i')) {
s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
s++;
}
sawinf = 1;
} else if (*s == 'N' || *s == 'n') {
/* XXX TODO: There are signaling NaNs and quiet NaNs. */
s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
s++;
sawnan = 1;
} else
return 0;
if (sawinf) {
numtype &= IS_NUMBER_NEG; /* Keep track of sign */
numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
} else if (sawnan) {
numtype &= IS_NUMBER_NEG; /* Keep track of sign */
numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
} else if (s < send) {
/* we can have an optional exponent part */
if (*s == 'e' || *s == 'E') {
/* The only flag we keep is sign. Blow away any "it's UV" */
numtype &= IS_NUMBER_NEG;
numtype |= IS_NUMBER_NOT_INT;
s++;
if (s < send && (*s == '-' || *s == '+'))
s++;
if (s < send && isDIGIT(*s)) {
do {
s++;
} while (s < send && isDIGIT(*s));
}
else
return 0;
}
}
while (s < send && isSPACE(*s))
s++;
if (s >= send)
return numtype;
if (len == 10 && memEQ(pv, "0 but true", 10)) {
if (valuep)
*valuep = 0;
return IS_NUMBER_IN_UV;
}
return 0;
}
#endif
#endif
/*
* The grok_* routines have been modified to use warn() instead of
* Perl_warner(). Also, 'hexdigit' was the former name of PL_hexdigit,
* which is why the stack variable has been renamed to 'xdigit'.
*/
#ifndef grok_bin
#if { NEED grok_bin }
UV
grok_bin(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
{
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_2 = UV_MAX / 2;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
/* strip off leading b or 0b.
for compatibility silently suffer "b" and "0b" as valid binary
numbers. */
if (len >= 1) {
if (s[0] == 'b') {
s++;
len--;
}
else if (len >= 2 && s[0] == '0' && s[1] == 'b') {
s+=2;
len-=2;
}
}
}
for (; len-- && *s; s++) {
char bit = *s;
if (bit == '0' || bit == '1') {
/* Write it in this wonky order with a goto to attempt to get the
compiler to make the common case integer-only loop pretty tight.
With gcc seems to be much straighter code than old scan_bin. */
redo:
if (!overflowed) {
if (value <= max_div_2) {
value = (value << 1) | (bit - '0');
continue;
}
/* Bah. We're just overflowed. */
warn("Integer overflow in binary number");
overflowed = TRUE;
value_nv = (NV) value;
}
value_nv *= 2.0;
/* If an NV has not enough bits in its mantissa to
* represent a UV this summing of small low-order numbers
* is a waste of time (because the NV cannot preserve
* the low-order bits anyway): we could just remember when
* did we overflow and in the end just multiply value_nv by the
* right amount. */
value_nv += (NV)(bit - '0');
continue;
}
if (bit == '_' && len && allow_underscores && (bit = s[1])
&& (bit == '0' || bit == '1'))
{
--len;
++s;
goto redo;
}
if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
warn("Illegal binary digit '%c' ignored", *s);
break;
}
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
|| (!overflowed && value > 0xffffffff )
#endif
) {
warn("Binary number > 0b11111111111111111111111111111111 non-portable");
}
*len_p = s - start;
if (!overflowed) {
*flags = 0;
return value;
}
*flags = PERL_SCAN_GREATER_THAN_UV_MAX;
if (result)
*result = value_nv;
return UV_MAX;
}
#endif
#endif
#ifndef grok_hex
#if { NEED grok_hex }
UV
grok_hex(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
{
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_16 = UV_MAX / 16;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
const char *xdigit;
if (!(*flags & PERL_SCAN_DISALLOW_PREFIX)) {
/* strip off leading x or 0x.
for compatibility silently suffer "x" and "0x" as valid hex numbers.
*/
if (len >= 1) {
if (s[0] == 'x') {
s++;
len--;
}
else if (len >= 2 && s[0] == '0' && s[1] == 'x') {
s+=2;
len-=2;
}
}
}
for (; len-- && *s; s++) {
xdigit = strchr((char *) PL_hexdigit, *s);
if (xdigit) {
/* Write it in this wonky order with a goto to attempt to get the
compiler to make the common case integer-only loop pretty tight.
With gcc seems to be much straighter code than old scan_hex. */
redo:
if (!overflowed) {
if (value <= max_div_16) {
value = (value << 4) | ((xdigit - PL_hexdigit) & 15);
continue;
}
warn("Integer overflow in hexadecimal number");
overflowed = TRUE;
value_nv = (NV) value;
}
value_nv *= 16.0;
/* If an NV has not enough bits in its mantissa to
* represent a UV this summing of small low-order numbers
* is a waste of time (because the NV cannot preserve
* the low-order bits anyway): we could just remember when
* did we overflow and in the end just multiply value_nv by the
* right amount of 16-tuples. */
value_nv += (NV)((xdigit - PL_hexdigit) & 15);
continue;
}
if (*s == '_' && len && allow_underscores && s[1]
&& (xdigit = strchr((char *) PL_hexdigit, s[1])))
{
--len;
++s;
goto redo;
}
if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
warn("Illegal hexadecimal digit '%c' ignored", *s);
break;
}
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
|| (!overflowed && value > 0xffffffff )
#endif
) {
warn("Hexadecimal number > 0xffffffff non-portable");
}
*len_p = s - start;
if (!overflowed) {
*flags = 0;
return value;
}
*flags = PERL_SCAN_GREATER_THAN_UV_MAX;
if (result)
*result = value_nv;
return UV_MAX;
}
#endif
#endif
#ifndef grok_oct
#if { NEED grok_oct }
UV
grok_oct(pTHX_ char *start, STRLEN *len_p, I32 *flags, NV *result)
{
const char *s = start;
STRLEN len = *len_p;
UV value = 0;
NV value_nv = 0;
const UV max_div_8 = UV_MAX / 8;
bool allow_underscores = *flags & PERL_SCAN_ALLOW_UNDERSCORES;
bool overflowed = FALSE;
for (; len-- && *s; s++) {
/* gcc 2.95 optimiser not smart enough to figure that this subtraction
out front allows slicker code. */
int digit = *s - '0';
if (digit >= 0 && digit <= 7) {
/* Write it in this wonky order with a goto to attempt to get the
compiler to make the common case integer-only loop pretty tight.
*/
redo:
if (!overflowed) {
if (value <= max_div_8) {
value = (value << 3) | digit;
continue;
}
/* Bah. We're just overflowed. */
warn("Integer overflow in octal number");
overflowed = TRUE;
value_nv = (NV) value;
}
value_nv *= 8.0;
/* If an NV has not enough bits in its mantissa to
* represent a UV this summing of small low-order numbers
* is a waste of time (because the NV cannot preserve
* the low-order bits anyway): we could just remember when
* did we overflow and in the end just multiply value_nv by the
* right amount of 8-tuples. */
value_nv += (NV)digit;
continue;
}
if (digit == ('_' - '0') && len && allow_underscores
&& (digit = s[1] - '0') && (digit >= 0 && digit <= 7))
{
--len;
++s;
goto redo;
}
/* Allow \octal to work the DWIM way (that is, stop scanning
* as soon as non-octal characters are seen, complain only iff
* someone seems to want to use the digits eight and nine). */
if (digit == 8 || digit == 9) {
if (!(*flags & PERL_SCAN_SILENT_ILLDIGIT))
warn("Illegal octal digit '%c' ignored", *s);
}
break;
}
if ( ( overflowed && value_nv > 4294967295.0)
#if UVSIZE > 4
|| (!overflowed && value > 0xffffffff )
#endif
) {
warn("Octal number > 037777777777 non-portable");
}
*len_p = s - start;
if (!overflowed) {
*flags = 0;
return value;
}
*flags = PERL_SCAN_GREATER_THAN_UV_MAX;
if (result)
*result = value_nv;
return UV_MAX;
}
#endif
#endif
=xsinit
#define NEED_grok_number
#define NEED_grok_numeric_radix
#define NEED_grok_bin
#define NEED_grok_hex
#define NEED_grok_oct
=xsubs
UV
grok_number(string)
SV *string
PREINIT:
const char *pv;
STRLEN len;
CODE:
pv = SvPV(string, len);
if (!grok_number(pv, len, &RETVAL))
XSRETURN_UNDEF;
OUTPUT:
RETVAL
UV
grok_bin(string)
SV *string
PREINIT:
char *pv;
I32 flags;
STRLEN len;
CODE:
pv = SvPV(string, len);
RETVAL = grok_bin(pv, &len, &flags, NULL);
OUTPUT:
RETVAL
UV
grok_hex(string)
SV *string
PREINIT:
char *pv;
I32 flags;
STRLEN len;
CODE:
pv = SvPV(string, len);
RETVAL = grok_hex(pv, &len, &flags, NULL);
OUTPUT:
RETVAL
UV
grok_oct(string)
SV *string
PREINIT:
char *pv;
I32 flags;
STRLEN len;
CODE:
pv = SvPV(string, len);
RETVAL = grok_oct(pv, &len, &flags, NULL);
OUTPUT:
RETVAL
UV
Perl_grok_number(string)
SV *string
PREINIT:
const char *pv;
STRLEN len;
CODE:
pv = SvPV(string, len);
if (!Perl_grok_number(aTHX_ pv, len, &RETVAL))
XSRETURN_UNDEF;
OUTPUT:
RETVAL
UV
Perl_grok_bin(string)
SV *string
PREINIT:
char *pv;
I32 flags;
STRLEN len;
CODE:
pv = SvPV(string, len);
RETVAL = Perl_grok_bin(aTHX_ pv, &len, &flags, NULL);
OUTPUT:
RETVAL
UV
Perl_grok_hex(string)
SV *string
PREINIT:
char *pv;
I32 flags;
STRLEN len;
CODE:
pv = SvPV(string, len);
RETVAL = Perl_grok_hex(aTHX_ pv, &len, &flags, NULL);
OUTPUT:
RETVAL
UV
Perl_grok_oct(string)
SV *string
PREINIT:
char *pv;
I32 flags;
STRLEN len;
CODE:
pv = SvPV(string, len);
RETVAL = Perl_grok_oct(aTHX_ pv, &len, &flags, NULL);
OUTPUT:
RETVAL
=tests plan => 10
ok(&Devel::PPPort::grok_number("42"), 42);
ok(!defined(&Devel::PPPort::grok_number("A")));
ok(&Devel::PPPort::grok_bin("10000001"), 129);
ok(&Devel::PPPort::grok_hex("deadbeef"), 0xdeadbeef);
ok(&Devel::PPPort::grok_oct("377"), 255);
ok(&Devel::PPPort::Perl_grok_number("42"), 42);
ok(!defined(&Devel::PPPort::Perl_grok_number("A")));
ok(&Devel::PPPort::Perl_grok_bin("10000001"), 129);
ok(&Devel::PPPort::Perl_grok_hex("deadbeef"), 0xdeadbeef);
ok(&Devel::PPPort::Perl_grok_oct("377"), 255);
--- NEW FILE: version ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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
PERL_REVISION
PERL_VERSION
PERL_SUBVERSION
PERL_BCDVERSION
=dontwarn
PERL_PATCHLEVEL_H_IMPLICIT
=implementation
#ifndef PERL_REVISION
# if !defined(__PATCHLEVEL_H_INCLUDED__) && !(defined(PATCHLEVEL) && defined(SUBVERSION))
# define PERL_PATCHLEVEL_H_IMPLICIT
# include <patchlevel.h>
# endif
# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
# include <could_not_find_Perl_patchlevel.h>
# endif
# ifndef PERL_REVISION
# define PERL_REVISION (5)
/* Replace: 1 */
# define PERL_VERSION PATCHLEVEL
# define PERL_SUBVERSION SUBVERSION
/* Replace PERL_PATCHLEVEL with PERL_VERSION */
/* Replace: 0 */
# endif
#endif
#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
/* It is very unlikely that anyone will try to use this with Perl 6
(or greater), but who knows.
*/
#if PERL_REVISION != 5
# error ppport.h only works with Perl version 5
#endif /* PERL_REVISION != 5 */
--- NEW FILE: threads ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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__
=implementation
__UNDEFINED__ dTHR dNOOP
__UNDEFINED__ dTHX dNOOP
__UNDEFINED__ dTHXa(x) dNOOP
__UNDEFINED__ pTHX void
__UNDEFINED__ pTHX_
__UNDEFINED__ aTHX
__UNDEFINED__ aTHX_
__UNDEFINED__ dTHXoa(x) dTHXa(x)
=xsubs
IV
no_THX_arg(sv)
SV *sv
CODE:
RETVAL = 1 + sv_2iv(sv);
OUTPUT:
RETVAL
void
with_THX_arg(error)
char *error
PPCODE:
Perl_croak(aTHX_ "%s", error);
=tests plan => 2
ok(&Devel::PPPort::no_THX_arg("42"), 43);
eval { &Devel::PPPort::with_THX_arg("yes\n"); };
ok($@ =~ /^yes/);
--- NEW FILE: mPUSH ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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__
=implementation
__UNDEFINED__ PUSHmortal PUSHs(sv_newmortal())
__UNDEFINED__ mPUSHp(p,l) sv_setpvn_mg(PUSHmortal, (p), (l))
__UNDEFINED__ mPUSHn(n) sv_setnv_mg(PUSHmortal, (NV)(n))
__UNDEFINED__ mPUSHi(i) sv_setiv_mg(PUSHmortal, (IV)(i))
__UNDEFINED__ mPUSHu(u) sv_setuv_mg(PUSHmortal, (UV)(u))
__UNDEFINED__ XPUSHmortal XPUSHs(sv_newmortal())
__UNDEFINED__ mXPUSHp(p,l) STMT_START { EXTEND(sp,1); sv_setpvn_mg(PUSHmortal, (p), (l)); } STMT_END
__UNDEFINED__ mXPUSHn(n) STMT_START { EXTEND(sp,1); sv_setnv_mg(PUSHmortal, (NV)(n)); } STMT_END
__UNDEFINED__ mXPUSHi(i) STMT_START { EXTEND(sp,1); sv_setiv_mg(PUSHmortal, (IV)(i)); } STMT_END
__UNDEFINED__ mXPUSHu(u) STMT_START { EXTEND(sp,1); sv_setuv_mg(PUSHmortal, (UV)(u)); } STMT_END
=xsubs
void
mPUSHp()
PPCODE:
EXTEND(SP, 3);
mPUSHp("one", 3);
mPUSHp("two", 3);
mPUSHp("three", 5);
XSRETURN(3);
void
mPUSHn()
PPCODE:
EXTEND(SP, 3);
mPUSHn(0.5);
mPUSHn(-0.25);
mPUSHn(0.125);
XSRETURN(3);
void
mPUSHi()
PPCODE:
EXTEND(SP, 3);
mPUSHi(-1);
mPUSHi(2);
mPUSHi(-3);
XSRETURN(3);
void
mPUSHu()
PPCODE:
EXTEND(SP, 3);
mPUSHu(1);
mPUSHu(2);
mPUSHu(3);
XSRETURN(3);
void
mXPUSHp()
PPCODE:
mXPUSHp("one", 3);
mXPUSHp("two", 3);
mXPUSHp("three", 5);
XSRETURN(3);
void
mXPUSHn()
PPCODE:
mXPUSHn(0.5);
mXPUSHn(-0.25);
mXPUSHn(0.125);
XSRETURN(3);
void
mXPUSHi()
PPCODE:
mXPUSHi(-1);
mXPUSHi(2);
mXPUSHi(-3);
XSRETURN(3);
void
mXPUSHu()
PPCODE:
mXPUSHu(1);
mXPUSHu(2);
mXPUSHu(3);
XSRETURN(3);
=tests plan => 8
ok(join(':', &Devel::PPPort::mPUSHp()), "one:two:three");
ok(join(':', &Devel::PPPort::mPUSHn()), "0.5:-0.25:0.125");
ok(join(':', &Devel::PPPort::mPUSHi()), "-1:2:-3");
ok(join(':', &Devel::PPPort::mPUSHu()), "1:2:3");
ok(join(':', &Devel::PPPort::mXPUSHp()), "one:two:three");
ok(join(':', &Devel::PPPort::mXPUSHn()), "0.5:-0.25:0.125");
ok(join(':', &Devel::PPPort::mXPUSHi()), "-1:2:-3");
ok(join(':', &Devel::PPPort::mXPUSHu()), "1:2:3");
--- NEW FILE: call ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:15 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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
eval_pv
eval_sv
call_sv
call_pv
call_argv
call_method
=implementation
/* Replace: 1 */
__UNDEFINED__ call_sv perl_call_sv
__UNDEFINED__ call_pv perl_call_pv
__UNDEFINED__ call_argv perl_call_argv
__UNDEFINED__ call_method perl_call_method
__UNDEFINED__ eval_sv perl_eval_sv
/* Replace: 0 */
/* Replace perl_eval_pv with eval_pv */
/* eval_pv depends on eval_sv */
#ifndef eval_pv
#if { NEED eval_pv }
SV*
eval_pv(char *p, I32 croak_on_error)
{
dSP;
SV* sv = newSVpv(p, 0);
PUSHMARK(sp);
eval_sv(sv, G_SCALAR);
SvREFCNT_dec(sv);
SPAGAIN;
sv = POPs;
PUTBACK;
if (croak_on_error && SvTRUE(GvSV(errgv)))
croak(SvPVx(GvSV(errgv), na));
return sv;
}
#endif
#endif
=xsinit
#define NEED_eval_pv
=xsubs
I32
G_SCALAR()
CODE:
RETVAL = G_SCALAR;
OUTPUT:
RETVAL
I32
G_ARRAY()
CODE:
RETVAL = G_ARRAY;
OUTPUT:
RETVAL
I32
G_DISCARD()
CODE:
RETVAL = G_DISCARD;
OUTPUT:
RETVAL
void
eval_sv(sv, flags)
SV* sv
I32 flags
PREINIT:
I32 i;
PPCODE:
PUTBACK;
i = eval_sv(sv, flags);
SPAGAIN;
EXTEND(SP, 1);
PUSHs(sv_2mortal(newSViv(i)));
void
eval_pv(p, croak_on_error)
char* p
I32 croak_on_error
PPCODE:
PUTBACK;
EXTEND(SP, 1);
PUSHs(eval_pv(p, croak_on_error));
void
call_sv(sv, flags, ...)
SV* sv
I32 flags
PREINIT:
I32 i;
PPCODE:
for (i=0; i<items-2; i++)
ST(i) = ST(i+2); /* pop first two args */
PUSHMARK(SP);
SP += items - 2;
PUTBACK;
i = call_sv(sv, flags);
SPAGAIN;
EXTEND(SP, 1);
PUSHs(sv_2mortal(newSViv(i)));
void
call_pv(subname, flags, ...)
char* subname
I32 flags
PREINIT:
I32 i;
PPCODE:
for (i=0; i<items-2; i++)
ST(i) = ST(i+2); /* pop first two args */
PUSHMARK(SP);
SP += items - 2;
PUTBACK;
i = call_pv(subname, flags);
SPAGAIN;
EXTEND(SP, 1);
PUSHs(sv_2mortal(newSViv(i)));
void
call_argv(subname, flags, ...)
char* subname
I32 flags
PREINIT:
I32 i;
char *args[8];
PPCODE:
if (items > 8) /* play safe */
XSRETURN_UNDEF;
for (i=2; i<items; i++)
args[i-2] = SvPV_nolen(ST(i));
args[items-2] = NULL;
PUTBACK;
i = call_argv(subname, flags, args);
SPAGAIN;
EXTEND(SP, 1);
PUSHs(sv_2mortal(newSViv(i)));
void
call_method(methname, flags, ...)
char* methname
I32 flags
PREINIT:
I32 i;
PPCODE:
for (i=0; i<items-2; i++)
ST(i) = ST(i+2); /* pop first two args */
PUSHMARK(SP);
SP += items - 2;
PUTBACK;
i = call_method(methname, flags);
SPAGAIN;
EXTEND(SP, 1);
PUSHs(sv_2mortal(newSViv(i)));
=tests plan => 44
sub eq_array
{
my($a, $b) = @_;
join(':', @$a) eq join(':', @$b);
}
sub f
{
shift;
unshift @_, 'b';
pop @_;
@_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
}
my $obj = bless [], 'Foo';
sub Foo::meth
{
return 'bad_self' unless @_ && ref $_[0] && ref($_[0]) eq 'Foo';
shift;
shift;
unshift @_, 'b';
pop @_;
@_, defined wantarray ? wantarray ? 'x' : 'y' : 'z';
}
my $test;
for $test (
# flags args expected description
[ &Devel::PPPort::G_SCALAR, [ ], [ qw(y 1) ], '0 args, G_SCALAR' ],
[ &Devel::PPPort::G_SCALAR, [ qw(a p q) ], [ qw(y 1) ], '3 args, G_SCALAR' ],
[ &Devel::PPPort::G_ARRAY, [ ], [ qw(x 1) ], '0 args, G_ARRAY' ],
[ &Devel::PPPort::G_ARRAY, [ qw(a p q) ], [ qw(b p x 3) ], '3 args, G_ARRAY' ],
[ &Devel::PPPort::G_DISCARD, [ ], [ qw(0) ], '0 args, G_DISCARD' ],
[ &Devel::PPPort::G_DISCARD, [ qw(a p q) ], [ qw(0) ], '3 args, G_DISCARD' ],
)
{
my ($flags, $args, $expected, $description) = @$test;
print "# --- $description ---\n";
ok(eq_array( [ &Devel::PPPort::call_sv(\&f, $flags, @$args) ], $expected));
ok(eq_array( [ &Devel::PPPort::call_sv(*f, $flags, @$args) ], $expected));
ok(eq_array( [ &Devel::PPPort::call_sv('f', $flags, @$args) ], $expected));
ok(eq_array( [ &Devel::PPPort::call_pv('f', $flags, @$args) ], $expected));
ok(eq_array( [ &Devel::PPPort::call_argv('f', $flags, @$args) ], $expected));
ok(eq_array( [ &Devel::PPPort::eval_sv("f(qw(@$args))", $flags) ], $expected));
ok(eq_array( [ &Devel::PPPort::call_method('meth', $flags, $obj, @$args) ], $expected));
};
ok(&Devel::PPPort::eval_pv('f()', 0), 'y');
ok(&Devel::PPPort::eval_pv('f(qw(a b c))', 0), 'y');
--- NEW FILE: magic ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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__
/sv_\w+_mg/
=implementation
__UNDEFINED__ SvGETMAGIC(x) STMT_START { if (SvGMAGICAL(x)) mg_get(x); } STMT_END
__UNDEFINED__ PERL_MAGIC_sv '\0'
__UNDEFINED__ PERL_MAGIC_overload 'A'
__UNDEFINED__ PERL_MAGIC_overload_elem 'a'
__UNDEFINED__ PERL_MAGIC_overload_table 'c'
__UNDEFINED__ PERL_MAGIC_bm 'B'
__UNDEFINED__ PERL_MAGIC_regdata 'D'
__UNDEFINED__ PERL_MAGIC_regdatum 'd'
__UNDEFINED__ PERL_MAGIC_env 'E'
__UNDEFINED__ PERL_MAGIC_envelem 'e'
__UNDEFINED__ PERL_MAGIC_fm 'f'
__UNDEFINED__ PERL_MAGIC_regex_global 'g'
__UNDEFINED__ PERL_MAGIC_isa 'I'
__UNDEFINED__ PERL_MAGIC_isaelem 'i'
__UNDEFINED__ PERL_MAGIC_nkeys 'k'
__UNDEFINED__ PERL_MAGIC_dbfile 'L'
__UNDEFINED__ PERL_MAGIC_dbline 'l'
__UNDEFINED__ PERL_MAGIC_mutex 'm'
__UNDEFINED__ PERL_MAGIC_shared 'N'
__UNDEFINED__ PERL_MAGIC_shared_scalar 'n'
__UNDEFINED__ PERL_MAGIC_collxfrm 'o'
__UNDEFINED__ PERL_MAGIC_tied 'P'
__UNDEFINED__ PERL_MAGIC_tiedelem 'p'
__UNDEFINED__ PERL_MAGIC_tiedscalar 'q'
__UNDEFINED__ PERL_MAGIC_qr 'r'
__UNDEFINED__ PERL_MAGIC_sig 'S'
__UNDEFINED__ PERL_MAGIC_sigelem 's'
__UNDEFINED__ PERL_MAGIC_taint 't'
__UNDEFINED__ PERL_MAGIC_uvar 'U'
__UNDEFINED__ PERL_MAGIC_uvar_elem 'u'
__UNDEFINED__ PERL_MAGIC_vstring 'V'
__UNDEFINED__ PERL_MAGIC_vec 'v'
__UNDEFINED__ PERL_MAGIC_utf8 'w'
__UNDEFINED__ PERL_MAGIC_substr 'x'
__UNDEFINED__ PERL_MAGIC_defelem 'y'
__UNDEFINED__ PERL_MAGIC_glob '*'
__UNDEFINED__ PERL_MAGIC_arylen '#'
__UNDEFINED__ PERL_MAGIC_pos '.'
__UNDEFINED__ PERL_MAGIC_backref '<'
__UNDEFINED__ PERL_MAGIC_ext '~'
/* That's the best we can do... */
__UNDEFINED__ SvPV_force_nomg SvPV_force
__UNDEFINED__ SvPV_nomg SvPV
__UNDEFINED__ sv_catpvn_nomg sv_catpvn
__UNDEFINED__ sv_catsv_nomg sv_catsv
__UNDEFINED__ sv_setsv_nomg sv_setsv
__UNDEFINED__ sv_pvn_nomg sv_pvn
__UNDEFINED__ SvIV_nomg SvIV
__UNDEFINED__ SvUV_nomg SvUV
#ifndef sv_catpv_mg
# define sv_catpv_mg(sv, ptr) \
STMT_START { \
SV *TeMpSv = sv; \
sv_catpv(TeMpSv,ptr); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_catpvn_mg
# define sv_catpvn_mg(sv, ptr, len) \
STMT_START { \
SV *TeMpSv = sv; \
sv_catpvn(TeMpSv,ptr,len); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_catsv_mg
# define sv_catsv_mg(dsv, ssv) \
STMT_START { \
SV *TeMpSv = dsv; \
sv_catsv(TeMpSv,ssv); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setiv_mg
# define sv_setiv_mg(sv, i) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setiv(TeMpSv,i); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setnv_mg
# define sv_setnv_mg(sv, num) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setnv(TeMpSv,num); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setpv_mg
# define sv_setpv_mg(sv, ptr) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setpv(TeMpSv,ptr); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setpvn_mg
# define sv_setpvn_mg(sv, ptr, len) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setpvn(TeMpSv,ptr,len); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setsv_mg
# define sv_setsv_mg(dsv, ssv) \
STMT_START { \
SV *TeMpSv = dsv; \
sv_setsv(TeMpSv,ssv); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_setuv_mg
# define sv_setuv_mg(sv, i) \
STMT_START { \
SV *TeMpSv = sv; \
sv_setuv(TeMpSv,i); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
#ifndef sv_usepvn_mg
# define sv_usepvn_mg(sv, ptr, len) \
STMT_START { \
SV *TeMpSv = sv; \
sv_usepvn(TeMpSv,ptr,len); \
SvSETMAGIC(TeMpSv); \
} STMT_END
#endif
=xsubs
void
sv_catpv_mg(sv, string)
SV *sv;
char *string;
CODE:
sv_catpv_mg(sv, string);
void
sv_catpvn_mg(sv, sv2)
SV *sv;
SV *sv2;
PREINIT:
char *str;
STRLEN len;
CODE:
str = SvPV(sv2, len);
sv_catpvn_mg(sv, str, len);
void
sv_catsv_mg(sv, sv2)
SV *sv;
SV *sv2;
CODE:
sv_catsv_mg(sv, sv2);
void
sv_setiv_mg(sv, iv)
SV *sv;
IV iv;
CODE:
sv_setiv_mg(sv, iv);
void
sv_setnv_mg(sv, nv)
SV *sv;
NV nv;
CODE:
sv_setnv_mg(sv, nv);
void
sv_setpv_mg(sv, pv)
SV *sv;
char *pv;
CODE:
sv_setpv_mg(sv, pv);
void
sv_setpvn_mg(sv, sv2)
SV *sv;
SV *sv2;
PREINIT:
char *str;
STRLEN len;
CODE:
str = SvPV(sv2, len);
sv_setpvn_mg(sv, str, len);
void
sv_setsv_mg(sv, sv2)
SV *sv;
SV *sv2;
CODE:
sv_setsv_mg(sv, sv2);
void
sv_setuv_mg(sv, uv)
SV *sv;
UV uv;
CODE:
sv_setuv_mg(sv, uv);
void
sv_usepvn_mg(sv, sv2)
SV *sv;
SV *sv2;
PREINIT:
char *str, *copy;
STRLEN len;
CODE:
str = SvPV(sv2, len);
New(42, copy, len+1, char);
Copy(str, copy, len+1, char);
sv_usepvn_mg(sv, copy, len);
=tests plan => 10
use Tie::Hash;
my %h;
tie %h, 'Tie::StdHash';
$h{foo} = 'foo';
$h{bar} = '';
&Devel::PPPort::sv_catpv_mg($h{foo}, 'bar');
ok($h{foo}, 'foobar');
&Devel::PPPort::sv_catpvn_mg($h{bar}, 'baz');
ok($h{bar}, 'baz');
&Devel::PPPort::sv_catsv_mg($h{foo}, '42');
ok($h{foo}, 'foobar42');
&Devel::PPPort::sv_setiv_mg($h{bar}, 42);
ok($h{bar}, 42);
&Devel::PPPort::sv_setnv_mg($h{PI}, 3.14159);
ok(abs($h{PI} - 3.14159) < 0.01);
&Devel::PPPort::sv_setpv_mg($h{mhx}, 'mhx');
ok($h{mhx}, 'mhx');
&Devel::PPPort::sv_setpvn_mg($h{mhx}, 'Marcus');
ok($h{mhx}, 'Marcus');
&Devel::PPPort::sv_setsv_mg($h{sv}, 'SV');
ok($h{sv}, 'SV');
&Devel::PPPort::sv_setuv_mg($h{sv}, 4711);
ok($h{sv}, 4711);
&Devel::PPPort::sv_usepvn_mg($h{sv}, 'Perl');
ok($h{sv}, 'Perl');
--- NEW FILE: ppphtest ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:16 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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.
##
################################################################################
=tests plan => 197
use File::Path qw/rmtree mkpath/;
use Config;
my $tmp = 'ppptmp';
my $inc = '';
my $perl = find_perl();
my $isVMS = $^O eq 'VMS';
my $isMAC = $^O eq 'MacOS';
rmtree($tmp) if -d $tmp;
mkpath($tmp) or die "mkpath $tmp: $!\n";
chdir($tmp) or die "chdir $tmp: $!\n";
if ($ENV{'PERL_CORE'}) {
if (-d '../../lib') {
if ($isVMS) {
$inc = '"-I../../lib"';
}
elsif ($isMAC) {
$inc = '-I:::lib';
}
else {
$inc = '-I../../lib';
}
unshift @INC, '../../lib';
}
}
if ($perl =~ m!^\./!) {
$perl = ".$perl";
}
END {
chdir('..') if !-d $tmp && -d "../$tmp";
rmtree($tmp) if -d $tmp;
}
ok(&Devel::PPPort::WriteFile("ppport.h"));
sub comment
{
my $c = shift;
$c =~ s/^/# | /mg;
$c .= "\n" unless $c =~ /[\r\n]$/;
print $c;
}
sub ppport
{
my @args = ('ppport.h', @_);
unshift @args, $inc if $inc;
my $run = $perl =~ m/\s/ ? qq("$perl") : $perl;
$run .= ' -MMac::err=unix' if $isMAC;
for (@args) {
$_ = qq("$_") if $isVMS && /^[^"]/;
$run .= " $_";
}
print "# *** running $run ***\n";
$run .= ' 2>&1' unless $isMAC;
my @out = `$run`;
my $out = join '', @out;
comment($out);
return wantarray ? @out : $out;
}
sub matches
{
my($str, $re, $mod) = @_;
my @n;
eval "\@n = \$str =~ /$re/g$mod;";
if ($@) {
my $err = $@;
$err =~ s/^/# *** /mg;
print "# *** ERROR ***\n$err\n";
}
return $@ ? -42 : scalar @n;
}
sub eq_files
{
my($f1, $f2) = @_;
return 0 unless -e $f1 && -e $f2;
local *F;
for ($f1, $f2) {
print "# File: $_\n";
unless (open F, $_) {
print "# couldn't open $_: $!\n";
return 0;
}
$_ = do { local $/; <F> };
close F;
comment($_);
}
return $f1 eq $f2;
}
my @tests;
for (split /\s*={70,}\s*/, do { local $/; <DATA> }) {
s/^\s+//; s/\s+$//;
my($c, %f);
($c, @f{m/-{20,}\s+(\S+)\s+-{20,}/g}) = split /\s*-{20,}\s+\S+\s+-{20,}\s*/;
push @tests, { code => $c, files => \%f };
}
my $t;
for $t (@tests) {
my $f;
for $f (keys %{$t->{files}}) {
my @f = split /\//, $f;
if (@f > 1) {
pop @f;
my $path = join '/', @f;
mkpath($path) or die "mkpath('$path'): $!\n";
}
my $txt = $t->{files}{$f};
local *F;
open F, ">$f" or die "open $f: $!\n";
print F "$txt\n";
close F;
$txt =~ s/^/# | /mg;
print "# *** writing $f ***\n$txt\n";
}
eval $t->{code};
if ($@) {
my $err = $@;
$err =~ s/^/# *** /mg;
print "# *** ERROR ***\n$err\n";
}
ok($@, '');
for (keys %{$t->{files}}) {
unlink $_ or die "unlink('$_'): $!\n";
}
}
sub find_perl
{
my $perl = $^X;
return $perl if $isVMS;
my $exe = $Config{'_exe'} || '';
if ($perl =~ /^perl\Q$exe\E$/i) {
$perl = "perl$exe";
eval "require File::Spec";
if ($@) {
$perl = "./$perl";
} else {
$perl = File::Spec->catfile(File::Spec->curdir(), $perl);
}
}
if ($perl !~ /\Q$exe\E$/i) {
$perl .= $exe;
}
warn "find_perl: cannot find $perl from $^X" unless -f $perl;
return $perl;
}
__DATA__
my $o = ppport(qw(--help));
ok($o =~ /^Usage:.*ppport\.h/m);
ok($o =~ /--help/m);
$o = ppport(qw(--nochanges));
ok($o =~ /^Scanning.*test\.xs/mi);
ok($o =~ /Analyzing.*test\.xs/mi);
ok(matches($o, '^Scanning', 'm'), 1);
ok(matches($o, 'Analyzing', 'm'), 1);
ok($o =~ /Uses Perl_newSViv instead of newSViv/);
$o = ppport(qw(--quiet --nochanges));
ok($o =~ /^\s*$/);
---------------------------- test.xs ------------------------------------------
Perl_newSViv();
===============================================================================
# check if C and C++ comments are filtered correctly
my $o = ppport(qw(--copy=a));
ok($o =~ /^Scanning.*MyExt\.xs/mi);
ok($o =~ /Analyzing.*MyExt\.xs/mi);
ok(matches($o, '^Scanning', 'm'), 1);
ok($o =~ /^Needs to include.*ppport\.h/m);
ok($o !~ /^Uses grok_bin/m);
ok($o !~ /^Uses newSVpv/m);
ok($o =~ /Uses 1 C\+\+ style comment/m);
ok(eq_files('MyExt.xsa', 'MyExt.ra'));
# check if C++ are left untouched with --cplusplus
$o = ppport(qw(--copy=b --cplusplus));
ok($o =~ /^Scanning.*MyExt\.xs/mi);
ok($o =~ /Analyzing.*MyExt\.xs/mi);
ok(matches($o, '^Scanning', 'm'), 1);
ok($o =~ /^Needs to include.*ppport\.h/m);
ok($o !~ /^Uses grok_bin/m);
ok($o !~ /^Uses newSVpv/m);
ok($o !~ /Uses \d+ C\+\+ style comment/m);
ok(eq_files('MyExt.xsb', 'MyExt.rb'));
unlink qw(MyExt.xsa MyExt.xsb);
---------------------------- MyExt.xs -----------------------------------------
newSVuv();
// newSVpv();
XPUSHs(foo);
/* grok_bin(); */
---------------------------- MyExt.ra -----------------------------------------
#include "ppport.h"
newSVuv();
/* newSVpv(); */
XPUSHs(foo);
/* grok_bin(); */
---------------------------- MyExt.rb -----------------------------------------
#include "ppport.h"
newSVuv();
// newSVpv();
XPUSHs(foo);
/* grok_bin(); */
===============================================================================
my $o = ppport(qw(--nochanges file1.xs));
ok($o =~ /^Scanning.*file1\.xs/mi);
ok($o =~ /Analyzing.*file1\.xs/mi);
ok($o !~ /^Scanning.*file2\.xs/mi);
ok($o =~ /^Uses newCONSTSUB/m);
ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m);
ok($o =~ /hint for newCONSTSUB/m);
ok($o !~ /hint for sv_2pv_nolen/m);
ok($o =~ /^Looks good/m);
$o = ppport(qw(--nochanges --nohints file1.xs));
ok($o =~ /^Scanning.*file1\.xs/mi);
ok($o =~ /Analyzing.*file1\.xs/mi);
ok($o !~ /^Scanning.*file2\.xs/mi);
ok($o =~ /^Uses newCONSTSUB/m);
ok($o =~ /^Uses SvPV_nolen.*depends.*sv_2pv_nolen/m);
ok($o !~ /hint for newCONSTSUB/m);
ok($o !~ /hint for sv_2pv_nolen/m);
ok($o =~ /^Looks good/m);
$o = ppport(qw(--nochanges --nohints --nodiag file1.xs));
ok($o =~ /^Scanning.*file1\.xs/mi);
ok($o =~ /Analyzing.*file1\.xs/mi);
ok($o !~ /^Scanning.*file2\.xs/mi);
ok($o !~ /^Uses newCONSTSUB/m);
ok($o !~ /^Uses SvPV_nolen/m);
ok($o !~ /hint for newCONSTSUB/m);
ok($o !~ /hint for sv_2pv_nolen/m);
ok($o =~ /^Looks good/m);
$o = ppport(qw(--nochanges --quiet file1.xs));
ok($o =~ /^\s*$/);
$o = ppport(qw(--nochanges file2.xs));
ok($o =~ /^Scanning.*file2\.xs/mi);
ok($o =~ /Analyzing.*file2\.xs/mi);
ok($o !~ /^Scanning.*file1\.xs/mi);
ok($o =~ /^Uses mXPUSHp/m);
ok($o =~ /^Needs to include.*ppport\.h/m);
ok($o !~ /^Looks good/m);
ok($o =~ /^1 potentially required change detected/m);
$o = ppport(qw(--nochanges --nohints file2.xs));
ok($o =~ /^Scanning.*file2\.xs/mi);
ok($o =~ /Analyzing.*file2\.xs/mi);
ok($o !~ /^Scanning.*file1\.xs/mi);
ok($o =~ /^Uses mXPUSHp/m);
ok($o =~ /^Needs to include.*ppport\.h/m);
ok($o !~ /^Looks good/m);
ok($o =~ /^1 potentially required change detected/m);
$o = ppport(qw(--nochanges --nohints --nodiag file2.xs));
ok($o =~ /^Scanning.*file2\.xs/mi);
ok($o =~ /Analyzing.*file2\.xs/mi);
ok($o !~ /^Scanning.*file1\.xs/mi);
ok($o !~ /^Uses mXPUSHp/m);
ok($o !~ /^Needs to include.*ppport\.h/m);
ok($o !~ /^Looks good/m);
ok($o =~ /^1 potentially required change detected/m);
$o = ppport(qw(--nochanges --quiet file2.xs));
ok($o =~ /^\s*$/);
---------------------------- file1.xs -----------------------------------------
#define NEED_newCONSTSUB
#define NEED_sv_2pv_nolen
#include "ppport.h"
newCONSTSUB();
SvPV_nolen();
---------------------------- file2.xs -----------------------------------------
mXPUSHp(foo);
===============================================================================
my $o = ppport(qw(--nochanges));
ok($o =~ /^Scanning.*FooBar\.xs/mi);
ok($o =~ /Analyzing.*FooBar\.xs/mi);
ok(matches($o, '^Scanning', 'm'), 1);
ok($o !~ /^Looks good/m);
ok($o =~ /^Uses grok_bin/m);
---------------------------- FooBar.xs ----------------------------------------
newSViv();
XPUSHs(foo);
grok_bin();
===============================================================================
my $o = ppport(qw(--nochanges));
ok($o =~ /^Scanning.*First\.xs/mi);
ok($o =~ /Analyzing.*First\.xs/mi);
ok($o =~ /^Scanning.*second\.h/mi);
ok($o =~ /Analyzing.*second\.h/mi);
ok($o =~ /^Scanning.*sub.*third\.c/mi);
ok($o =~ /Analyzing.*sub.*third\.c/mi);
ok($o !~ /^Scanning.*foobar/mi);
ok(matches($o, '^Scanning', 'm'), 3);
---------------------------- First.xs -----------------------------------------
one
---------------------------- foobar.xyz ---------------------------------------
two
---------------------------- second.h -----------------------------------------
three
---------------------------- sub/third.c --------------------------------------
four
===============================================================================
my $o = ppport(qw(--nochanges));
ok($o =~ /Possibly wrong #define NEED_foobar in.*test.xs/i);
---------------------------- test.xs ------------------------------------------
#define NEED_foobar
===============================================================================
# And now some complex "real-world" example
my $o = ppport(qw(--copy=f));
for (qw(main.xs mod1.c mod2.c mod3.c mod4.c mod5.c)) {
ok($o =~ /^Scanning.*\Q$_\E/mi);
ok($o =~ /Analyzing.*\Q$_\E/i);
}
ok(matches($o, '^Scanning', 'm'), 6);
ok(matches($o, '^Writing copy of', 'm'), 5);
ok(!-e "mod5.cf");
for (qw(main.xs mod1.c mod2.c mod3.c mod4.c)) {
ok($o =~ /^Writing copy of.*\Q$_\E.*with changes/mi);
ok(-e "${_}f");
ok(eq_files("${_}f", "${_}r"));
unlink "${_}f";
}
---------------------------- main.xs ------------------------------------------
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define NEED_newCONSTSUB
#define NEED_grok_hex_GLOBAL
#include "ppport.h"
newCONSTSUB();
grok_hex();
Perl_grok_bin(aTHX_ foo, bar);
/* some comment */
perl_eval_pv();
grok_bin();
Perl_grok_bin(bar, sv_no);
---------------------------- mod1.c -------------------------------------------
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define NEED_grok_bin_GLOBAL
#define NEED_newCONSTSUB
#include "ppport.h"
newCONSTSUB();
grok_bin();
{
Perl_croak ("foo");
Perl_sv_catpvf(); /* I know it's wrong ;-) */
}
---------------------------- mod2.c -------------------------------------------
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define NEED_eval_pv
#include "ppport.h"
newSViv();
/*
eval_pv();
*/
---------------------------- mod3.c -------------------------------------------
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
grok_oct();
eval_pv();
---------------------------- mod4.c -------------------------------------------
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
START_MY_CXT;
---------------------------- mod5.c -------------------------------------------
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
call_pv();
---------------------------- main.xsr -----------------------------------------
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define NEED_eval_pv_GLOBAL
#define NEED_grok_hex
#define NEED_newCONSTSUB_GLOBAL
#include "ppport.h"
newCONSTSUB();
grok_hex();
grok_bin(foo, bar);
/* some comment */
eval_pv();
grok_bin();
grok_bin(bar, PL_sv_no);
---------------------------- mod1.cr ------------------------------------------
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define NEED_grok_bin_GLOBAL
#include "ppport.h"
newCONSTSUB();
grok_bin();
{
Perl_croak (aTHX_ "foo");
Perl_sv_catpvf(aTHX); /* I know it's wrong ;-) */
}
---------------------------- mod2.cr ------------------------------------------
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
newSViv();
/*
eval_pv();
*/
---------------------------- mod3.cr ------------------------------------------
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#define NEED_grok_oct
#include "ppport.h"
grok_oct();
eval_pv();
---------------------------- mod4.cr ------------------------------------------
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
START_MY_CXT;
===============================================================================
my $o = ppport(qw(--nochanges));
ok($o =~ /Uses grok_hex/m);
ok($o !~ /Looks good/m);
$o = ppport(qw(--nochanges --compat-version=5.8.0));
ok($o !~ /Uses grok_hex/m);
ok($o =~ /Looks good/m);
---------------------------- FooBar.xs ----------------------------------------
grok_hex();
===============================================================================
my $o = ppport(qw(--nochanges));
ok($o =~ /Uses SvPVutf8_force, which may not be portable/m);
$o = ppport(qw(--nochanges --compat-version=5.5.3));
ok($o =~ /Uses SvPVutf8_force, which may not be portable/m);
$o = ppport(qw(--nochanges --compat-version=5.005_03));
ok($o =~ /Uses SvPVutf8_force, which may not be portable/m);
$o = ppport(qw(--nochanges --compat-version=5.6.0));
ok($o !~ /Uses SvPVutf8_force/m);
$o = ppport(qw(--nochanges --compat-version=5.006));
ok($o !~ /Uses SvPVutf8_force/m);
$o = ppport(qw(--nochanges --compat-version=5.999.999));
ok($o !~ /Uses SvPVutf8_force/m);
$o = ppport(qw(--nochanges --compat-version=6.0.0));
ok($o =~ /Only Perl 5 is supported/m);
$o = ppport(qw(--nochanges --compat-version=5.1000.999));
ok($o =~ /Invalid version number: 5.1000.999/m);
$o = ppport(qw(--nochanges --compat-version=5.999.1000));
ok($o =~ /Invalid version number: 5.999.1000/m);
---------------------------- FooBar.xs ----------------------------------------
SvPVutf8_force();
===============================================================================
my $o = ppport(qw(--nochanges));
ok($o !~ /potentially required change/);
ok(matches($o, '^Looks good', 'm'), 2);
---------------------------- FooBar.xs ----------------------------------------
#define NEED_grok_numeric_radix
#define NEED_grok_number
#include "ppport.h"
GROK_NUMERIC_RADIX();
grok_number();
---------------------------- foo.c --------------------------------------------
#include "ppport.h"
call_pv();
===============================================================================
# check --api-info option
my $o = ppport(qw(--api-info=INT2PTR));
my %found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg;
ok(scalar keys %found, 1);
ok(exists $found{INT2PTR});
ok(matches($o, '^Supported at least starting from perl-5\.6\.0\.', 'm'), 1);
ok(matches($o, '^Support by .*ppport.* provided back to perl-5\.003\.', 'm'), 1);
$o = ppport(qw(--api-info=Zero));
%found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg;
ok(scalar keys %found, 1);
ok(exists $found{Zero});
ok(matches($o, '^No portability information available\.', 'm'), 1);
$o = ppport(qw(--api-info=/Zero/));
%found = map {($_ => 1)} $o =~ /^===\s+(\w+)\s+===/mg;
ok(scalar keys %found, 2);
ok(exists $found{Zero});
ok(exists $found{ZeroD});
===============================================================================
# check --list-provided option
my @o = ppport(qw(--list-provided));
my %p;
my $fail = 0;
for (@o) {
my($name, $flags) = /^(\w+)(?:\s+\[(\w+(?:,\s+\w+)*)\])?$/ or $fail++;
exists $p{$name} and $fail++;
$p{$name} = defined $flags ? { map { ($_ => 1) } $flags =~ /(\w+)/g } : '';
}
ok(@o > 100);
ok($fail, 0);
ok(exists $p{call_sv});
ok(not ref $p{call_sv});
ok(exists $p{grok_bin});
ok(ref $p{grok_bin}, 'HASH');
ok(scalar keys %{$p{grok_bin}}, 1);
ok($p{grok_bin}{explicit});
ok(exists $p{gv_stashpvn});
ok(ref $p{gv_stashpvn}, 'HASH');
ok(scalar keys %{$p{gv_stashpvn}}, 1);
ok($p{gv_stashpvn}{hint});
ok(exists $p{sv_catpvf_mg});
ok(ref $p{sv_catpvf_mg}, 'HASH');
ok(scalar keys %{$p{sv_catpvf_mg}}, 2);
ok($p{sv_catpvf_mg}{explicit});
ok($p{sv_catpvf_mg}{depend});
===============================================================================
# check --list-unsupported option
my @o = ppport(qw(--list-unsupported));
my %p;
my $fail = 0;
for (@o) {
my($name, $ver) = /^(\w+)\s*\.+\s*([\d._]+)$/ or $fail++;
exists $p{$name} and $fail++;
$p{$name} = $ver;
}
ok(@o > 100);
ok($fail, 0);
ok(exists $p{utf8_distance});
ok($p{utf8_distance}, '5.6.0');
ok(exists $p{save_generic_svref});
ok($p{save_generic_svref}, '5.005_03');
===============================================================================
# check --nofilter option
my $o = ppport(qw(--nochanges));
ok($o =~ /^Scanning.*foo\.cpp/mi);
ok($o =~ /Analyzing.*foo\.cpp/mi);
ok(matches($o, '^Scanning', 'm'), 1);
ok(matches($o, 'Analyzing', 'm'), 1);
$o = ppport(qw(--nochanges foo.cpp foo.o Makefile.PL));
ok($o =~ /Skipping the following files \(use --nofilter to avoid this\):/m);
ok(matches($o, '^\|\s+foo\.o', 'mi'), 1);
ok(matches($o, '^\|\s+Makefile\.PL', 'mi'), 1);
ok($o =~ /^Scanning.*foo\.cpp/mi);
ok($o =~ /Analyzing.*foo\.cpp/mi);
ok(matches($o, '^Scanning', 'm'), 1);
ok(matches($o, 'Analyzing', 'm'), 1);
$o = ppport(qw(--nochanges --nofilter foo.cpp foo.o Makefile.PL));
ok($o =~ /^Scanning.*foo\.cpp/mi);
ok($o =~ /Analyzing.*foo\.cpp/mi);
ok($o =~ /^Scanning.*foo\.o/mi);
ok($o =~ /Analyzing.*foo\.o/mi);
ok($o =~ /^Scanning.*Makefile/mi);
ok($o =~ /Analyzing.*Makefile/mi);
ok(matches($o, '^Scanning', 'm'), 3);
ok(matches($o, 'Analyzing', 'm'), 3);
---------------------------- foo.cpp ------------------------------------------
newSViv();
---------------------------- foo.o --------------------------------------------
newSViv();
---------------------------- Makefile.PL --------------------------------------
newSViv();
--- NEW FILE: MY_CXT ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:15 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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
START_MY_CXT
dMY_CXT_SV
dMY_CXT
MY_CXT_INIT
MY_CXT_CLONE
MY_CXT
pMY_CXT
pMY_CXT_
_pMY_CXT
aMY_CXT
aMY_CXT_
_aMY_CXT
=implementation
/*
* Boilerplate macros for initializing and accessing interpreter-local
* data from C. All statics in extensions should be reworked to use
* this, if you want to make the extension thread-safe. See ext/re/re.xs
* for an example of the use of these macros.
*
* Code that uses these macros is responsible for the following:
* 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
* 2. Declare a typedef named my_cxt_t that is a structure that contains
* all the data that needs to be interpreter-local.
* 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
* 4. Use the MY_CXT_INIT macro such that it is called exactly once
* (typically put in the BOOT: section).
* 5. Use the members of the my_cxt_t structure everywhere as
* MY_CXT.member.
* 6. Use the dMY_CXT macro (a declaration) in all the functions that
* access MY_CXT.
*/
#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
#ifndef START_MY_CXT
/* This must appear in all extensions that define a my_cxt_t structure,
* right after the definition (i.e. at file scope). The non-threads
* case below uses it to declare the data as static. */
#define START_MY_CXT
#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
/* Fetches the SV that keeps the per-interpreter data. */
#define dMY_CXT_SV \
SV *my_cxt_sv = get_sv(MY_CXT_KEY, FALSE)
#else /* >= perl5.004_68 */
#define dMY_CXT_SV \
SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
sizeof(MY_CXT_KEY)-1, TRUE)
#endif /* < perl5.004_68 */
/* This declaration should be used within all functions that use the
* interpreter-local data. */
#define dMY_CXT \
dMY_CXT_SV; \
my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
/* Creates and zeroes the per-interpreter data.
* (We allocate my_cxtp in a Perl SV so that it will be released when
* the interpreter goes away.) */
#define MY_CXT_INIT \
dMY_CXT_SV; \
/* newSV() allocates one more than needed */ \
my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
Zero(my_cxtp, 1, my_cxt_t); \
sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
/* This macro must be used to access members of the my_cxt_t structure.
* e.g. MYCXT.some_data */
#define MY_CXT (*my_cxtp)
/* Judicious use of these macros can reduce the number of times dMY_CXT
* is used. Use is similar to pTHX, aTHX etc. */
#define pMY_CXT my_cxt_t *my_cxtp
#define pMY_CXT_ pMY_CXT,
#define _pMY_CXT ,pMY_CXT
#define aMY_CXT my_cxtp
#define aMY_CXT_ aMY_CXT,
#define _aMY_CXT ,aMY_CXT
#endif /* START_MY_CXT */
#ifndef MY_CXT_CLONE
/* Clones the per-interpreter data. */
#define MY_CXT_CLONE \
dMY_CXT_SV; \
my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
Copy(INT2PTR(my_cxt_t*, SvUV(my_cxt_sv)), my_cxtp, 1, my_cxt_t);\
sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
#endif
#else /* single interpreter */
#ifndef START_MY_CXT
#define START_MY_CXT static my_cxt_t my_cxt;
#define dMY_CXT_SV dNOOP
#define dMY_CXT dNOOP
#define MY_CXT_INIT NOOP
#define MY_CXT my_cxt
#define pMY_CXT void
#define pMY_CXT_
#define _pMY_CXT
#define aMY_CXT
#define aMY_CXT_
#define _aMY_CXT
#endif /* START_MY_CXT */
#ifndef MY_CXT_CLONE
#define MY_CXT_CLONE NOOP
#endif
#endif
=xsmisc
#define MY_CXT_KEY "Devel::PPPort::_guts" XS_VERSION
typedef struct {
/* Put Global Data in here */
int dummy;
} my_cxt_t;
START_MY_CXT
=xsboot
{
MY_CXT_INIT;
/* If any of the fields in the my_cxt_t struct need
* to be initialised, do it here.
*/
MY_CXT.dummy = 42;
}
=xsubs
int
MY_CXT_1()
CODE:
dMY_CXT;
RETVAL = MY_CXT.dummy == 42;
++MY_CXT.dummy;
OUTPUT:
RETVAL
int
MY_CXT_2()
CODE:
dMY_CXT;
RETVAL = MY_CXT.dummy == 43;
OUTPUT:
RETVAL
int
MY_CXT_CLONE()
CODE:
MY_CXT_CLONE;
RETVAL = 42;
OUTPUT:
RETVAL
=tests plan => 3
ok(&Devel::PPPort::MY_CXT_1());
ok(&Devel::PPPort::MY_CXT_2());
ok(&Devel::PPPort::MY_CXT_CLONE());
--- NEW FILE: SvPV ---
################################################################################
##
## $Revision: 1.1 $
## $Author: dslinux_cayenne $
## $Date: 2006-12-04 16:59:15 $
##
################################################################################
##
## Version 3.x, Copyright (C) 2004-2005, 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
SvPV_nolen
sv_2pv_nolen
SvPVbyte
sv_2pvbyte
sv_pvn
sv_pvn_force
=implementation
#ifndef SvPV_nolen
#if { NEED sv_2pv_nolen }
char *
sv_2pv_nolen(pTHX_ register SV *sv)
{
STRLEN n_a;
return sv_2pv(sv, &n_a);
}
#endif
/* Hint: sv_2pv_nolen
* Use the SvPV_nolen() macro instead of sv_2pv_nolen().
*/
/* SvPV_nolen depends on sv_2pv_nolen */
#define SvPV_nolen(sv) \
((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
? SvPVX(sv) : sv_2pv_nolen(sv))
#endif
#ifdef SvPVbyte
/* Hint: SvPVbyte
* Does not work in perl-5.6.1, ppport.h implements a version
* borrowed from perl-5.7.3.
*/
#if { VERSION < 5.7.0 }
#if { NEED sv_2pvbyte }
char *
sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
{
sv_utf8_downgrade(sv,0);
return SvPV(sv,*lp);
}
#endif
/* Hint: sv_2pvbyte
* Use the SvPVbyte() macro instead of sv_2pvbyte().
*/
#undef SvPVbyte
/* SvPVbyte depends on sv_2pvbyte */
#define SvPVbyte(sv, lp) \
((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pvbyte(sv, &lp))
#endif
#else
# define SvPVbyte SvPV
# define sv_2pvbyte sv_2pv
#endif
/* sv_2pvbyte_nolen depends on sv_2pv_nolen */
__UNDEFINED__ sv_2pvbyte_nolen sv_2pv_nolen
/* Hint: sv_pvn
* Always use the SvPV() macro instead of sv_pvn().
*/
__UNDEFINED__ sv_pvn(sv, len) SvPV(sv, len)
/* Hint: sv_pvn_force
* Always use the SvPV_force() macro instead of sv_pvn_force().
*/
__UNDEFINED__ sv_pvn_force(sv, len) SvPV_force(sv, len)
=xsinit
#define NEED_sv_2pv_nolen
#define NEED_sv_2pvbyte
=xsubs
IV
SvPVbyte(sv)
SV *sv
PREINIT:
STRLEN len;
const char *str;
CODE:
str = SvPVbyte(sv, len);
RETVAL = strEQ(str, "mhx") ? len : -1;
OUTPUT:
RETVAL
IV
SvPV_nolen(sv)
SV *sv
PREINIT:
const char *str;
CODE:
str = SvPV_nolen(sv);
RETVAL = strEQ(str, "mhx") ? 42 : 0;
OUTPUT:
RETVAL
=tests plan => 2
ok(&Devel::PPPort::SvPVbyte("mhx"), 3);
ok(&Devel::PPPort::SvPV_nolen("mhx"), 42);
More information about the dslinux-commit
mailing list