[p5sagit/p5-mst-13.2.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_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

#ifndef pTHX
#    define pTHX
#    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 dTHR
#  ifdef WIN32
#	define dTHR extern int Perl___notused
#  else
#	define dTHR extern int errno
#  endif
#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(CRIPPLED_CC) || 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 NOOP
#  define NOOP (void)0
#endif

#ifdef HASATTRIBUTE
#  define PERL_UNUSED_DECL __attribute__((unused))
#else
#  define PERL_UNUSED_DECL
#endif    

#ifndef dNOOP
#  define dNOOP extern int Perl___notused PERL_UNUSED_DECL
#endif

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

#endif /* _P_P_PORTABILITY_H_ */

/* End of File ppport.h */
Commit	Line	Data
0a7c7f4f	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	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	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	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	110	=head1 AUTHOR
0a7c7f4f	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	115
	116	=head1 SEE ALSO
	117
	118	See L<h2xs>.
	119
	120	=cut
	121
44284200	122
	123	package Devel::PPPort;
	124
	125	require Exporter;
	126	require DynaLoader;
0a7c7f4f	127	#use warnings;
0a7c7f4f	128	use strict;
44284200	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	138	bootstrap Devel::PPPort;
	139
	140	package Devel::PPPort;
0a7c7f4f	141
	142	{
	143	local $/ = undef;
	144	$data = <DATA> ;
	145	my $now = localtime;
	146	my $pkg = __PACKAGE__;
dbda3434	147	$data =~ s/__VERSION__/$VERSION/g;
	148	$data =~ s/__DATE__/$now/g;
	149	$data =~ s/__PKG__/$pkg/g;
0a7c7f4f	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	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	205
0a7c7f4f	206	/*
44284200	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	214
	215
	216	/* If you use one of a few functions that were not present in earlier
44284200	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	226
	227
	228	/* To verify whether ppport.h is needed for your module, and whether any
44284200	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	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	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	333	#ifndef _P_P_PORTABILITY_H_
	334	#define _P_P_PORTABILITY_H_
	335
0a7c7f4f	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	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	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
	372	# define PL_hints hints
	373	# define PL_na na
	374	# define PL_perldb perldb
	375	# define PL_rsfp_filters rsfp_filters
	376	# define PL_rsfpv rsfp
	377	# define PL_stdingv stdingv
	378	# define PL_sv_no sv_no
	379	# define PL_sv_undef sv_undef
	380	# define PL_sv_yes sv_yes
	381	/* Replace: 0 */
	382	#endif
	383
	384	#ifndef pTHX
	385	# define pTHX
	386	# define pTHX_
	387	# define aTHX
	388	# define aTHX_
	389	#endif
	390
	391	#ifndef PTR2IV
	392	# define PTR2IV(d) (IV)(d)
	393	#endif
	394
	395	#ifndef INT2PTR
	396	# define INT2PTR(any,d) (any)(d)
	397	#endif
	398
	399	#ifndef dTHR
	400	# ifdef WIN32
	401	# define dTHR extern int Perl___notused
	402	# else
	403	# define dTHR extern int errno
	404	# endif
	405	#endif
	406
	407	#ifndef boolSV
	408	# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
	409	#endif
	410
	411	#ifndef gv_stashpvn
	412	# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
	413	#endif
	414
	415	#ifndef newSVpvn
	416	# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
	417	#endif
	418
	419	#ifndef newRV_inc
	420	/* Replace: 1 */
	421	# define newRV_inc(sv) newRV(sv)
	422	/* Replace: 0 */
423	#endif
424
425	/* DEFSV appears first in 5.004_56 */
426	#ifndef DEFSV
427	# define DEFSV GvSV(PL_defgv)
428	#endif
429
430	#ifndef SAVE_DEFSV
431	# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
432	#endif
433
434	#ifndef newRV_noinc
435	# ifdef __GNUC__
436	# define newRV_noinc(sv) \
437	({ \
438	SV nsv = (SV)newRV(sv); \
439	SvREFCNT_dec(sv); \
440	nsv; \
441	})
442	# else
443	# if defined(CRIPPLED_CC) \|\| defined(USE_THREADS)
444	static SV * newRV_noinc (SV * sv)
445	{
446	SV nsv = (SV)newRV(sv);
447	SvREFCNT_dec(sv);
448	return nsv;
449	}
450	# else
451	# define newRV_noinc(sv) \
97dc1cde	452	(PL_Sv=(SV)newRV(sv), SvREFCNT_dec(sv), (SV)PL_Sv)
0a7c7f4f	453	# endif
	454	# endif
	455	#endif
	456
	457	/* Provide: newCONSTSUB */
	458
	459	/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
	460	#if (PERL_VERSION < 4) \|\| ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
	461
	462	#if defined(NEED_newCONSTSUB)
	463	static
	464	#else
eb1102fc	465	extern void newCONSTSUB(HV * stash, char * name, SV *sv);
0a7c7f4f	466	#endif
	467
	468	#if defined(NEED_newCONSTSUB) \|\| defined(NEED_newCONSTSUB_GLOBAL)
	469	void
	470	newCONSTSUB(stash,name,sv)
	471	HV *stash;
	472	char *name;
	473	SV *sv;
	474	{
	475	U32 oldhints = PL_hints;
	476	HV *old_cop_stash = PL_curcop->cop_stash;
	477	HV *old_curstash = PL_curstash;
	478	line_t oldline = PL_curcop->cop_line;
	479	PL_curcop->cop_line = PL_copline;
	480
	481	PL_hints &= ~HINT_BLOCK_SCOPE;
	482	if (stash)
	483	PL_curstash = PL_curcop->cop_stash = stash;
	484
	485	newSUB(
	486
	487	#if (PERL_VERSION < 3) \|\| ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
	488	/* before 5.003_22 */
	489	start_subparse(),
	490	#else
	491	# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
	492	/* 5.003_22 */
	493	start_subparse(0),
	494	# else
	495	/* 5.003_23 onwards */
	496	start_subparse(FALSE, 0),
	497	# endif
	498	#endif
	499
	500	newSVOP(OP_CONST, 0, newSVpv(name,0)),
	501	newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
	502	newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
	503	);
	504
	505	PL_hints = oldhints;
	506	PL_curcop->cop_stash = old_cop_stash;
	507	PL_curstash = old_curstash;
	508	PL_curcop->cop_line = oldline;
	509	}
	510	#endif
	511
	512	#endif /* newCONSTSUB */
	513
44284200	514	#ifndef NOOP
	515	# define NOOP (void)0
	516	#endif
	517
	518	#ifdef HASATTRIBUTE
	519	# define PERL_UNUSED_DECL __attribute__((unused))
	520	#else
	521	# define PERL_UNUSED_DECL
	522	#endif
	523
	524	#ifndef dNOOP
	525	# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
	526	#endif
0a7c7f4f	527
	528	#ifndef START_MY_CXT
	529
	530	/*
	531	* Boilerplate macros for initializing and accessing interpreter-local
	532	* data from C. All statics in extensions should be reworked to use
	533	* this, if you want to make the extension thread-safe. See ext/re/re.xs
	534	* for an example of the use of these macros.
	535	*
	536	* Code that uses these macros is responsible for the following:
	537	* 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
	538	* 2. Declare a typedef named my_cxt_t that is a structure that contains
	539	* all the data that needs to be interpreter-local.
	540	* 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
	541	* 4. Use the MY_CXT_INIT macro such that it is called exactly once
	542	* (typically put in the BOOT: section).
	543	* 5. Use the members of the my_cxt_t structure everywhere as
	544	* MY_CXT.member.
	545	* 6. Use the dMY_CXT macro (a declaration) in all the functions that
	546	* access MY_CXT.
	547	*/
	548
	549	#if defined(MULTIPLICITY) \|\| defined(PERL_OBJECT) \|\| \
	550	defined(PERL_CAPI) \|\| defined(PERL_IMPLICIT_CONTEXT)
	551
	552	/* This must appear in all extensions that define a my_cxt_t structure,
	553	* right after the definition (i.e. at file scope). The non-threads
	554	* case below uses it to declare the data as static. */
	555	#define START_MY_CXT
	556
44284200	557	#if (PERL_VERSION < 4 \|\| (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
0a7c7f4f	558	/* Fetches the SV that keeps the per-interpreter data. */
	559	#define dMY_CXT_SV \
	560	SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
	561	#else /* >= perl5.004_68 */
	562	#define dMY_CXT_SV \
	563	SV my_cxt_sv = hv_fetch(PL_modglobal, MY_CXT_KEY, \
	564	sizeof(MY_CXT_KEY)-1, TRUE)
	565	#endif /* < perl5.004_68 */
	566
	567	/* This declaration should be used within all functions that use the
	568	* interpreter-local data. */
	569	#define dMY_CXT \
	570	dMY_CXT_SV; \
	571	my_cxt_t my_cxtp = INT2PTR(my_cxt_t,SvUV(my_cxt_sv))
	572
	573	/* Creates and zeroes the per-interpreter data.
	574	* (We allocate my_cxtp in a Perl SV so that it will be released when
	575	* the interpreter goes away.) */
	576	#define MY_CXT_INIT \
	577	dMY_CXT_SV; \
	578	/* newSV() allocates one more than needed */ \
	579	my_cxt_t my_cxtp = (my_cxt_t)SvPVX(newSV(sizeof(my_cxt_t)-1));\
	580	Zero(my_cxtp, 1, my_cxt_t); \
	581	sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
	582
	583	/* This macro must be used to access members of the my_cxt_t structure.
	584	* e.g. MYCXT.some_data */
	585	#define MY_CXT (*my_cxtp)
	586
	587	/* Judicious use of these macros can reduce the number of times dMY_CXT
	588	* is used. Use is similar to pTHX, aTHX etc. */
	589	#define pMY_CXT my_cxt_t *my_cxtp
	590	#define pMY_CXT_ pMY_CXT,
	591	#define _pMY_CXT ,pMY_CXT
	592	#define aMY_CXT my_cxtp
	593	#define aMY_CXT_ aMY_CXT,
	594	#define _aMY_CXT ,aMY_CXT
	595
	596	#else /* single interpreter */
	597
0a7c7f4f	598
	599	#define START_MY_CXT static my_cxt_t my_cxt;
	600	#define dMY_CXT_SV dNOOP
	601	#define dMY_CXT dNOOP
	602	#define MY_CXT_INIT NOOP
	603	#define MY_CXT my_cxt
	604
	605	#define pMY_CXT void
	606	#define pMY_CXT_
	607	#define _pMY_CXT
	608	#define aMY_CXT
	609	#define aMY_CXT_
	610	#define _aMY_CXT
	611
	612	#endif
	613
	614	#endif /* START_MY_CXT */
	615
0a7c7f4f	616	#endif /* _P_P_PORTABILITY_H_ */
44284200	617
44284200	618	/* End of File ppport.h */