This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add Devel::PPPort originally from Kenneth Albanowski,
[perl5.git] / ext / Devel / PPPort / PPPort.pm
CommitLineData
0a7c7f4f
JH
1
2package Devel::PPPort;
3
4=head1 NAME
5
6Perl/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
15This modules contains a single function, called C<WriteFile>. It is
16used to write a 'C' header file that is used when writing XS modules. The
17file contains a series of macros that allow XS modules to be built using
18older versions of Perl.
19
20This module is primarily used by h2xs to write the file F<ppport.h>.
21
22=head2 WriteFile
23
24C<WriteFile> takes a zero or one parameters. When called with one
25parameter it expects to be passed a filename. When called with no
26parameters, it defults to the filename C<./pport.h>.
27
28The function returns TRUE if the file was written successfully. Otherwise
29it returns FALSE.
30
31=head1 AUTHOR
32
33Version 1 of Devel::PPPort was written by Kenneth Albanowski.
34
35Version 2 was ported to the Perl core by Paul Marquess.
36
37=head1 SEE ALSO
38
39See L<h2xs>.
40
41=cut
42
43#use warnings;
44use strict;
45use vars qw( $VERSION $data );
46
47$VERSION = "2.0000";
48
49{
50 local $/ = undef;
51 $data = <DATA> ;
52 my $now = localtime;
53 my $pkg = __PACKAGE__;
54 $data =~ s/__VERSION__/$VERSION/;
55 $data =~ s/__DATE__/$now/;
56 $data =~ s/__PKG__/$pkg/;
57}
58
59sub WriteFile
60{
61 my $file = shift || 'ppport.h' ;
62
63 open F, ">$file" || return undef ;
64 print F $data ;
65 close F;
66
67 return 1 ;
68}
69
701;
71
72__DATA__;
73/* Perl/Pollution/Portability Version __VERSION__ */
74
75/* Automatically Created by __PKG__ on __DATE__ */
76
77/* Do NOT edit this file directly! -- edit PPPort.pm instead. */
78
79
80#ifndef _P_P_PORTABILITY_H_
81#define _P_P_PORTABILITY_H_
82
83/* Copyright (C) 1999, Kenneth Albanowski. This code may be used and
84 distributed under the same license as any version of Perl. */
85
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. */
89
90/* If you needed to customize this file for your project, please mention
91 your changes, and visible alter the version number. */
92
93
94/*
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.
100*/
101
102
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
107 modules.
108
109 Function: Static define: Extern define:
110 newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL
111
112*/
113
114
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:
118
119 perl -x ppport.h *.c *.h *.xs foo/*.c [etc]
120
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.
126
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.
129
130*/
131
132
133/*
134#!/usr/bin/perl
135@ARGV = ("*.xs") if !@ARGV;
136%badmacros = %funcs = %macros = (); $replace = 0;
137foreach (<DATA>) {
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+)/;
143}
144foreach $filename (map(glob($_),@ARGV)) {
145 unless (open(IN, "<$filename")) {
146 warn "Unable to read from $file: $!\n";
147 next;
148 }
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);
153
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);
159 } else {
160 print "Uses $func\n";
161 $need_include = 1;
162 }
163 } else {
164 if ($c =~ /\b$func\b/m) {
165 $add_func{$func} =1 ;
166 print "Uses $func\n";
167 $need_include = 1;
168 }
169 }
170 }
171
172 if (not $need_include) {
173 foreach $macro (keys %macros) {
174 if ($c =~ /\b$macro\b/m) {
175 print "Uses $macro\n";
176 $need_include = 1;
177 }
178 }
179 }
180
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";
185 $need_include = 1;
186 }
187 }
188
189 if (scalar(keys %add_func) or $need_include != $has_include) {
190 if (!$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;
197 }
198 if (!$need_include) {
199 print "Doesn't seem to need ppport.h.\n";
200 $c =~ s/^.*#.*include.*ppport.*\n//m;
201 }
202 $changes++;
203 }
204
205 if ($changes) {
206 open(OUT,">/tmp/ppport.h.$$");
207 print OUT $c;
208 close(OUT);
209 open(DIFF, "diff -u $filename /tmp/ppport.h.$$|");
210 while (<DIFF>) { s!/tmp/ppport\.h\.$$!$filename.patched!; print STDOUT; }
211 close(DIFF);
212 unlink("/tmp/ppport.h.$$");
213 } else {
214 print "Looks OK\n";
215 }
216}
217__DATA__
218*/
219
220#ifndef PERL_REVISION
221# ifndef __PATCHLEVEL_H_INCLUDED__
222# include "patchlevel.h"
223# endif
224# ifndef PERL_REVISION
225# define PERL_REVISION (5)
226 /* Replace: 1 */
227# define PERL_VERSION PATCHLEVEL
228# define PERL_SUBVERSION SUBVERSION
229 /* Replace PERL_PATCHLEVEL with PERL_VERSION */
230 /* Replace: 0 */
231# endif
232#endif
233
234#define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
235
236#ifndef ERRSV
237# define ERRSV perl_get_sv("@",FALSE)
238#endif
239
240#if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
241/* Replace: 1 */
242# define PL_Sv Sv
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
250# define PL_na na
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
258/* Replace: 0 */
259#endif
260
261#ifndef pTHX
262# define pTHX
263# define pTHX_
264# define aTHX
265# define aTHX_
266#endif
267
268#ifndef PTR2IV
269# define PTR2IV(d) (IV)(d)
270#endif
271
272#ifndef INT2PTR
273# define INT2PTR(any,d) (any)(d)
274#endif
275
276#ifndef dTHR
277# ifdef WIN32
278# define dTHR extern int Perl___notused
279# else
280# define dTHR extern int errno
281# endif
282#endif
283
284#ifndef boolSV
285# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
286#endif
287
288#ifndef gv_stashpvn
289# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
290#endif
291
292#ifndef newSVpvn
293# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
294#endif
295
296#ifndef newRV_inc
297/* Replace: 1 */
298# define newRV_inc(sv) newRV(sv)
299/* Replace: 0 */
300#endif
301
302/* DEFSV appears first in 5.004_56 */
303#ifndef DEFSV
304# define DEFSV GvSV(PL_defgv)
305#endif
306
307#ifndef SAVE_DEFSV
308# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
309#endif
310
311#ifndef newRV_noinc
312# ifdef __GNUC__
313# define newRV_noinc(sv) \
314 ({ \
315 SV *nsv = (SV*)newRV(sv); \
316 SvREFCNT_dec(sv); \
317 nsv; \
318 })
319# else
320# if defined(CRIPPLED_CC) || defined(USE_THREADS)
321static SV * newRV_noinc (SV * sv)
322{
323 SV *nsv = (SV*)newRV(sv);
324 SvREFCNT_dec(sv);
325 return nsv;
326}
327# else
328# define newRV_noinc(sv) \
329 ((PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
330# endif
331# endif
332#endif
333
334/* Provide: newCONSTSUB */
335
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))
338
339#if defined(NEED_newCONSTSUB)
340static
341#else
342extern void newCONSTSUB _((HV * stash, char * name, SV *sv));
343#endif
344
345#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
346void
347newCONSTSUB(stash,name,sv)
348HV *stash;
349char *name;
350SV *sv;
351{
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;
357
358 PL_hints &= ~HINT_BLOCK_SCOPE;
359 if (stash)
360 PL_curstash = PL_curcop->cop_stash = stash;
361
362 newSUB(
363
364#if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
365 /* before 5.003_22 */
366 start_subparse(),
367#else
368# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
369 /* 5.003_22 */
370 start_subparse(0),
371# else
372 /* 5.003_23 onwards */
373 start_subparse(FALSE, 0),
374# endif
375#endif
376
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))
380 );
381
382 PL_hints = oldhints;
383 PL_curcop->cop_stash = old_cop_stash;
384 PL_curstash = old_curstash;
385 PL_curcop->cop_line = oldline;
386}
387#endif
388
389#endif /* newCONSTSUB */
390
391
392#ifndef START_MY_CXT
393
394/*
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.
399 *
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
408 * MY_CXT.member.
409 * 6. Use the dMY_CXT macro (a declaration) in all the functions that
410 * access MY_CXT.
411 */
412
413#if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
414 defined(PERL_CAPI) || defined(PERL_IMPLICIT_CONTEXT)
415
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. */
419#define START_MY_CXT
420
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. */
424#define dMY_CXT_SV \
425 SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
426#else /* >= perl5.004_68 */
427#define dMY_CXT_SV \
428 SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY, \
429 sizeof(MY_CXT_KEY)-1, TRUE)
430#endif /* < perl5.004_68 */
431
432/* This declaration should be used within all functions that use the
433 * interpreter-local data. */
434#define dMY_CXT \
435 dMY_CXT_SV; \
436 my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
437
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 \
442 dMY_CXT_SV; \
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))
447
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)
451
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
460
461#else /* single interpreter */
462
463#ifndef NOOP
464# define NOOP (void)0
465#endif
466
467#ifdef HASATTRIBUTE
468# define PERL_UNUSED_DECL __attribute__((unused))
469#else
470# define PERL_UNUSED_DECL
471#endif
472
473#ifndef dNOOP
474# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
475#endif
476
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
482
483#define pMY_CXT void
484#define pMY_CXT_
485#define _pMY_CXT
486#define aMY_CXT
487#define aMY_CXT_
488#define _aMY_CXT
489
490#endif
491
492#endif /* START_MY_CXT */
493
494
495#endif /* _P_P_PORTABILITY_H_ */