[perl5.git] / ext / Devel / PPPort / PPPort.pm


package Devel::PPPort;

=head1 NAME

Perl/Pollution/Portability

=head1 SYNOPSIS

    Devel::PPPort::WriteFile() ; # defaults to ./ppport.h
    Devel::PPPort::WriteFile('someheader.h') ;

=head1 DESCRIPTION

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
additional work.

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>. 

=head2 WriteFile

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
it returns FALSE.

=head1 ppport.h

The file written by this module, typically C<ppport.h>, provides access
to the following Perl API if not already available:

    DEFSV
    ERRSV
    INT2PTR(any,d)
    MY_CXT
    MY_CXT_INIT
    NOOP
    PERL_REVISION
    PERL_SUBVERSION
    PERL_UNUSED_DECL
    PERL_VERSION
    PL_Sv
    PL_compiling
    PL_copline
    PL_curcop
    PL_curstash
    PL_defgv
    PL_dirty
    PL_hints
    PL_na
    PL_perldb
    PL_rsfp_filters
    PL_rsfpv
    PL_stdingv
    PL_sv_no
    PL_sv_undef
    PL_sv_yes
    PTR2IV(d)
    SAVE_DEFSV
    START_MY_CXT
    _aMY_CXT
    _pMY_CXT
    aMY_CXT
    aMY_CXT_
    aTHX
    aTHX_
    boolSV(b)
    dMY_CXT	
    dMY_CXT_SV
    dNOOP
    dTHR
    gv_stashpvn(str,len,flags)
    newCONSTSUB(stash,name,sv)
    newRV_inc(sv)
    newRV_noinc(sv)
    newSVpvn(data,len)
    pMY_CXT
    pMY_CXT_
    pTHX
    pTHX_

=head1 AUTHOR

Version 1.x of Devel::PPPort was written by Kenneth Albanowski.

Version 2.x was ported to the Perl core by Paul Marquess.

=head1 SEE ALSO

See L<h2xs>.

=cut


package Devel::PPPort;

require Exporter;
require DynaLoader;
#use warnings;
use strict;
use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK $data );

$VERSION = "2.0002";

@ISA = qw(Exporter DynaLoader);
@EXPORT =  qw();
# Other items we are prepared to export if requested
@EXPORT_OK = qw( );

bootstrap Devel::PPPort;

package Devel::PPPort;

{
    local $/ = undef;
    $data = <DATA> ;
    my $now = localtime;
    my $pkg = __PACKAGE__;
    $data =~ s/__VERSION__/$VERSION/g;
    $data =~ s/__DATE__/$now/g;
    $data =~ s/__PKG__/$pkg/g;
}

sub WriteFile
{
    my $file = shift || 'ppport.h' ;

    open F, ">$file" || return undef ;
    print F $data ;
    close F;

    return 1 ;
}

1;

__DATA__;

/* 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
 * version of Perl.
 * 
 * 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"
 *
 *  2. This file.
 *
 *  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
 * module from CPAN.
 * 
 */

/*
 * 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
 * modules.
 * 
 * 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.
 *
 */ 


/*
#!/usr/bin/perl
@ARGV = ("*.xs") if !@ARGV;
%badmacros = %funcs = %macros = (); $replace = 0;
foreach (<DATA>) {
	$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";
		next;
	}
	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);
			} else {
				print "Uses $func\n";
				$need_include = 1;
			}
		} else {
			if ($c =~ /\b$func\b/m) {
				$add_func{$func} =1 ;
				print "Uses $func\n";
				$need_include = 1;
			}
		}
	}

	if (not $need_include) {
		foreach $macro (keys %macros) {
			if ($c =~ /\b$macro\b/m) {
				print "Uses $macro\n";
				$need_include = 1;
			}
		}
	}

	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";
			$need_include = 1;
		}
	}
	
	if (scalar(keys %add_func) or $need_include != $has_include) {
		if (!$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;
		}
		if (!$need_include) {
			print "Doesn't seem to need ppport.h.\n";
			$c =~ s/^.*#.*include.*ppport.*\n//m;
		}
		$changes++;
	}
	
	if ($changes) {
		open(OUT,">/tmp/ppport.h.$$");
		print OUT $c;
		close(OUT);
		open(DIFF, "diff -u $filename /tmp/ppport.h.$$|");
		while (<DIFF>) { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT; }
		close(DIFF);
		unlink("/tmp/ppport.h.$$");
	} else {
		print "Looks OK\n";
	}
}
__DATA__
*/

