Perl/Pollution/Portability
Devel::PPPort::WriteFile() ; # defaults to ./ppport.h
Devel::PPPort::WriteFile('someheader.h') ;
Perl has changed over time, gaining new features, new functions,
increasing its flexibility, and reducing the impact on the C namespace
environment (reduced pollution). The header file, typicaly C<ppport.h>,
written by this module attempts to bring some of the newer Perl
features to older versions of Perl, so that you can worry less about
keeping track of old releases, but users can still reap the benefit.
Why you should use C<ppport.h> in modern code: so that your code will work
with the widest range of Perl interpreters possible, without significant
Why you should attempt older code to fully use C<ppport.h>: because
the reduced pollution of newer Perl versions is an important thing, so
important that the old polluting ways of original Perl modules will not be
supported very far into the future, and your module will almost certainly
break! By adapting to it now, you'll gained compatibility and a sense of
having done the electronic ecology some good.
How to use ppport.h: Don't direct the user to download C<Devel::PPPort>,
and don't make C<ppport.h> optional. Rather, just take the most recent
copy of C<ppport.h> that you can find (probably in C<Devel::PPPort>
on CPAN), copy it into your project, adjust your project to use it,
and distribute the header along with your module.
C<Devel::PPPort> contains a single function, called C<WriteFile>. It's
purpose is to write a 'C' header file that is used when writing XS
modules. The file contains a series of macros that allow XS modules to
be built using older versions of Perl.
This module is used by h2xs to write the file F<ppport.h>.
C<WriteFile> takes a zero or one parameters. When called with one
parameter it expects to be passed a filename. When called with no
parameters, it defults to the filename C<./pport.h>.
The function returns TRUE if the file was written successfully. Otherwise
The file written by this module, typically C<ppport.h>, provides access
to the following Perl API if not already available (and in some cases [*]
even if available, access to a fixed interface):
gv_stashpvn(str,len,flags)
newCONSTSUB(stash,name,sv)
Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
Version 2.x was ported to the Perl core by Paul Marquess.
use vars
qw( $VERSION @ISA @EXPORT @EXPORT_OK $data );
@ISA = qw(Exporter DynaLoader);
# Other items we are prepared to export if requested
$data =~ s/__VERSION__/$VERSION/g;
$data =~ s/__DATE__/$now/g;
$data =~ s/__PKG__/$pkg/g;
my $file = shift || 'ppport.h' ;
open F
, ">$file" || return undef ;
/* ppport.h -- Perl/Pollution
/Portability Version __VERSION__
* Automatically Created by __PKG__ on __DATE__
* Do NOT edit this file directly
! -- Edit PPPort
.pm instead
.
* Version
2.x
, Copyright
(C
) 2001, Paul Marquess
.
* Version
1.x
, Copyright
(C
) 1999, Kenneth Albanowski
.
* This code may be used
and distributed under the same license as any
* This version of ppport
.h is designed to support operation with Perl
* installations back to
5.004, and has been tested up to
5.8.0.
* If this version of ppport
.h is failing during the compilation of this
* module
, please check
if a newer version of Devel
::PPPort is available
* on CPAN before sending a bug report
.
* If you are using the latest version of Devel
::PPPort
and it is failing
* during compilation of this module
, please
send a report to perlbug
@perl.com
* Include all following information
:
* 1. The complete output from running
"perl -V"
* 3. The name
& version of the module you were trying to build
.
* 4. A full
log of the build that failed
.
* 5. Any other information that you think could be relevant
.
* For the latest version of this code
, please retreive the Devel
::PPPort
* In order
for a Perl extension module to be as portable as possible
* across differing versions of Perl itself
, certain steps need to be taken
.
* Including this header is the first major one
, then using dTHR is all the
* appropriate places
and using a PL_ prefix to refer to global Perl
* variables is the second
.
/* If you
use one of a few functions that were
not present
in earlier
* versions of Perl
, please add a define before the inclusion of ppport
.h
* for a static include
, or use the GLOBAL request
in a single module to
* produce a global definition that can be referenced from the other
* Function
: Static define
: Extern define
:
* newCONSTSUB
() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
/* To verify whether ppport
.h is needed
for your module
, and whether any
* special defines should be used
, ppport
.h can be run through Perl to check
* your source code
. Simply
say:
* perl
-x ppport
.h
*.c
*.h
*.xs foo
/bar
*.c
[etc
]
* The result will 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
. It won
't catch where dTHR is needed, and
* doesn't attempt to account
for global macro
or function definitions
,
* nested includes
, typemaps
, etc
.
* In order to test
for the need of dTHR
, please try your module under a
* recent version of Perl that has threading compiled
-in.
@ARGV = ("*.xs") if !@ARGV;
%badmacros = %funcs = %macros = (); $replace = 0;
$funcs{$1} = 1 if /Provide:\s+(\S+)/;
$macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/;
$replace = $1 if /Replace:\s+(\d+)/;
$badmacros{$2}=$1 if $replace and /^#\s*define\s+([a-zA-Z0-9_]+).*?\s+([a-zA-Z0-9_]+)/;
$badmacros{$1}=$2 if /Replace (\S+) with (\S+)/;
foreach $filename (map(glob($_),@ARGV)) {
unless (open(IN
, "<$filename")) {
warn "Unable to read from $file: $!\n";
print "Scanning $filename...\n";
$c = ""; while (<IN
>) { $c .= $_; } close(IN
);
$need_include = 0; %add_func = (); $changes = 0;
$has_include = ($c =~ /#.*include.*ppport/m);
foreach $func (keys %funcs) {
if ($c =~ /#.*define.*\bNEED_$func(_GLOBAL)?\b/m) {
if ($c !~ /\b$func\b/m) {
print "If $func isn't needed, you don't need to request it.\n" if
$changes += ($c =~ s/^.*#.*define.*\bNEED_$func\b.*\n//m);
if ($c =~ /\b$func\b/m) {
foreach $macro (keys %macros) {
if ($c =~ /\b$macro\b/m) {
foreach $badmacro (keys %badmacros) {
if ($c =~ /\b$badmacro\b/m) {
$changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm);
print "Uses $badmacros{$badmacro} (instead of $badmacro)\n";
if (scalar(keys %add_func) or $need_include != $has_include) {
$inc = join('',map("#define NEED_$_\n", sort keys %add_func)).
"#include \"ppport.h\"\n";
$c = "$inc$c" unless $c =~ s/#.*include.*XSUB.*\n/$&$inc/m;
} elsif (keys %add_func) {
$inc = join('',map("#define NEED_$_\n", sort keys %add_func));
$c = "$inc$c" unless $c =~ s/^.*#.*include.*ppport.*$/$inc$&/m;
print "Doesn't seem to need ppport.h.\n";
$c =~ s/^.*#.*include.*ppport.*\n//m;
open(OUT
,">/tmp/ppport.h.$$");
open(DIFF
, "diff -u $filename /tmp/ppport.h.$$|");
while (<DIFF
>) { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT
; }
unlink("/tmp/ppport.h.$$");
#ifndef _P_P_PORTABILITY_H_
#define _P_P_PORTABILITY_H_
# ifndef __PATCHLEVEL_H_INCLUDED__
# define PERL_REVISION (5)
# define PERL_VERSION PATCHLEVEL
# define PERL_SUBVERSION SUBVERSION
/* Replace PERL_PATCHLEVEL with PERL_VERSION */
#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
.
# error ppport.h only works with Perl version 5
#endif /* PERL_REVISION != 5 */
# define ERRSV perl_get_sv("@",FALSE)
#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
# define PL_compiling compiling
# define PL_copline copline
# define PL_curcop curcop
# define PL_curstash curstash
# define PL_dowarn dowarn
# define PL_perldb perldb
# define PL_rsfp_filters rsfp_filters
# define PL_stdingv stdingv
# define PL_sv_undef sv_undef
# define PL_sv_yes sv_yes
# if defined(__GNUC__) && defined(__cplusplus)
# define PERL_UNUSED_DECL
# define PERL_UNUSED_DECL __attribute__((unused))
# define PERL_UNUSED_DECL
# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
# define NVTYPE long double
#if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
# define INT2PTR(any,d) (any)(d)
# define PTRV unsigned long
# define INT2PTR(any,d) (any)(PTRV)(d)
#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)
# define PTR2ul(p) (unsigned long)(p)
# define PTR2ul(p) INT2PTR(unsigned long,p)
# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
# define newRV_inc(sv) newRV(sv)
/* DEFSV appears first in 5.004_56 */
# define DEFSV GvSV(PL_defgv)
# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
# define newRV_noinc(sv) \
SV
*nsv
= (SV
*)newRV
(sv
); \
# if defined(USE_THREADS)
static SV
* newRV_noinc
(SV
* sv
)
SV
*nsv
= (SV
*)newRV
(sv
);
# define newRV_noinc(sv) \
(PL_Sv
=(SV
*)newRV
(sv
), SvREFCNT_dec
(sv
), (SV
*)PL_Sv
)
/* Provide: newCONSTSUB */
/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
#if defined(NEED_newCONSTSUB)
extern void newCONSTSUB
(HV
* stash
, char
* name
, SV
*sv
);
#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
newCONSTSUB
(stash
,name
,sv
)
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
;
PL_curstash
= PL_curcop
->cop_stash = stash
;
#if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
start_subparse
(FALSE
, 0),
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_curcop
->cop_stash = old_cop_stash
;
PL_curstash
= old_curstash
;
PL_curcop
->cop_line = oldline
;
* 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
* 6. Use the dMY_CXT macro
(a declaration
) in all the functions that
#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
defined(PERL_CAPI
) || defined(PERL_IMPLICIT_CONTEXT
)
/* 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
. */
#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
/* Fetches the SV that keeps the per-interpreter data. */
SV
*my_cxt_sv
= perl_get_sv
(MY_CXT_KEY
, FALSE
)
#else /* >= perl5.004_68 */
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
. */
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
.) */
/* 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_ aMY_CXT,
#define _aMY_CXT ,aMY_CXT
#else /* single interpreter */
#define START_MY_CXT static my_cxt_t my_cxt;
#endif /* START_MY_CXT */
# 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
#ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */
# if PERL_REVISION == 5 && PERL_VERSION < 7
/* SvPVbyte does not work in perl-5.6.1, borrowed version for 5.7.3 */
# define SvPVbyte(sv, lp) \
((SvFLAGS
(sv
) & (SVf_POK
|SVf_UTF8
)) == (SVf_POK
) \
?
((lp
= SvCUR
(sv
)), SvPVX
(sv
)) : my_sv_2pvbyte
(aTHX_ sv
, &lp
))
my_sv_2pvbyte
(pTHX_ register SV
*sv
, STRLEN
*lp
)
#endif /* _P_P_PORTABILITY_H_ */
/* End of File ppport.h */