6 Perl/Pollution/Portability
10 Devel::PPPort::WriteFile() ; # defaults to ./ppport.h
11 Devel::PPPort::WriteFile('someheader.h') ;
15 This modules contains a single function, called C<WriteFile>. It is
16 used to write a 'C' header file that is used when writing XS modules. The
17 file contains a series of macros that allow XS modules to be built using
18 older versions of Perl.
20 This module is primarily used by h2xs to write the file F<ppport.h>.
24 C<WriteFile> takes a zero or one parameters. When called with one
25 parameter it expects to be passed a filename. When called with no
26 parameters, it defults to the filename C<./pport.h>.
28 The function returns TRUE if the file was written successfully. Otherwise
33 Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
35 Version 2.x was ported to the Perl core by Paul Marquess.
45 use vars qw( $VERSION $data );
53 my $pkg = __PACKAGE__;
54 $data =~ s/__VERSION__/$VERSION/g;
55 $data =~ s/__DATE__/$now/g;
56 $data =~ s/__PKG__/$pkg/g;
61 my $file = shift || 'ppport.h' ;
63 open F, ">$file" || return undef ;
73 /* Perl/Pollution/Portability Version __VERSION__ */
75 /* Automatically Created by __PKG__ on __DATE__ */
77 /* Do NOT edit this file directly! -- edit PPPort.pm instead. */
80 #ifndef _P_P_PORTABILITY_H_
81 #define _P_P_PORTABILITY_H_
83 /* Copyright (C) 1999, Kenneth Albanowski. This code may be used and
84 distributed under the same license as any version of Perl. */
86 /* For the latest version of this code, please retreive the Devel::PPPort
87 module from CPAN, contact the author at <kjahds@kjahds.com>, or check
88 with the Perl maintainers. */
90 /* If you needed to customize this file for your project, please mention
91 your changes, and visible alter the version number. */
95 In order for a Perl extension module to be as portable as possible
96 across differing versions of Perl itself, certain steps need to be taken.
97 Including this header is the first major one, then using dTHR is all the
98 appropriate places and using a PL_ prefix to refer to global Perl
99 variables is the second.
103 /* If you use one of a few functions that were not present in earlier
104 versions of Perl, please add a define before the inclusion of ppport.h
105 for a static include, or use the GLOBAL request in a single module to
106 produce a global definition that can be referenced from the other
109 Function: Static define: Extern define:
110 newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
115 /* To verify whether ppport.h is needed for your module, and whether any
116 special defines should be used, ppport.h can be run through Perl to check
117 your source code. Simply say:
119 perl -x ppport.h *.c *.h *.xs foo/*.c [etc]
121 The result will be a list of patches suggesting changes that should at
122 least be acceptable, if not necessarily the most efficient solution, or a
123 fix for all possible problems. It won't catch where dTHR is needed, and
124 doesn't attempt to account for global macro or function definitions,
125 nested includes, typemaps, etc.
127 In order to test for the need of dTHR, please try your module under a
128 recent version of Perl that has threading compiled-in.
135 @ARGV = ("*.xs") if !@ARGV;
136 %badmacros = %funcs = %macros = (); $replace = 0;
138 $funcs{$1} = 1 if /Provide:\s+(\S+)/;
139 $macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/;
140 $replace = $1 if /Replace:\s+(\d+)/;
141 $badmacros{$2}=$1 if $replace and /^#\s*define\s+([a-zA-Z0-9_]+).*?\s+([a-zA-Z0-9_]+)/;
142 $badmacros{$1}=$2 if /Replace (\S+) with (\S+)/;
144 foreach $filename (map(glob($_),@ARGV)) {
145 unless (open(IN, "<$filename")) {
146 warn "Unable to read from $file: $!\n";
149 print "Scanning $filename...\n";
150 $c = ""; while (<IN>) { $c .= $_; } close(IN);
151 $need_include = 0; %add_func = (); $changes = 0;
152 $has_include = ($c =~ /#.*include.*ppport/m);
154 foreach $func (keys %funcs) {
155 if ($c =~ /#.*define.*\bNEED_$func(_GLOBAL)?\b/m) {
156 if ($c !~ /\b$func\b/m) {
157 print "If $func isn't needed, you don't need to request it.\n" if
158 $changes += ($c =~ s/^.*#.*define.*\bNEED_$func\b.*\n//m);
160 print "Uses $func\n";
164 if ($c =~ /\b$func\b/m) {
165 $add_func{$func} =1 ;
166 print "Uses $func\n";
172 if (not $need_include) {
173 foreach $macro (keys %macros) {
174 if ($c =~ /\b$macro\b/m) {
175 print "Uses $macro\n";
181 foreach $badmacro (keys %badmacros) {
182 if ($c =~ /\b$badmacro\b/m) {
183 $changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm);
184 print "Uses $badmacros{$badmacro} (instead of $badmacro)\n";
189 if (scalar(keys %add_func) or $need_include != $has_include) {
191 $inc = join('',map("#define NEED_$_\n", sort keys %add_func)).
192 "#include \"ppport.h\"\n";
193 $c = "$inc$c" unless $c =~ s/#.*include.*XSUB.*\n/$&$inc/m;
194 } elsif (keys %add_func) {
195 $inc = join('',map("#define NEED_$_\n", sort keys %add_func));
196 $c = "$inc$c" unless $c =~ s/^.*#.*include.*ppport.*$/$inc$&/m;
198 if (!$need_include) {
199 print "Doesn't seem to need ppport.h.\n";
200 $c =~ s/^.*#.*include.*ppport.*\n//m;
206 open(OUT,">/tmp/ppport.h.$$");
209 open(DIFF, "diff -u $filename /tmp/ppport.h.$$|");
210 while (<DIFF>) { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT; }
212 unlink("/tmp/ppport.h.$$");
220 #ifndef PERL_REVISION
221 # ifndef __PATCHLEVEL_H_INCLUDED__
222 # include "patchlevel.h"
224 # ifndef PERL_REVISION
225 # define PERL_REVISION (5)
227 # define PERL_VERSION PATCHLEVEL
228 # define PERL_SUBVERSION SUBVERSION
229 /* Replace PERL_PATCHLEVEL with PERL_VERSION */
234 #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
237 # define ERRSV perl_get_sv("@",FALSE)
240 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
243 # define PL_compiling compiling
244 # define PL_copline copline
245 # define PL_curcop curcop
246 # define PL_curstash curstash
247 # define PL_defgv defgv
248 # define PL_dirty dirty
249 # define PL_hints hints
251 # define PL_perldb perldb
252 # define PL_rsfp_filters rsfp_filters
253 # define PL_rsfpv rsfp
254 # define PL_stdingv stdingv
255 # define PL_sv_no sv_no
256 # define PL_sv_undef sv_undef
257 # define PL_sv_yes sv_yes
269 # define PTR2IV(d) (IV)(d)
273 # define INT2PTR(any,d) (any)(d)
278 # define dTHR extern int Perl___notused
280 # define dTHR extern int errno
285 # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
289 # define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
293 # define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
298 # define newRV_inc(sv) newRV(sv)
302 /* DEFSV appears first in 5.004_56 */
304 # define DEFSV GvSV(PL_defgv)
308 # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
313 # define newRV_noinc(sv) \
315 SV *nsv = (SV*)newRV(sv); \
320 # if defined(CRIPPLED_CC) || defined(USE_THREADS)
321 static SV * newRV_noinc (SV * sv)
323 SV *nsv = (SV*)newRV(sv);
328 # define newRV_noinc(sv) \
329 (PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
334 /* Provide: newCONSTSUB */
336 /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
337 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
339 #if defined(NEED_newCONSTSUB)
342 extern void newCONSTSUB _((HV * stash, char * name, SV *sv));
345 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
347 newCONSTSUB(stash,name,sv)
352 U32 oldhints = PL_hints;
353 HV *old_cop_stash = PL_curcop->cop_stash;
354 HV *old_curstash = PL_curstash;
355 line_t oldline = PL_curcop->cop_line;
356 PL_curcop->cop_line = PL_copline;
358 PL_hints &= ~HINT_BLOCK_SCOPE;
360 PL_curstash = PL_curcop->cop_stash = stash;
364 #if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
365 /* before 5.003_22 */
368 # if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
372 /* 5.003_23 onwards */
373 start_subparse(FALSE, 0),
377 newSVOP(OP_CONST, 0, newSVpv(name,0)),
378 newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
379 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
383 PL_curcop->cop_stash = old_cop_stash;
384 PL_curstash = old_curstash;
385 PL_curcop->cop_line = oldline;
389 #endif /* newCONSTSUB */
395 * Boilerplate macros for initializing and accessing interpreter-local
396 * data from C. All statics in extensions should be reworked to use
397 * this, if you want to make the extension thread-safe. See ext/re/re.xs
398 * for an example of the use of these macros.
400 * Code that uses these macros is responsible for the following:
401 * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
402 * 2. Declare a typedef named my_cxt_t that is a structure that contains
403 * all the data that needs to be interpreter-local.
404 * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
405 * 4. Use the MY_CXT_INIT macro such that it is called exactly once
406 * (typically put in the BOOT: section).
407 * 5. Use the members of the my_cxt_t structure everywhere as
409 * 6. Use the dMY_CXT macro (a declaration) in all the functions that
413 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
414 defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
416 /* This must appear in all extensions that define a my_cxt_t structure,
417 * right after the definition (i.e. at file scope). The non-threads
418 * case below uses it to declare the data as static. */
421 #if PERL_REVISION == 5 && \
422 (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
423 /* Fetches the SV that keeps the per-interpreter data. */
425 SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
426 #else /* >= perl5.004_68 */
428 SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
429 sizeof(MY_CXT_KEY)-1, TRUE)
430 #endif /* < perl5.004_68 */
432 /* This declaration should be used within all functions that use the
433 * interpreter-local data. */
436 my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
438 /* Creates and zeroes the per-interpreter data.
439 * (We allocate my_cxtp in a Perl SV so that it will be released when
440 * the interpreter goes away.) */
441 #define MY_CXT_INIT \
443 /* newSV() allocates one more than needed */ \
444 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
445 Zero(my_cxtp, 1, my_cxt_t); \
446 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
448 /* This macro must be used to access members of the my_cxt_t structure.
449 * e.g. MYCXT.some_data */
450 #define MY_CXT (*my_cxtp)
452 /* Judicious use of these macros can reduce the number of times dMY_CXT
453 * is used. Use is similar to pTHX, aTHX etc. */
454 #define pMY_CXT my_cxt_t *my_cxtp
455 #define pMY_CXT_ pMY_CXT,
456 #define _pMY_CXT ,pMY_CXT
457 #define aMY_CXT my_cxtp
458 #define aMY_CXT_ aMY_CXT,
459 #define _aMY_CXT ,aMY_CXT
461 #else /* single interpreter */
464 # define NOOP (void)0
468 # define PERL_UNUSED_DECL __attribute__((unused))
470 # define PERL_UNUSED_DECL
474 # define dNOOP extern int Perl___notused PERL_UNUSED_DECL
477 #define START_MY_CXT static my_cxt_t my_cxt;
478 #define dMY_CXT_SV dNOOP
479 #define dMY_CXT dNOOP
480 #define MY_CXT_INIT NOOP
481 #define MY_CXT my_cxt
492 #endif /* START_MY_CXT */
495 #endif /* _P_P_PORTABILITY_H_ */