#ifndef _P_P_PORTABILITY_H_
#define _P_P_PORTABILITY_H_

#ifndef PERL_REVISION
#   ifndef __PATCHLEVEL_H_INCLUDED__
#       include "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 */

#ifndef ERRSV
#	define ERRSV perl_get_sv("@",FALSE)
#endif

#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
/* Replace: 1 */
#	define PL_Sv		Sv
#	define PL_compiling	compiling
#	define PL_copline	copline
#	define PL_curcop	curcop
#	define PL_curstash	curstash
#	define PL_defgv		defgv
#	define PL_dirty		dirty
#	define PL_dowarn	dowarn
#	define PL_hints		hints
#	define PL_na		na
#	define PL_perldb	perldb
#	define PL_rsfp_filters	rsfp_filters
#	define PL_rsfpv		rsfp
#	define PL_stdingv	stdingv
#	define PL_sv_no		sv_no
#	define PL_sv_undef	sv_undef
#	define PL_sv_yes	sv_yes
/* Replace: 0 */
#endif

#ifdef HASATTRIBUTE
#  if defined(__GNUC__) && defined(__cplusplus)
#    define PERL_UNUSED_DECL
#  else
#    define PERL_UNUSED_DECL __attribute__((unused))
#  endif
#else
#  define PERL_UNUSED_DECL
#endif

#ifndef dNOOP
#  define NOOP (void)0
#  define dNOOP extern int Perl___notused PERL_UNUSED_DECL
#endif

#ifndef dTHR
#  define dTHR          dNOOP
#endif

#ifndef dTHX
#  define dTHX          dNOOP
#  define dTHXa(x)      dNOOP
#  define dTHXoa(x)     dNOOP
#endif

#ifndef pTHX
#    define pTHX	void
#    define pTHX_
#    define aTHX
#    define aTHX_
#endif         

#ifndef PTR2IV
#    define PTR2IV(d)   (IV)(d)
#endif
 
#ifndef INT2PTR
#    define INT2PTR(any,d)      (any)(d)
#endif

#ifndef boolSV
#	define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
#endif

#ifndef gv_stashpvn
#	define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
#endif

#ifndef newSVpvn
#	define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
#endif

#ifndef newRV_inc
/* Replace: 1 */
#	define newRV_inc(sv) newRV(sv)
/* Replace: 0 */
#endif

/* DEFSV appears first in 5.004_56 */
#ifndef DEFSV
#  define DEFSV	GvSV(PL_defgv)
#endif

#ifndef SAVE_DEFSV
#    define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
#endif

#ifndef newRV_noinc
#  ifdef __GNUC__
#    define newRV_noinc(sv)               \
      ({                                  \
          SV *nsv = (SV*)newRV(sv);       \
          SvREFCNT_dec(sv);               \
          nsv;                            \
      })
