6 Devel::PPPort - Perl/Pollution/Portability
10 Devel::PPPort::WriteFile() ; # defaults to ./ppport.h
11 Devel::PPPort::WriteFile('someheader.h') ;
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.
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
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.
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.
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.
44 This module is used by h2xs to write the file F<ppport.h>.
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>.
52 The function returns TRUE if the file was written successfully. Otherwise
57 The file written by this module, typically C<ppport.h>, provides access
58 to the following Perl API if not already available (and in some cases [*]
59 even if available, access to a fixed interface):
77 gv_stashpvn(str,len,flags)
82 newCONSTSUB(stash,name,sv)
132 Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
134 Version 2.x was ported to the Perl core by Paul Marquess.
143 package Devel::PPPort;
149 use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK $data );
153 @ISA = qw(Exporter DynaLoader);
155 # Other items we are prepared to export if requested
158 bootstrap Devel::PPPort;
160 package Devel::PPPort;
166 my $pkg = __PACKAGE__;
167 $data =~ s/__VERSION__/$VERSION/g;
168 $data =~ s/__DATE__/$now/g;
169 $data =~ s/__PKG__/$pkg/g;
174 my $file = shift || 'ppport.h' ;
176 open F, ">$file" || return undef ;
187 /* ppport.h -- Perl/Pollution/Portability Version __VERSION__
189 * Automatically Created by __PKG__ on __DATE__
191 * Do NOT edit this file directly! -- Edit PPPort.pm instead.
193 * Version 2.x, Copyright (C) 2001, Paul Marquess.
194 * Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
195 * This code may be used and distributed under the same license as any
198 * This version of ppport.h is designed to support operation with Perl
199 * installations back to 5.004, and has been tested up to 5.8.0.
201 * If this version of ppport.h is failing during the compilation of this
202 * module, please check if a newer version of Devel::PPPort is available
203 * on CPAN before sending a bug report.
205 * If you are using the latest version of Devel::PPPort and it is failing
206 * during compilation of this module, please send a report to perlbug@perl.com
208 * Include all following information:
210 * 1. The complete output from running "perl -V"
214 * 3. The name & version of the module you were trying to build.
216 * 4. A full log of the build that failed.
218 * 5. Any other information that you think could be relevant.
221 * For the latest version of this code, please retreive the Devel::PPPort
227 * In order for a Perl extension module to be as portable as possible
228 * across differing versions of Perl itself, certain steps need to be taken.
229 * Including this header is the first major one, then using dTHR is all the
230 * appropriate places and using a PL_ prefix to refer to global Perl
231 * variables is the second.
236 /* If you use one of a few functions that were not present in earlier
237 * versions of Perl, please add a define before the inclusion of ppport.h
238 * for a static include, or use the GLOBAL request in a single module to
239 * produce a global definition that can be referenced from the other
242 * Function: Static define: Extern define:
243 * newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
248 /* To verify whether ppport.h is needed for your module, and whether any
249 * special defines should be used, ppport.h can be run through Perl to check
250 * your source code. Simply say:
252 * perl -x ppport.h *.c *.h *.xs foo/bar*.c [etc]
254 * The result will be a list of patches suggesting changes that should at
255 * least be acceptable, if not necessarily the most efficient solution, or a
256 * fix for all possible problems. It won't catch where dTHR is needed, and
257 * doesn't attempt to account for global macro or function definitions,
258 * nested includes, typemaps, etc.
260 * In order to test for the need of dTHR, please try your module under a
261 * recent version of Perl that has threading compiled-in.
268 @ARGV = ("*.xs") if !@ARGV;
269 %badmacros = %funcs = %macros = (); $replace = 0;
271 $funcs{$1} = 1 if /Provide:\s+(\S+)/;
272 $macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/;
273 $replace = $1 if /Replace:\s+(\d+)/;
274 $badmacros{$2}=$1 if $replace and /^#\s*define\s+([a-zA-Z0-9_]+).*?\s+([a-zA-Z0-9_]+)/;
275 $badmacros{$1}=$2 if /Replace (\S+) with (\S+)/;
277 foreach $filename (map(glob($_),@ARGV)) {
278 unless (open(IN, "<$filename")) {
279 warn "Unable to read from $file: $!\n";
282 print "Scanning $filename...\n";
283 $c = ""; while (<IN>) { $c .= $_; } close(IN);
284 $need_include = 0; %add_func = (); $changes = 0;
285 $has_include = ($c =~ /#.*include.*ppport/m);
287 foreach $func (keys %funcs) {
288 if ($c =~ /#.*define.*\bNEED_$func(_GLOBAL)?\b/m) {
289 if ($c !~ /\b$func\b/m) {
290 print "If $func isn't needed, you don't need to request it.\n" if
291 $changes += ($c =~ s/^.*#.*define.*\bNEED_$func\b.*\n//m);
293 print "Uses $func\n";
297 if ($c =~ /\b$func\b/m) {
298 $add_func{$func} =1 ;
299 print "Uses $func\n";
305 if (not $need_include) {
306 foreach $macro (keys %macros) {
307 if ($c =~ /\b$macro\b/m) {
308 print "Uses $macro\n";
314 foreach $badmacro (keys %badmacros) {
315 if ($c =~ /\b$badmacro\b/m) {
316 $changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm);
317 print "Uses $badmacros{$badmacro} (instead of $badmacro)\n";
322 if (scalar(keys %add_func) or $need_include != $has_include) {
324 $inc = join('',map("#define NEED_$_\n", sort keys %add_func)).
325 "#include \"ppport.h\"\n";
326 $c = "$inc$c" unless $c =~ s/#.*include.*XSUB.*\n/$&$inc/m;
327 } elsif (keys %add_func) {
328 $inc = join('',map("#define NEED_$_\n", sort keys %add_func));
329 $c = "$inc$c" unless $c =~ s/^.*#.*include.*ppport.*$/$inc$&/m;
331 if (!$need_include) {
332 print "Doesn't seem to need ppport.h.\n";
333 $c =~ s/^.*#.*include.*ppport.*\n//m;
339 open(OUT,">/tmp/ppport.h.$$");
342 open(DIFF, "diff -u $filename /tmp/ppport.h.$$|");
343 while (<DIFF>) { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT; }
345 unlink("/tmp/ppport.h.$$");
353 #ifndef _P_P_PORTABILITY_H_
354 #define _P_P_PORTABILITY_H_
356 #ifndef PERL_REVISION
357 # ifndef __PATCHLEVEL_H_INCLUDED__
358 # include <patchlevel.h>
360 # if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
361 # include <could_not_find_Perl_patchlevel.h>
363 # ifndef PERL_REVISION
364 # define PERL_REVISION (5)
366 # define PERL_VERSION PATCHLEVEL
367 # define PERL_SUBVERSION SUBVERSION
368 /* Replace PERL_PATCHLEVEL with PERL_VERSION */
373 #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
375 /* It is very unlikely that anyone will try to use this with Perl 6
376 (or greater), but who knows.
378 #if PERL_REVISION != 5
379 # error ppport.h only works with Perl version 5
380 #endif /* PERL_REVISION != 5 */
383 # define ERRSV perl_get_sv("@",FALSE)
386 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
389 # define PL_compiling compiling
390 # define PL_copline copline
391 # define PL_curcop curcop
392 # define PL_curstash curstash
393 # define PL_defgv defgv
394 # define PL_dirty dirty
395 # define PL_dowarn dowarn
396 # define PL_hints hints
398 # define PL_perldb perldb
399 # define PL_rsfp_filters rsfp_filters
400 # define PL_rsfpv rsfp
401 # define PL_stdingv stdingv
402 # define PL_sv_no sv_no
403 # define PL_sv_undef sv_undef
404 # define PL_sv_yes sv_yes
409 # if defined(__GNUC__) && defined(__cplusplus)
410 # define PERL_UNUSED_DECL
412 # define PERL_UNUSED_DECL __attribute__((unused))
415 # define PERL_UNUSED_DECL
419 # define NOOP (void)0
420 # define dNOOP extern int Perl___notused PERL_UNUSED_DECL
429 # define dTHXa(x) dNOOP
430 # define dTHXoa(x) dNOOP
440 /* IV could also be a quad (say, a long long), but Perls
441 * capable of those should have IVSIZE already. */
442 #if !defined(IVSIZE) && defined(LONGSIZE)
443 # define IVSIZE LONGSIZE
446 # define IVSIZE 4 /* A bold guess, but the best we can make. */
450 # define UVSIZE IVSIZE
454 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
455 # define NVTYPE long double
457 # define NVTYPE double
464 #if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
466 # define INT2PTR(any,d) (any)(d)
468 # if PTRSIZE == LONGSIZE
469 # define PTRV unsigned long
471 # define PTRV unsigned
473 # define INT2PTR(any,d) (any)(PTRV)(d)
475 #define NUM2PTR(any,d) (any)(PTRV)(d)
476 #define PTR2IV(p) INT2PTR(IV,p)
477 #define PTR2UV(p) INT2PTR(UV,p)
478 #define PTR2NV(p) NUM2PTR(NV,p)
479 #if PTRSIZE == LONGSIZE
480 # define PTR2ul(p) (unsigned long)(p)
482 # define PTR2ul(p) INT2PTR(unsigned long,p)
485 #endif /* !INT2PTR */
488 # define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
492 # define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
496 # define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
501 # define newRV_inc(sv) newRV(sv)
505 /* DEFSV appears first in 5.004_56 */
507 # define DEFSV GvSV(PL_defgv)
511 # define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
516 # define newRV_noinc(sv) \
518 SV *nsv = (SV*)newRV(sv); \
523 # if defined(USE_THREADS)
524 static SV * newRV_noinc (SV * sv)
526 SV *nsv = (SV*)newRV(sv);
531 # define newRV_noinc(sv) \
532 (PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
537 /* Provide: newCONSTSUB */
539 /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
540 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
542 #if defined(NEED_newCONSTSUB)
545 extern void newCONSTSUB(HV * stash, char * name, SV *sv);
548 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
550 newCONSTSUB(stash,name,sv)
555 U32 oldhints = PL_hints;
556 HV *old_cop_stash = PL_curcop->cop_stash;
557 HV *old_curstash = PL_curstash;
558 line_t oldline = PL_curcop->cop_line;
559 PL_curcop->cop_line = PL_copline;
561 PL_hints &= ~HINT_BLOCK_SCOPE;
563 PL_curstash = PL_curcop->cop_stash = stash;
567 #if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
568 /* before 5.003_22 */
571 # if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
575 /* 5.003_23 onwards */
576 start_subparse(FALSE, 0),
580 newSVOP(OP_CONST, 0, newSVpv(name,0)),
581 newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
582 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
586 PL_curcop->cop_stash = old_cop_stash;
587 PL_curstash = old_curstash;
588 PL_curcop->cop_line = oldline;
592 #endif /* newCONSTSUB */
597 * Boilerplate macros for initializing and accessing interpreter-local
598 * data from C. All statics in extensions should be reworked to use
599 * this, if you want to make the extension thread-safe. See ext/re/re.xs
600 * for an example of the use of these macros.
602 * Code that uses these macros is responsible for the following:
603 * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
604 * 2. Declare a typedef named my_cxt_t that is a structure that contains
605 * all the data that needs to be interpreter-local.
606 * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
607 * 4. Use the MY_CXT_INIT macro such that it is called exactly once
608 * (typically put in the BOOT: section).
609 * 5. Use the members of the my_cxt_t structure everywhere as
611 * 6. Use the dMY_CXT macro (a declaration) in all the functions that
615 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
616 defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
618 /* This must appear in all extensions that define a my_cxt_t structure,
619 * right after the definition (i.e. at file scope). The non-threads
620 * case below uses it to declare the data as static. */
623 #if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
624 /* Fetches the SV that keeps the per-interpreter data. */
626 SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
627 #else /* >= perl5.004_68 */
629 SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
630 sizeof(MY_CXT_KEY)-1, TRUE)
631 #endif /* < perl5.004_68 */
633 /* This declaration should be used within all functions that use the
634 * interpreter-local data. */
637 my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
639 /* Creates and zeroes the per-interpreter data.
640 * (We allocate my_cxtp in a Perl SV so that it will be released when
641 * the interpreter goes away.) */
642 #define MY_CXT_INIT \
644 /* newSV() allocates one more than needed */ \
645 my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
646 Zero(my_cxtp, 1, my_cxt_t); \
647 sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
649 /* This macro must be used to access members of the my_cxt_t structure.
650 * e.g. MYCXT.some_data */
651 #define MY_CXT (*my_cxtp)
653 /* Judicious use of these macros can reduce the number of times dMY_CXT
654 * is used. Use is similar to pTHX, aTHX etc. */
655 #define pMY_CXT my_cxt_t *my_cxtp
656 #define pMY_CXT_ pMY_CXT,
657 #define _pMY_CXT ,pMY_CXT
658 #define aMY_CXT my_cxtp
659 #define aMY_CXT_ aMY_CXT,
660 #define _aMY_CXT ,aMY_CXT
662 #else /* single interpreter */
664 #define START_MY_CXT static my_cxt_t my_cxt;
665 #define dMY_CXT_SV dNOOP
666 #define dMY_CXT dNOOP
667 #define MY_CXT_INIT NOOP
668 #define MY_CXT my_cxt
679 #endif /* START_MY_CXT */
682 # if IVSIZE == LONGSIZE
689 # if IVSIZE == INTSIZE
700 # if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
701 defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
702 # define NVef PERL_PRIeldbl
703 # define NVff PERL_PRIfldbl
704 # define NVgf PERL_PRIgldbl
712 #ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */
713 # define AvFILLp AvFILL
717 # if PERL_REVISION == 5 && PERL_VERSION < 7
718 /* SvPVbyte does not work in perl-5.6.1, borrowed version for 5.7.3 */
720 # define SvPVbyte(sv, lp) \
721 ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
722 ? ((lp = SvCUR(sv)), SvPVX(sv)) : my_sv_2pvbyte(aTHX_ sv, &lp))
724 my_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
726 sv_utf8_downgrade(sv,0);
731 # define SvPVbyte SvPV
735 # define SvPV_nolen(sv) \
736 ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
737 ? SvPVX(sv) : sv_2pv_nolen(sv))
739 sv_2pv_nolen(pTHX_ register SV *sv)
742 return sv_2pv(sv, &n_a);
746 #endif /* _P_P_PORTABILITY_H_ */
748 /* End of File ppport.h */