From: Jarkko Hietaniemi Date: Wed, 21 Nov 2001 13:44:41 +0000 (+0000) Subject: Add Devel::PPPort originally from Kenneth Albanowski, X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0a7c7f4fca760548390159c148b40caeb4e5a91d;p=p5sagit%2Fp5-mst-13.2.git Add Devel::PPPort originally from Kenneth Albanowski, revigorated by Paul Marquess: gives h2xs a Perl version portability boost. p4raw-id: //depot/perl@13162 --- diff --git a/MANIFEST b/MANIFEST index f8b08d6..f6f19a9 100644 --- a/MANIFEST +++ b/MANIFEST @@ -139,6 +139,17 @@ ext/Devel/Peek/Makefile.PL Data debugging tool, makefile writer ext/Devel/Peek/Peek.pm Data debugging tool, module and pod ext/Devel/Peek/Peek.t See if Devel::Peek works ext/Devel/Peek/Peek.xs Data debugging tool, externals +ext/Devel/PPPort/Makefile.PL Devel::PPPort makefile writer +ext/Devel/PPPort/PPPort.pm Devel::PPPort +ext/Devel/PPPort/README Devel::PPPort Readme +ext/Devel/PPPort/TODO Devel::PPPort Todo +ext/Devel/PPPort/harness/Harness.pm Devel::PPPort test harness +ext/Devel/PPPort/harness/Harness.xs Devel::PPPort test harness +ext/Devel/PPPort/harness/Makefile.PL Devel::PPPort::harness makefile writer +ext/Devel/PPPort/harness/module2.c Devel::PPPort test file +ext/Devel/PPPort/harness/module3.c Devel::PPPort test file +ext/Devel/PPPort/harness/t/test.t See if Devel::PPPort works +ext/Devel/PPPort/soak Test Harness to run Devel::PPPort other Perls ext/Digest/MD5/Changes Digest::MD5 extension changes ext/Digest/MD5/hints/irix_6.pl Hints for named architecture ext/Digest/MD5/Makefile.PL Digest::MD5 extension makefile writer diff --git a/ext/Devel/PPPort/Makefile.PL b/ext/Devel/PPPort/Makefile.PL new file mode 100644 index 0000000..14ec479 --- /dev/null +++ b/ext/Devel/PPPort/Makefile.PL @@ -0,0 +1,21 @@ + +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => "Devel::PPPort", + DISTNAME => "Devel-PPPort", + VERSION_FROM => 'PPPort.pm', + + #PM => {'PPPort.pm' => '$(INST_LIBDIR)/PPPort.pm'}, + XSPROTOARG => '-noprototypes', + 'dist' => { COMPRESS=>"gzip", SUFFIX=>"gz" } +); + +sub MY::postamble {<<'EOM'}; + +sweep: + cd harness ; $(MAKE) sweep + $(RM_F) pm_to_blib + $(RM_RF) ./blib + +EOM diff --git a/ext/Devel/PPPort/PPPort.pm b/ext/Devel/PPPort/PPPort.pm new file mode 100644 index 0000000..6486225 --- /dev/null +++ b/ext/Devel/PPPort/PPPort.pm @@ -0,0 +1,495 @@ + +package Devel::PPPort; + +=head1 NAME + +Perl/Pollution/Portability + +=head1 SYNOPSIS + + Devel::PPPort::WriteFile() ; # defaults to ./ppport.h + Devel::PPPort::WriteFile('someheader.h') ; + +=head1 DESCRIPTION + +This modules contains a single function, called C. It is +used 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 primarily used by h2xs to write the file F. + +=head2 WriteFile + +C 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 AUTHOR + +Version 1 of Devel::PPPort was written by Kenneth Albanowski. + +Version 2 was ported to the Perl core by Paul Marquess. + +=head1 SEE ALSO + +See L. + +=cut + +#use warnings; +use strict; +use vars qw( $VERSION $data ); + +$VERSION = "2.0000"; + +{ + local $/ = undef; + $data = ; + my $now = localtime; + my $pkg = __PACKAGE__; + $data =~ s/__VERSION__/$VERSION/; + $data =~ s/__DATE__/$now/; + $data =~ s/__PKG__/$pkg/; +} + +sub WriteFile +{ + my $file = shift || 'ppport.h' ; + + open F, ">$file" || return undef ; + print F $data ; + close F; + + return 1 ; +} + +1; + +__DATA__; +/* Perl/Pollution/Portability Version __VERSION__ */ + +/* Automatically Created by __PKG__ on __DATE__ */ + +/* Do NOT edit this file directly! -- edit PPPort.pm instead. */ + + +#ifndef _P_P_PORTABILITY_H_ +#define _P_P_PORTABILITY_H_ + +/* Copyright (C) 1999, Kenneth Albanowski. This code may be used and + distributed under the same license as any version of Perl. */ + +/* For the latest version of this code, please retreive the Devel::PPPort + module from CPAN, contact the author at , or check + with the Perl maintainers. */ + +/* If you needed to customize this file for your project, please mention + your changes, and visible alter the version number. */ + + +/* + 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/*.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 () { + $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 () { $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 () { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT; } + close(DIFF); + unlink("/tmp/ppport.h.$$"); + } else { + print "Looks OK\n"; + } +} +__DATA__ +*/ + +#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) + +#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 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_REVISION == 5 && \ + (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 */ + +#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 + +#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_ */ diff --git a/ext/Devel/PPPort/README b/ext/Devel/PPPort/README new file mode 100644 index 0000000..3828773 --- /dev/null +++ b/ext/Devel/PPPort/README @@ -0,0 +1,44 @@ + + Perl/Pollution/Portability Version 1.0005 + + Copyright (C) 1999, Kenneth Albanowski. This archive may be used and + distributed under the same license as any version of Perl. + + This is not an actual Perl module, but rather a distribution containing a + small header file designed to aid the portability of the XS modules you + write. The Makefile.PL is provided primarily to aid in testing the code. + (Please notify me about any compile warnings or errors, or test failures.) + + Perl has changed over time, gaining new features, new functions, increasing + its flexibility, and reducing the impact on the C namespace environment + (reduced pollution). This header 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 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 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 Devel::PPPort, and + don't make ppport.h optional. Rather, just take the most recent copy of + ppport.h that you can find (probably in Devel::PPPort on CPAN), copy it + into your project, adjust your project to use it, and distribute the header + along with your module. + + The file may be able to help you make use of itself. It's got some internal + documentation, and even an automated script to determine how it could be + used. However, ppport.h is a work in progress, and may not include every + feature or macro definition. Feel free to add missing parts, just make sure + to adjust the version mark so that its clear you've branched from the + original version. + + - Kenneth Albanowski , + February, 1999 diff --git a/ext/Devel/PPPort/TODO b/ext/Devel/PPPort/TODO new file mode 100644 index 0000000..65c574e --- /dev/null +++ b/ext/Devel/PPPort/TODO @@ -0,0 +1,8 @@ + + + * Don't need to install the harness files - fix Makefile.PL + + * more documentation + + * + diff --git a/ext/Devel/PPPort/harness/Harness.pm b/ext/Devel/PPPort/harness/Harness.pm new file mode 100644 index 0000000..992ab5a --- /dev/null +++ b/ext/Devel/PPPort/harness/Harness.pm @@ -0,0 +1,21 @@ + +package Devel::Harness; + +require Exporter; +require DynaLoader; +use Carp; +use strict; +use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK $data ); + +$VERSION = "2.0000"; + +@ISA = qw(Exporter DynaLoader); +@EXPORT = qw(); +# Other items we are prepared to export if requested +@EXPORT_OK = qw( ); + +bootstrap Devel::Harness; + +package Devel::Harness; + +1; diff --git a/ext/Devel/PPPort/harness/Harness.xs b/ext/Devel/PPPort/harness/Harness.xs new file mode 100644 index 0000000..a8dfd8c --- /dev/null +++ b/ext/Devel/PPPort/harness/Harness.xs @@ -0,0 +1,169 @@ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_newCONSTSUB +#include "ppport.h" + +/* Global Data */ + +#define MY_CXT_KEY "${module}::_guts" XS_VERSION + +typedef struct { + /* Put Global Data in here */ + int dummy; +} my_cxt_t; + +START_MY_CXT + +void test1(void) +{ + newCONSTSUB(gv_stashpv("Devel::Harness", FALSE), "test_value_1", newSViv(1)); +} + +extern void test2(void); +extern void test3(void); + +MODULE = Devel::Harness PACKAGE = Devel::Harness + +BOOT: +{ + 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 ; +} + +void +test1() + +void +test2() + +void +test3() + +int +test4() + CODE: + { + SV * sv = newSViv(1); + SV * rv = newRV_inc(sv); + RETVAL = (SvREFCNT(sv) == 2); + } + OUTPUT: + RETVAL + +int +test5() + CODE: + { + SV * sv = newSViv(2); + SV * rv = newRV_noinc(sv); + RETVAL = (SvREFCNT(sv) == 1); + } + OUTPUT: + RETVAL + +SV * +test6() + CODE: + { + RETVAL = (newSVsv(&PL_sv_undef)); + } + OUTPUT: + RETVAL + +SV * +test7() + CODE: + { + RETVAL = (newSVsv(&PL_sv_yes)); + } + OUTPUT: + RETVAL + +SV * +test8() + CODE: + { + RETVAL = (newSVsv(&PL_sv_no)); + } + OUTPUT: + RETVAL + +int +test9(string) + char * string; + CODE: + { + PL_na = strlen(string); + RETVAL = PL_na; + } + OUTPUT: + RETVAL + + +SV* +test10(value) + int value + CODE: + { + RETVAL = (newSVsv(boolSV(value))); + } + OUTPUT: + RETVAL + + +SV* +test11(string, len) + char * string + int len + CODE: + { + RETVAL = newSVpvn(string, len); + } + OUTPUT: + RETVAL + +SV* +test12() + CODE: + { + RETVAL = newSVsv(DEFSV); + } + OUTPUT: + RETVAL + +int +test13() + CODE: + { + RETVAL = SvTRUE(ERRSV); + } + OUTPUT: + RETVAL + +int +test14() + CODE: + { + dMY_CXT; + RETVAL = (MY_CXT.dummy == 42); + ++ MY_CXT.dummy ; + } + OUTPUT: + RETVAL + +int +test15() + CODE: + { + dMY_CXT; + RETVAL = (MY_CXT.dummy == 43); + } + OUTPUT: + RETVAL + diff --git a/ext/Devel/PPPort/harness/Makefile.PL b/ext/Devel/PPPort/harness/Makefile.PL new file mode 100644 index 0000000..552b88b --- /dev/null +++ b/ext/Devel/PPPort/harness/Makefile.PL @@ -0,0 +1,30 @@ + +use ExtUtils::MakeMaker; + +WriteMakefile( + NAME => "Devel::Harness", + VERSION_FROM => '../PPPort.pm', + + + XSPROTOARG => '-noprototypes', + #PM => {'Harness.pm' => '$(INST_LIBDIR)/Harness.pm'}, + #XS => {'Harness.xs' => 'Harness.c'}, + OBJECT => 'Harness$(OBJ_EXT) module2$(OBJ_EXT) module3$(OBJ_EXT)', + 'dist' => { COMPRESS=>"gzip", SUFFIX=>"gz" }, + +); + +sub MY::postamble {<<'EOM'}; + +sweep: + $(RM_F) pm_to_blib Harness.c Harness$(OBJ_EXT) module2$(OBJ_EXT) module3$(OBJ_EXT) ppport.h + $(RM_RF) ./blib + +Harness.c module2.c module3.c : ppport.h + +ppport.h: ../PPPort.pm + $(PERL) -I../../../../lib -e 'require "../PPPort.pm"; Devel::PPPort::WriteFile("ppport.h")' + +EOM + +sub MY::install { "install ::\n" }; diff --git a/ext/Devel/PPPort/harness/module2.c b/ext/Devel/PPPort/harness/module2.c new file mode 100644 index 0000000..0983385 --- /dev/null +++ b/ext/Devel/PPPort/harness/module2.c @@ -0,0 +1,12 @@ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#define NEED_newCONSTSUB_GLOBAL +#include "ppport.h" + +void test2(void) +{ + newCONSTSUB(gv_stashpv("Devel::Harness", FALSE), "test_value_2", newSViv(2)); +} diff --git a/ext/Devel/PPPort/harness/module3.c b/ext/Devel/PPPort/harness/module3.c new file mode 100644 index 0000000..563b3ce --- /dev/null +++ b/ext/Devel/PPPort/harness/module3.c @@ -0,0 +1,11 @@ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include "ppport.h" + +void test3(void) +{ + newCONSTSUB(gv_stashpv("Devel::Harness", FALSE), "test_value_3", newSViv(3)); +} diff --git a/ext/Devel/PPPort/harness/t/test.t b/ext/Devel/PPPort/harness/t/test.t new file mode 100644 index 0000000..ce40035 --- /dev/null +++ b/ext/Devel/PPPort/harness/t/test.t @@ -0,0 +1,99 @@ + +use Devel::Harness; + +use strict; + +print "1..17\n"; + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib' if -d '../lib'; + +} + +my $total = 0; +my $good = 0; + +my $test = 0; +sub ok { + my ($name, $test_sub) = @_; + my $line = (caller)[2]; + my $value; + + eval { $value = &{ $test_sub }() } ; + + ++ $test ; + + if ($@) { + printf "not ok $test # Testing '$name', line $line $@\n"; + } + elsif ($value != 1){ + printf "not ok $test # Testing '$name', line $line, value != 1 ($value)\n"; + } + else { + print "ok $test\n"; + } + +} + +ok "Static newCONSTSUB()", + sub { Devel::Harness::test1(); Devel::Harness::test_value_1() == 1} ; + +ok "Global newCONSTSUB()", + sub { Devel::Harness::test2(); Devel::Harness::test_value_2() == 2} ; + +ok "Extern newCONSTSUB()", + sub { Devel::Harness::test3(); Devel::Harness::test_value_3() == 3} ; + +ok "newRV_inc()", sub { Devel::Harness::test4()} ; + +ok "newRV_noinc()", sub { Devel::Harness::test5()} ; + +ok "PL_sv_undef", sub { not defined Devel::Harness::test6()} ; + +ok "PL_sv_yes", sub { Devel::Harness::test7()} ; + +ok "PL_sv_no", sub { !Devel::Harness::test8()} ; + +ok "PL_na", sub { Devel::Harness::test9("abcd") == 4} ; + +ok "boolSV 1", sub { Devel::Harness::test10(1) } ; + +ok "boolSV 0", sub { ! Devel::Harness::test10(0) } ; + +ok "newSVpvn", sub { Devel::Harness::test11("abcde", 3) eq "abc" } ; + +ok "DEFSV", sub { $_ = "Fred"; Devel::Harness::test12() eq "Fred" } ; + +ok "ERRSV", sub { eval { 1; }; ! Devel::Harness::test13() }; + +ok "ERRSV", sub { eval { fred() }; Devel::Harness::test13() }; + +ok "CXT 1", sub { Devel::Harness::test14()} ; + +ok "CXT 2", sub { Devel::Harness::test15()} ; + +__END__ +# TODO + +PERL_VERSION +PERL_BCDVERSION + +PL_stdingv +PL_hints +PL_curcop +PL_curstash +PL_copline +PL_Sv +PL_compiling +PL_dirty + +PTR2IV +INT2PTR + +dTHR +gv_stashpvn +NOOP +SAVE_DEFSV +PERL_UNUSED_DECL +dNOOP diff --git a/ext/Devel/PPPort/soak b/ext/Devel/PPPort/soak new file mode 100644 index 0000000..893f353 --- /dev/null +++ b/ext/Devel/PPPort/soak @@ -0,0 +1,86 @@ + +use strict ; + +my $verbose = 0 ; + +# find all version of Perl that are available +my @PerlBinaries = qw( + perl5.004 + perl5.00401 + perl5.00402 + perl5.00403 + perl5.00404 + perl5.00405 + perl5.005 + perl5.00501 + perl5.00502 + perl5.00503 + perl5.6.0 + perl5.6.1 + perl5.7.0 + perl5.7.1 + perl5.7.2 + ); + +my $maxlen = 0 ; +foreach (@PerlBinaries) + { $maxlen = length $_ if length $_ > $maxlen } +$maxlen += 3 ; + +# run each through the test harness + +my $bad = 0 ; +my $good = 0 ; +my $total = 0 ; + +foreach my $perl (@PerlBinaries) +{ + print "Testing $perl " . ('.' x ($maxlen - length $perl)) ; + my $ok = runit("$perl Makefile.PL") && + runit("make sweep") && + runit("make test") ; + + ++ $total; + if ($ok) { + ++ $good ; + print "ok\n"; + } + else { + ++ $bad ; + print "not ok\n" ; + } + +} + +print "\n\nPassed with $good of $total versions of Perl.\n"; +exit $bad ; + + +sub runit +{ + my $cmd = shift ; + print "Running [$cmd]\n" if $verbose ; + my $file = "/tmp/abc.$$" ; + unlink $file ; + system "$cmd >$file 2>&1" ; + if ($?) + { + return 0 unless $verbose ; + my $output = docat_del($file) ; + warn "$cmd failed: $?\n$output\n" ; + exit ; + } + unlink $file ; + return 1 ; +} + +sub docat_del +{ + my $file = shift; + local $/ = undef; + open(CAT, "<$file") || die "Cannot open $file: $!"; + my $result = ; + close(CAT); + unlink $file ; + return $result; +} diff --git a/lib/h2xs.t b/lib/h2xs.t index 0c5920e..b049b48 100644 --- a/lib/h2xs.t +++ b/lib/h2xs.t @@ -48,7 +48,7 @@ Defaulting to backwards compatibility with perl $thisversion If you intend this module to be compatible with earlier perl versions, please specify a minimum perl version with the -b option. -Writing $name/compat.h +Writing $name/ppport.h Writing $name/$name.pm Writing $name/$name.xs Writing $name/fallback.c @@ -61,7 +61,7 @@ Writing $name/MANIFEST EOXSFILES "-f -n $name -b $thisversion", $], <<"EOXSFILES", -Writing $name/compat.h +Writing $name/ppport.h Writing $name/$name.pm Writing $name/$name.xs Writing $name/fallback.c @@ -74,7 +74,7 @@ Writing $name/MANIFEST EOXSFILES "-f -n $name -b 5.6.1", "5.006001", <<"EOXSFILES", -Writing $name/compat.h +Writing $name/ppport.h Writing $name/$name.pm Writing $name/$name.xs Writing $name/fallback.c @@ -87,7 +87,7 @@ Writing $name/MANIFEST EOXSFILES "-f -n $name -b 5.5.3", "5.00503", <<"EOXSFILES", -Writing $name/compat.h +Writing $name/ppport.h Writing $name/$name.pm Writing $name/$name.xs Writing $name/fallback.c @@ -109,7 +109,7 @@ Writing $name/MANIFEST EONOXSFILES "-f -n $name $header -b $thisversion", $], <<"EOXSFILES", -Writing $name/compat.h +Writing $name/ppport.h Writing $name/$name.pm Writing $name/$name.xs Writing $name/fallback.c diff --git a/utils/h2xs.PL b/utils/h2xs.PL index b856d89..1c7cf78 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -447,6 +447,7 @@ $Text::Wrap::huge = 'overflow'; $Text::Wrap::columns = 80; use ExtUtils::Constant qw (WriteConstants WriteMakefileSnippet autoload); use File::Compare; +use Devel::PPPort; sub usage { warn "@_\n" if @_; @@ -818,138 +819,9 @@ my %vdecl_hash; my @vdecls; if( ! $opt_X ){ # use XS, unless it was disabled - open(COMPAT, ">compat.h") || die "Can't create $ext$modpname/compat.h: $!\n"; - warn "Writing $ext$modpname/compat.h\n"; - print COMPAT <= 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 = (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, (UV)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 */ - -#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 - -#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 /* perl < 5.7.2 */ - -/* End of file compat.h */ - -EOM - close COMPAT ; + warn "Writing $ext$modpname/ppport.h\n"; + Devel::PPPort::WriteFile('ppport.h') + || die "Can't create $ext$modpname/ppport.h: $!\n"; open(XS, ">$modfname.xs") || die "Can't create $ext$modpname/$modfname.xs: $!\n"; if ($opt_x) { @@ -1330,7 +1202,7 @@ print XS <<"END"; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" -#include "compat.h" +#include "ppport.h" END if( @path_h ){