#  else
#    if defined(USE_THREADS)
static SV * newRV_noinc (SV * sv)
{
          SV *nsv = (SV*)newRV(sv);       
          SvREFCNT_dec(sv);               
          return nsv;                     
}
#    else
#      define newRV_noinc(sv)    \
        (PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
#    endif
#  endif
#endif

/* 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)
static
#else
extern void newCONSTSUB(HV * stash, char * name, SV *sv);
#endif

#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
void
newCONSTSUB(stash,name,sv)
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 (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
     /* before 5.003_22 */
		start_subparse(),
#else
#  if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
     /* 5.003_22 */
     		start_subparse(0),
#  else
     /* 5.003_23  onwards */
     		start_subparse(FALSE, 0),
#  endif
#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 /* newCONSTSUB */

#ifndef START_MY_CXT

/*
 * 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)

/* 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 = perl_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

#else /* single interpreter */


#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 

#endif /* START_MY_CXT */

#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

#ifndef UVSIZE
#   define UVSIZE IVSIZE
#endif

#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 */

#ifndef AvFILLp			/* Older perls (<=5.003) lack AvFILLp */
#   define AvFILLp AvFILL
#endif

#endif /* _P_P_PORTABILITY_H_ */

/* End of File ppport.h */
Commit	Line	Data
0a7c7f4f JH	1
	2	package Devel::PPPort;
	3
	4	=head1 NAME
	5
	6	Perl/Pollution/Portability
	7
	8	=head1 SYNOPSIS
	9
	10	Devel::PPPort::WriteFile() ; # defaults to ./ppport.h
	11	Devel::PPPort::WriteFile('someheader.h') ;
	12
	13	=head1 DESCRIPTION
	14
44284200 JH	15	Perl has changed over time, gaining new features, new functions,
	16	increasing its flexibility, and reducing the impact on the C namespace
	17	environment (reduced pollution). The header file, typicaly C<ppport.h>,
	18	written by this module attempts to bring some of the newer Perl
	19	features to older versions of Perl, so that you can worry less about
	20	keeping track of old releases, but users can still reap the benefit.
	21
	22	Why you should use C<ppport.h> in modern code: so that your code will work
	23	with the widest range of Perl interpreters possible, without significant
	24	additional work.
	25
	26	Why you should attempt older code to fully use C<ppport.h>: because
	27	the reduced pollution of newer Perl versions is an important thing, so
	28	important that the old polluting ways of original Perl modules will not be
	29	supported very far into the future, and your module will almost certainly
	30	break! By adapting to it now, you'll gained compatibility and a sense of
	31	having done the electronic ecology some good.
	32
	33	How to use ppport.h: Don't direct the user to download C<Devel::PPPort>,
	34	and don't make C<ppport.h> optional. Rather, just take the most recent
	35	copy of C<ppport.h> that you can find (probably in C<Devel::PPPort>
	36	on CPAN), copy it into your project, adjust your project to use it,
	37	and distribute the header along with your module.
	38
	39	C<Devel::PPPort> contains a single function, called C<WriteFile>. It's
	40	purpose is to write a 'C' header file that is used when writing XS
	41	modules. The file contains a series of macros that allow XS modules to
	42	be built using older versions of Perl.
	43
	44	This module is used by h2xs to write the file F<ppport.h>.
0a7c7f4f JH	45
	46	=head2 WriteFile
	47
	48	C<WriteFile> takes a zero or one parameters. When called with one
	49	parameter it expects to be passed a filename. When called with no
	50	parameters, it defults to the filename C<./pport.h>.
	51
	52	The function returns TRUE if the file was written successfully. Otherwise
	53	it returns FALSE.
	54
44284200 JH	55	=head1 ppport.h
	56
	57	The file written by this module, typically C<ppport.h>, provides access
	58	to the following Perl API if not already available:
	59
	60	DEFSV
	61	ERRSV
	62	INT2PTR(any,d)
	63	MY_CXT
	64	MY_CXT_INIT
	65	NOOP
	66	PERL_REVISION
	67	PERL_SUBVERSION
	68	PERL_UNUSED_DECL
	69	PERL_VERSION
	70	PL_Sv
	71	PL_compiling
	72	PL_copline
	73	PL_curcop
	74	PL_curstash
	75	PL_defgv
	76	PL_dirty
	77	PL_hints
	78	PL_na
	79	PL_perldb
	80	PL_rsfp_filters
	81	PL_rsfpv
	82	PL_stdingv
	83	PL_sv_no
	84	PL_sv_undef
	85	PL_sv_yes
	86	PTR2IV(d)
	87	SAVE_DEFSV
	88	START_MY_CXT
	89	_aMY_CXT
	90	_pMY_CXT
	91	aMY_CXT
	92	aMY_CXT_
	93	aTHX
	94	aTHX_
	95	boolSV(b)
	96	dMY_CXT
	97	dMY_CXT_SV
	98	dNOOP
	99	dTHR
	100	gv_stashpvn(str,len,flags)
	101	newCONSTSUB(stash,name,sv)
	102	newRV_inc(sv)
	103	newRV_noinc(sv)
	104	newSVpvn(data,len)
	105	pMY_CXT
	106	pMY_CXT_
	107	pTHX
	108	pTHX_
	109
0a7c7f4f JH	110	=head1 AUTHOR
0a7c7f4f JH	111
dbda3434	112	Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
0a7c7f4f	113
dbda3434	114	Version 2.x was ported to the Perl core by Paul Marquess.
0a7c7f4f JH	115
	116	=head1 SEE ALSO
	117
	118	See L<h2xs>.
	119
	120	=cut
	121
44284200 JH	122
	123	package Devel::PPPort;
	124
	125	require Exporter;
	126	require DynaLoader;
0a7c7f4f JH	127	#use warnings;
0a7c7f4f JH	128	use strict;
44284200 JH	129	use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK $data );
	130
	131	$VERSION = "2.0002";
	132
	133	@ISA = qw(Exporter DynaLoader);
	134	@EXPORT = qw();
	135	# Other items we are prepared to export if requested
	136	@EXPORT_OK = qw( );
