ext/Devel/PPPort/PPPort.pm

   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
  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.
  19
  20 This module is primarily used by h2xs to write the file F<ppport.h>.
  21
  22 =head2 WriteFile
  23
  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>.
  27
  28 The function returns TRUE if the file was written successfully. Otherwise
  29 it returns FALSE.
  30
  31 =head1 AUTHOR
  32
  33 Version 1 of Devel::PPPort was written by Kenneth Albanowski.
  34
  35 Version 2 was ported to the Perl core by Paul Marquess.
  36
  37 =head1 SEE ALSO
  38
  39 See L<h2xs>.
  40
  41 =cut
  42
  43 #use warnings;
  44 use strict;
  45 use 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
  59 sub 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
  70 1;
  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;
 137 foreach (<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 }
 144 foreach $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)
 321 static 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)
 340 static
 341 #else
 342 extern void newCONSTSUB _((HV * stash, char * name, SV *sv));
 343 #endif
 344
 345 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
 346 void
 347 newCONSTSUB(stash,name,sv)
 348 HV *stash;
 349 char *name;
 350 SV *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_ */