0a7c7f4f	137
44284200 JH	138	bootstrap Devel::PPPort;
	139
	140	package Devel::PPPort;
0a7c7f4f JH	141
	142	{
	143	local $/ = undef;
	144	$data = <DATA> ;
	145	my $now = localtime;
	146	my $pkg = __PACKAGE__;
dbda3434 PM	147	$data =~ s/__VERSION__/$VERSION/g;
	148	$data =~ s/__DATE__/$now/g;
	149	$data =~ s/__PKG__/$pkg/g;
0a7c7f4f JH	150	}
	151
	152	sub WriteFile
	153	{
	154	my $file = shift \|\| 'ppport.h' ;
	155
	156	open F, ">$file" \|\| return undef ;
	157	print F $data ;
	158	close F;
	159
	160	return 1 ;
	161	}
	162
	163	1;
	164
	165	__DATA__;
0a7c7f4f	166
44284200 JH	167	/* ppport.h -- Perl/Pollution/Portability Version __VERSION__
	168	*
	169	* Automatically Created by __PKG__ on __DATE__
	170	*
	171	* Do NOT edit this file directly! -- Edit PPPort.pm instead.
	172	*
	173	* Version 2.x, Copyright (C) 2001, Paul Marquess.
	174	* Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
	175	* This code may be used and distributed under the same license as any
	176	* version of Perl.
	177	*
	178	* This version of ppport.h is designed to support operation with Perl
	179	* installations back to 5.004, and has been tested up to 5.8.0.
	180	*
	181	* If this version of ppport.h is failing during the compilation of this
	182	* module, please check if a newer version of Devel::PPPort is available
	183	* on CPAN before sending a bug report.
	184	*
	185	* If you are using the latest version of Devel::PPPort and it is failing
	186	* during compilation of this module, please send a report to perlbug@perl.com
	187	*
	188	* Include all following information:
	189	*
	190	* 1. The complete output from running "perl -V"
	191	*
	192	* 2. This file.
	193	*
	194	* 3. The name & version of the module you were trying to build.
	195	*
	196	* 4. A full log of the build that failed.
	197	*
	198	* 5. Any other information that you think could be relevant.
	199	*
	200	*
	201	* For the latest version of this code, please retreive the Devel::PPPort
	202	* module from CPAN.
	203	*
	204	*/
0a7c7f4f JH	205
0a7c7f4f JH	206	/*
44284200 JH	207	* In order for a Perl extension module to be as portable as possible
	208	* across differing versions of Perl itself, certain steps need to be taken.
	209	* Including this header is the first major one, then using dTHR is all the
	210	* appropriate places and using a PL_ prefix to refer to global Perl
	211	* variables is the second.
	212	*
	213	*/
0a7c7f4f JH	214
	215
	216	/* If you use one of a few functions that were not present in earlier
44284200 JH	217	* versions of Perl, please add a define before the inclusion of ppport.h
	218	* for a static include, or use the GLOBAL request in a single module to
	219	* produce a global definition that can be referenced from the other
	220	* modules.
	221	*
	222	* Function: Static define: Extern define:
	223	* newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
	224	*
	225	*/
0a7c7f4f JH	226
	227
	228	/* To verify whether ppport.h is needed for your module, and whether any
44284200 JH	229	* special defines should be used, ppport.h can be run through Perl to check
	230	* your source code. Simply say:
	231	*
20d72259	232	* perl -x ppport.h .c .h .xs foo/bar.c [etc]
44284200 JH	233	*
	234	* The result will be a list of patches suggesting changes that should at
	235	* least be acceptable, if not necessarily the most efficient solution, or a
	236	* fix for all possible problems. It won't catch where dTHR is needed, and
	237	* doesn't attempt to account for global macro or function definitions,
	238	* nested includes, typemaps, etc.
	239	*
	240	* In order to test for the need of dTHR, please try your module under a
	241	* recent version of Perl that has threading compiled-in.
	242	*
	243	*/
0a7c7f4f JH	244
	245
	246	/*
	247	#!/usr/bin/perl
	248	@ARGV = ("*.xs") if !@ARGV;
	249	%badmacros = %funcs = %macros = (); $replace = 0;
	250	foreach (<DATA>) {
	251	$funcs{$1} = 1 if /Provide:\s+(\S+)/;
	252	$macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/;
	253	$replace = $1 if /Replace:\s+(\d+)/;
	254	$badmacros{$2}=$1 if $replace and /^#\sdefine\s+([a-zA-Z0-9_]+).?\s+([a-zA-Z0-9_]+)/;
	255	$badmacros{$1}=$2 if /Replace (\S+) with (\S+)/;
	256	}
	257	foreach $filename (map(glob($_),@ARGV)) {
	258	unless (open(IN, "<$filename")) {
	259	warn "Unable to read from $file: $!\n";
	260	next;
	261	}
	262	print "Scanning $filename...\n";
	263	$c = ""; while (<IN>) { $c .= $_; } close(IN);
	264	$need_include = 0; %add_func = (); $changes = 0;
	265	$has_include = ($c =~ /#.include.ppport/m);
	266
	267	foreach $func (keys %funcs) {
	268	if ($c =~ /#.define.\bNEED_$func(_GLOBAL)?\b/m) {
	269	if ($c !~ /\b$func\b/m) {
	270	print "If $func isn't needed, you don't need to request it.\n" if
	271	$changes += ($c =~ s/^.#.define.\bNEED_$func\b.\n//m);
	272	} else {
	273	print "Uses $func\n";
	274	$need_include = 1;
	275	}
	276	} else {
	277	if ($c =~ /\b$func\b/m) {
	278	$add_func{$func} =1 ;
	279	print "Uses $func\n";
	280	$need_include = 1;
	281	}
	282	}
	283	}
	284
	285	if (not $need_include) {
	286	foreach $macro (keys %macros) {
	287	if ($c =~ /\b$macro\b/m) {
	288	print "Uses $macro\n";
	289	$need_include = 1;
	290	}
	291	}
	292	}
	293
	294	foreach $badmacro (keys %badmacros) {
	295	if ($c =~ /\b$badmacro\b/m) {
	296	$changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm);
	297	print "Uses $badmacros{$badmacro} (instead of $badmacro)\n";
	298	$need_include = 1;
	299	}
	300	}
	301
	302	if (scalar(keys %add_func) or $need_include != $has_include) {
	303	if (!$has_include) {
	304	$inc = join('',map("#define NEED_$_\n", sort keys %add_func)).
	305	"#include \"ppport.h\"\n";
	306	$c = "$inc$c" unless $c =~ s/#.include.XSUB.*\n/$&$inc/m;
	307	} elsif (keys %add_func) {
308	$inc = join('',map("#define NEED_$_\n", sort keys %add_func));
309	$c = "$inc$c" unless $c =~ s/^.#.include.ppport.$/$inc$&/m;
310	}
311	if (!$need_include) {
312	print "Doesn't seem to need ppport.h.\n";
313	$c =~ s/^.#.include.ppport.\n//m;
314	}
315	$changes++;
316	}
317
318	if ($changes) {
319	open(OUT,">/tmp/ppport.h.$$");
320	print OUT $c;
321	close(OUT);
322	open(DIFF, "diff -u $filename /tmp/ppport.h.$$\|");
323	while (<DIFF>) { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT; }
324	close(DIFF);
325	unlink("/tmp/ppport.h.$$");
326	} else {
327	print "Looks OK\n";
328	}
329	}
330	__DATA__
331	*/
332
44284200 JH	333	#ifndef _P_P_PORTABILITY_H_
	334	#define _P_P_PORTABILITY_H_
	335
0a7c7f4f JH	336	#ifndef PERL_REVISION
	337	# ifndef __PATCHLEVEL_H_INCLUDED__
	338	# include "patchlevel.h"
	339	# endif
	340	# ifndef PERL_REVISION
	341	# define PERL_REVISION (5)
	342	/* Replace: 1 */
	343	# define PERL_VERSION PATCHLEVEL
	344	# define PERL_SUBVERSION SUBVERSION
	345	/* Replace PERL_PATCHLEVEL with PERL_VERSION */
	346	/* Replace: 0 */
	347	# endif
	348	#endif
	349
	350	#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
	351
44284200 JH	352	/* It is very unlikely that anyone will try to use this with Perl 6
	353	(or greater), but who knows.
	354	*/
	355	#if PERL_REVISION != 5
	356	# error ppport.h only works with Perl version 5
	357	#endif /* PERL_REVISION != 5 */
	358
0a7c7f4f JH	359	#ifndef ERRSV
	360	# define ERRSV perl_get_sv("@",FALSE)
	361	#endif
	362
	363	#if (PERL_VERSION < 4) \|\| ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
	364	/* Replace: 1 */
	365	# define PL_Sv Sv
	366	# define PL_compiling compiling
	367	# define PL_copline copline
	368	# define PL_curcop curcop
	369	# define PL_curstash curstash
	370	# define PL_defgv defgv
	371	# define PL_dirty dirty
b9381339	372	# define PL_dowarn dowarn
0a7c7f4f JH	373	# define PL_hints hints
	374	# define PL_na na
	375	# define PL_perldb perldb
	376	# define PL_rsfp_filters rsfp_filters
	377	# define PL_rsfpv rsfp
	378	# define PL_stdingv stdingv
	379	# define PL_sv_no sv_no
	380	# define PL_sv_undef sv_undef
	381	# define PL_sv_yes sv_yes
	382	/* Replace: 0 */
	383	#endif
	384
5a0bf5be JH	385	#ifdef HASATTRIBUTE
	386	# if defined(__GNUC__) && defined(__cplusplus)
	387	# define PERL_UNUSED_DECL
	388	# else
	389	# define PERL_UNUSED_DECL __attribute__((unused))
	390	# endif
	391	#else
	392	# define PERL_UNUSED_DECL
	393	#endif
	394
	395	#ifndef dNOOP
	396	# define NOOP (void)0
	397	# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
	398	#endif
	399
	400	#ifndef dTHR
	401	# define dTHR dNOOP
	402	#endif
	403
	404	#ifndef dTHX
	405	# define dTHX dNOOP
	406	# define dTHXa(x) dNOOP
	407	# define dTHXoa(x) dNOOP
	408	#endif
	409
0a7c7f4f	410	#ifndef pTHX
5a0bf5be	411	# define pTHX void
0a7c7f4f JH	412	# define pTHX_
	413	# define aTHX
	414	# define aTHX_
	415	#endif
	416
	417	#ifndef PTR2IV
	418	# define PTR2IV(d) (IV)(d)
	419	#endif
	420
	421	#ifndef INT2PTR
	422	# define INT2PTR(any,d) (any)(d)
	423	#endif
	424
0a7c7f4f JH	425	#ifndef boolSV
	426	# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
	427	#endif
	428
	429	#ifndef gv_stashpvn
	430	# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
	431	#endif
	432
	433	#ifndef newSVpvn
	434	# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
	435	#endif
	436
	437	#ifndef newRV_inc
	438	/* Replace: 1 */
	439	# define newRV_inc(sv) newRV(sv)
	440	/* Replace: 0 */
	441	#endif
	442
	443	/* DEFSV appears first in 5.004_56 */
	444	#ifndef DEFSV
	445	# define DEFSV GvSV(PL_defgv)
	446	#endif
	447
	448	#ifndef SAVE_DEFSV
	449	# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
	450	#endif
	451
	452	#ifndef newRV_noinc
	453	# ifdef __GNUC__
	454	# define newRV_noinc(sv) \
	455	({ \
	456	SV nsv = (SV)newRV(sv); \
	457	SvREFCNT_dec(sv); \
	458	nsv; \
	459	})
	460	# else
9ede5bc8	461	# if defined(USE_THREADS)
0a7c7f4f JH	462	static SV * newRV_noinc (SV * sv)
	463	{
	464	SV nsv = (SV)newRV(sv);
	465	SvREFCNT_dec(sv);
	466	return nsv;
	467	}
	468	# else
	469	# define newRV_noinc(sv) \
97dc1cde	470	(PL_Sv=(SV)newRV(sv), SvREFCNT_dec(sv), (SV)PL_Sv)
0a7c7f4f JH	471	# endif
	472	# endif
	473	#endif
	474
	475	/* Provide: newCONSTSUB */
	476
	477	/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
	478	#if (PERL_VERSION < 4) \|\| ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
	479
	480	#if defined(NEED_newCONSTSUB)
	481	static
	482	#else
c68a00c0	483	extern void newCONSTSUB(HV * stash, char * name, SV *sv);
0a7c7f4f JH	484	#endif
	485
	486	#if defined(NEED_newCONSTSUB) \|\| defined(NEED_newCONSTSUB_GLOBAL)
	487	void
	488	newCONSTSUB(stash,name,sv)
	489	HV *stash;
	490	char *name;
	491	SV *sv;
	492	{
	493	U32 oldhints = PL_hints;
	494	HV *old_cop_stash = PL_curcop->cop_stash;
	495	HV *old_curstash = PL_curstash;
	496	line_t oldline = PL_curcop->cop_line;
	497	PL_curcop->cop_line = PL_copline;
	498
	499	PL_hints &= ~HINT_BLOCK_SCOPE;
	500	if (stash)
	501	PL_curstash = PL_curcop->cop_stash = stash;
	502
	503	newSUB(
	504
	505	#if (PERL_VERSION < 3) \|\| ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
	506	/* before 5.003_22 */
	507	start_subparse(),
	508	#else
	509	# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
	510	/* 5.003_22 */
	511	start_subparse(0),
	512	# else
	513	/* 5.003_23 onwards */
	514	start_subparse(FALSE, 0),
	515	# endif
	516	#endif
	517
	518	newSVOP(OP_CONST, 0, newSVpv(name,0)),
	519	newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
	520	newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
	521	);
	522
	523	PL_hints = oldhints;
	524	PL_curcop->cop_stash = old_cop_stash;
	525	PL_curstash = old_curstash;
	526	PL_curcop->cop_line = oldline;
	527	}
	528	#endif
	529
	530	#endif /* newCONSTSUB */
	531
0a7c7f4f JH	532	#ifndef START_MY_CXT
	533
	534	/*
	535	* Boilerplate macros for initializing and accessing interpreter-local
	536	* data from C. All statics in extensions should be reworked to use
	537	* this, if you want to make the extension thread-safe. See ext/re/re.xs
	538	* for an example of the use of these macros.
	539	*
	540	* Code that uses these macros is responsible for the following:
	541	* 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
	542	* 2. Declare a typedef named my_cxt_t that is a structure that contains
	543	* all the data that needs to be interpreter-local.
	544	* 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
	545	* 4. Use the MY_CXT_INIT macro such that it is called exactly once
	546	* (typically put in the BOOT: section).
	547	* 5. Use the members of the my_cxt_t structure everywhere as
	548	* MY_CXT.member.
	549	* 6. Use the dMY_CXT macro (a declaration) in all the functions that
	550	* access MY_CXT.
	551	*/
	552
	553	#if defined(MULTIPLICITY) \|\| defined(PERL_OBJECT) \|\| \
	554	defined(PERL_CAPI) \|\| defined(PERL_IMPLICIT_CONTEXT)
	555
	556	/* This must appear in all extensions that define a my_cxt_t structure,
	557	* right after the definition (i.e. at file scope). The non-threads
	558	* case below uses it to declare the data as static. */
	559	#define START_MY_CXT
	560
44284200	561	#if (PERL_VERSION < 4 \|\| (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
0a7c7f4f JH	562	/* Fetches the SV that keeps the per-interpreter data. */
	563	#define dMY_CXT_SV \
	564	SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
	565	#else /* >= perl5.004_68 */
	566	#define dMY_CXT_SV \
	567	SV my_cxt_sv = hv_fetch(PL_modglobal, MY_CXT_KEY, \
	568	sizeof(MY_CXT_KEY)-1, TRUE)
	569	#endif /* < perl5.004_68 */
	570
	571	/* This declaration should be used within all functions that use the
	572	* interpreter-local data. */
	573	#define dMY_CXT \
	574	dMY_CXT_SV; \
	575	my_cxt_t my_cxtp = INT2PTR(my_cxt_t,SvUV(my_cxt_sv))
	576
	577	/* Creates and zeroes the per-interpreter data.
	578	* (We allocate my_cxtp in a Perl SV so that it will be released when
	579	* the interpreter goes away.) */
	580	#define MY_CXT_INIT \
	581	dMY_CXT_SV; \
	582	/* newSV() allocates one more than needed */ \
	583	my_cxt_t my_cxtp = (my_cxt_t)SvPVX(newSV(sizeof(my_cxt_t)-1));\
	584	Zero(my_cxtp, 1, my_cxt_t); \
	585	sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
	586
	587	/* This macro must be used to access members of the my_cxt_t structure.
	588	* e.g. MYCXT.some_data */
	589	#define MY_CXT (*my_cxtp)
	590
	591	/* Judicious use of these macros can reduce the number of times dMY_CXT
	592	* is used. Use is similar to pTHX, aTHX etc. */
	593	#define pMY_CXT my_cxt_t *my_cxtp
	594	#define pMY_CXT_ pMY_CXT,
	595	#define _pMY_CXT ,pMY_CXT
	596	#define aMY_CXT my_cxtp
	597	#define aMY_CXT_ aMY_CXT,
	598	#define _aMY_CXT ,aMY_CXT
	599
	600	#else /* single interpreter */
	601
0a7c7f4f JH	602
	603	#define START_MY_CXT static my_cxt_t my_cxt;
	604	#define dMY_CXT_SV dNOOP
	605	#define dMY_CXT dNOOP
	606	#define MY_CXT_INIT NOOP
	607	#define MY_CXT my_cxt
	608
	609	#define pMY_CXT void
	610	#define pMY_CXT_
	611	#define _pMY_CXT
	612	#define aMY_CXT
	613	#define aMY_CXT_
	614	#define _aMY_CXT
	615
	616	#endif
	617
	618	#endif /* START_MY_CXT */
	619
4b729f51 JH	620	#ifndef IVdf
	621	# if IVSIZE == LONGSIZE
	622	# define IVdf "ld"
	623	# define UVuf "lu"
	624	# define UVof "lo"
	625	# define UVxf "lx"
	626	# define UVXf "lX"
	627	# else
	628	# if IVSIZE == INTSIZE
	629	# define IVdf "d"
	630	# define UVuf "u"
	631	# define UVof "o"
	632	# define UVxf "x"
	633	# define UVXf "X"
	634	# endif
	635	# endif
	636	#endif
	637
	638	#ifndef NVef
	639	# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
	640	defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
	641	# define NVef PERL_PRIeldbl
	642	# define NVff PERL_PRIfldbl
	643	# define NVgf PERL_PRIgldbl
	644	# else
	645	# define NVef "e"
	646	# define NVff "f"
	647	# define NVgf "g"
	648	# endif
	649	#endif
	650
	651	#ifndef UVSIZE
	652	# define UVSIZE IVSIZE
	653	#endif
	654
	655	#ifndef NVTYPE
	656	# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
	657	# define NVTYPE long double
	658	# else
	659	# define NVTYPE double
	660	# endif
	661	typedef NVTYPE NV;
	662	#endif
	663
	664	#ifndef INT2PTR
	665
	666	#if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
	667	# define PTRV UV
	668	# define INT2PTR(any,d) (any)(d)
	669	#else
	670	# if PTRSIZE == LONGSIZE
	671	# define PTRV unsigned long
	672	# else
	673	# define PTRV unsigned
	674	# endif
	675	# define INT2PTR(any,d) (any)(PTRV)(d)
	676	#endif
	677	#define NUM2PTR(any,d) (any)(PTRV)(d)
	678	#define PTR2IV(p) INT2PTR(IV,p)
	679	#define PTR2UV(p) INT2PTR(UV,p)
	680	#define PTR2NV(p) NUM2PTR(NV,p)
	681	#if PTRSIZE == LONGSIZE
	682	# define PTR2ul(p) (unsigned long)(p)
	683	#else
684	# define PTR2ul(p) INT2PTR(unsigned long,p)
685	#endif
686
687	#endif /* !INT2PTR */
688
689	#ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */
690	# define AvFILLp AvFILL
691	#endif
692
0a7c7f4f	693	#endif /* _P_P_PORTABILITY_H_ */
44284200 JH	694
44284200 JH	695	/* End of File ppport.h */