ext/Devel/PPPort/PPPort.pm

   1 package Devel::PPPort;
   2
   3 =head1 NAME
   4
   5 Devel::PPPort - Perl/Pollution/Portability
   6
   7 =head1 SYNOPSIS
   8
   9     Devel::PPPort::WriteFile() ; # defaults to ./ppport.h
  10     Devel::PPPort::WriteFile('someheader.h') ;
  11
  12 =head1 DESCRIPTION
  13
  14 Perl has changed over time, gaining new features, new functions,
  15 increasing its flexibility, and reducing the impact on the C namespace
  16 environment (reduced pollution). The header file, typicaly C<ppport.h>,
  17 written by this module attempts to bring some of the newer Perl
  18 features to older versions of Perl, so that you can worry less about
  19 keeping track of old releases, but users can still reap the benefit.
  20
  21 Why you should use C<ppport.h> in modern code: so that your code will work
  22 with the widest range of Perl interpreters possible, without significant
  23 additional work.
  24
  25 Why you should attempt older code to fully use C<ppport.h>: because
  26 the reduced pollution of newer Perl versions is an important thing, so
  27 important that the old polluting ways of original Perl modules will not be
  28 supported very far into the future, and your module will almost certainly
  29 break! By adapting to it now, you'll gained compatibility and a sense of
  30 having done the electronic ecology some good.
  31
  32 How to use ppport.h: Don't direct the user to download C<Devel::PPPort>,
  33 and don't make C<ppport.h> optional. Rather, just take the most recent
  34 copy of C<ppport.h> that you can find (probably in C<Devel::PPPort>
  35 on CPAN), copy it into your project, adjust your project to use it,
  36 and distribute the header along with your module.
  37
  38 C<Devel::PPPort> contains a single function, called C<WriteFile>. It's
  39 purpose is to write a 'C' header file that is used when writing XS
  40 modules. The file contains a series of macros that allow XS modules to
  41 be built using older versions of Perl.
  42
  43 This module is used by h2xs to write the file F<ppport.h>.
  44
  45 =head2 WriteFile
  46
  47 C<WriteFile> takes a zero or one parameters. When called with one
  48 parameter it expects to be passed a filename. When called with no
  49 parameters, it defults to the filename C<./pport.h>.
  50
  51 The function returns TRUE if the file was written successfully. Otherwise
  52 it returns FALSE.
  53
  54 =head1 ppport.h
  55
  56 The file written by this module, typically C<ppport.h>, provides access
  57 to the following Perl API if not already available (and in some cases [*]
  58 even if available, access to a fixed interface):
  59
  60     aMY_CXT
  61     aMY_CXT_
  62     _aMY_CXT
  63     aTHX
  64     aTHX_
  65     AvFILLp
  66     boolSV(b)
  67     call_argv
  68     call_method
  69     call_pv
  70     call_sv
  71     dAX
  72     DEFSV
  73     dITEMS
  74     dMY_CXT
  75     dMY_CXT_SV
  76     dNOOP
  77     dTHR
  78     dTHX
  79     dTHXa
  80     dTHXoa
  81     ERRSV
  82     get_av
  83     get_cv
  84     get_hv
  85     get_sv
  86     grok_hex
  87     grok_oct
  88     grok_bin
  89     grok_number
  90     grok_numeric_radix
  91     gv_stashpvn(str,len,flags)
  92     INT2PTR(type,int)
  93     IVdf
  94     MY_CXT
  95     MY_CXT_INIT
  96     newCONSTSUB(stash,name,sv)
  97     newRV_inc(sv)
  98     newRV_noinc(sv)
  99     newSVpvn(data,len)
 100     NOOP
 101     NV
 102     NVef
 103     NVff
 104     NVgf
 105     PERL_REVISION
 106     PERL_SUBVERSION
 107     PERL_UNUSED_DECL
 108     PERL_VERSION
 109     PL_compiling
 110     PL_copline
 111     PL_curcop
 112     PL_curstash
 113     PL_defgv
 114     PL_dirty
 115     PL_hints
 116     PL_na
 117     PL_perldb
 118     PL_rsfp_filters
 119     PL_rsfpv
 120     PL_stdingv
 121     PL_Sv
 122     PL_sv_no
 123     PL_sv_undef
 124     PL_sv_yes
 125     pMY_CXT
 126     pMY_CXT_
 127     _pMY_CXT
 128     pTHX
 129     pTHX_
 130     PTR2IV(ptr)
 131     PTR2NV(ptr)
 132     PTR2ul(ptr)
 133     PTR2UV(ptr)
 134     SAVE_DEFSV
 135     START_MY_CXT
 136     SvPVbyte(sv,lp) [*]
 137     UVof
 138     UVSIZE
 139     UVuf
 140     UVxf
 141     UVXf
 142
 143 =head1 AUTHOR
 144
 145 Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
 146
 147 Version 2.x was ported to the Perl core by Paul Marquess.
 148
 149 =head1 SEE ALSO
 150
 151 See L<h2xs>.
 152
 153 =cut
 154
 155
 156 package Devel::PPPort;
 157
 158 require Exporter;
 159 require DynaLoader;
 160 #use warnings;
 161 use strict;
 162 use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK $data );
 163
 164 $VERSION = "2.011_01";
 165
 166 @ISA = qw(Exporter DynaLoader);
 167 @EXPORT =  qw();
 168 # Other items we are prepared to export if requested
 169 @EXPORT_OK = qw( );
 170
 171 bootstrap Devel::PPPort;
 172
 173 package Devel::PPPort;
 174
 175 {
 176     local $/ = undef;
 177     $data = <DATA> ;
 178     my $now = localtime;
 179     my $pkg = __PACKAGE__;
 180     $data =~ s/__VERSION__/$VERSION/g;
 181     $data =~ s/__DATE__/$now/g;
 182     $data =~ s/__PKG__/$pkg/g;
 183 }
 184
 185 sub WriteFile
 186 {
 187     my $file = shift || 'ppport.h' ;
 188
 189     open F, ">$file" || return undef ;
 190     print F $data ;
 191     close F;
 192
 193     return 1 ;
 194 }
 195
 196 1;
 197
 198 __DATA__;
 199
 200 /* ppport.h -- Perl/Pollution/Portability Version __VERSION__
 201  *
 202  * Automatically Created by __PKG__ on __DATE__
 203  *
 204  * Do NOT edit this file directly! -- Edit PPPort.pm instead.
 205  *
 206  * Version 2.x, Copyright (C) 2001, Paul Marquess.
 207  * Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
 208  * This code may be used and distributed under the same license as any
 209  * version of Perl.
 210  *
 211  * This version of ppport.h is designed to support operation with Perl
 212  * installations back to 5.004, and has been tested up to 5.8.1.
 213  *
 214  * If this version of ppport.h is failing during the compilation of this
 215  * module, please check if a newer version of Devel::PPPort is available
 216  * on CPAN before sending a bug report.
 217  *
 218  * If you are using the latest version of Devel::PPPort and it is failing
 219  * during compilation of this module, please send a report to perlbug@perl.com
 220  *
 221  * Include all following information:
 222  *
 223  *  1. The complete output from running "perl -V"
 224  *
 225  *  2. This file.
 226  *
 227  *  3. The name & version of the module you were trying to build.
 228  *
 229  *  4. A full log of the build that failed.
 230  *
 231  *  5. Any other information that you think could be relevant.
 232  *
 233  *
 234  * For the latest version of this code, please retreive the Devel::PPPort
 235  * module from CPAN.
 236  *
 237  */
 238
 239 /*
 240  * In order for a Perl extension module to be as portable as possible
 241  * across differing versions of Perl itself, certain steps need to be taken.
 242  * Including this header is the first major one, then using dTHR is all the
 243  * appropriate places and using a PL_ prefix to refer to global Perl
 244  * variables is the second.
 245  *
 246  */
 247
 248
 249 /* If you use one of a few functions that were not present in earlier
 250  * versions of Perl, please add a define before the inclusion of ppport.h
 251  * for a static include, or use the GLOBAL request in a single module to
 252  * produce a global definition that can be referenced from the other
 253  * modules.
 254  *
 255  * Function:            Static define:           Extern define:
 256  * newCONSTSUB()        NEED_newCONSTSUB         NEED_newCONSTSUB_GLOBAL
 257  *
 258  */
 259
 260
 261 /* To verify whether ppport.h is needed for your module, and whether any
 262  * special defines should be used, ppport.h can be run through Perl to check
 263  * your source code. Simply say:
 264  *
 265  *      perl -x ppport.h *.c *.h *.xs foo/bar*.c [etc]
 266  *
 267  * The result will be a list of patches suggesting changes that should at
 268  * least be acceptable, if not necessarily the most efficient solution, or a
 269  * fix for all possible problems. It won't catch where dTHR is needed, and
 270  * doesn't attempt to account for global macro or function definitions,
 271  * nested includes, typemaps, etc.
 272  *
 273  * In order to test for the need of dTHR, please try your module under a
 274  * recent version of Perl that has threading compiled-in.
 275  *
 276  */
 277
 278
 279 /*
 280 #!/usr/bin/perl
 281 @ARGV = ("*.xs") if !@ARGV;
 282 %badmacros = %funcs = %macros = (); $replace = 0;
 283 foreach (<DATA>) {
 284         $funcs{$1} = 1 if /Provide:\s+(\S+)/;
 285         $macros{$1} = 1 if /^#\s*define\s+([a-zA-Z0-9_]+)/;
 286         $replace = $1 if /Replace:\s+(\d+)/;
 287         $badmacros{$2}=$1 if $replace and /^#\s*define\s+([a-zA-Z0-9_]+).*?\s+([a-zA-Z0-9_]+)/;
 288         $badmacros{$1}=$2 if /Replace (\S+) with (\S+)/;
 289 }
 290 foreach $filename (map(glob($_),@ARGV)) {
 291         unless (open(IN, "<$filename")) {
 292                 warn "Unable to read from $file: $!\n";
 293                 next;
 294         }
 295         print "Scanning $filename...\n";
 296         $c = ""; while (<IN>) { $c .= $_; } close(IN);
 297         $need_include = 0; %add_func = (); $changes = 0;
 298         $has_include = ($c =~ /#.*include.*ppport/m);
 299
 300         foreach $func (keys %funcs) {
 301                 if ($c =~ /#.*define.*\bNEED_$func(_GLOBAL)?\b/m) {
 302                         if ($c !~ /\b$func\b/m) {
 303                                 print "If $func isn't needed, you don't need to request it.\n" if
 304                                 $changes += ($c =~ s/^.*#.*define.*\bNEED_$func\b.*\n//m);
 305                         } else {
 306                                 print "Uses $func\n";
 307                                 $need_include = 1;
 308                         }
 309                 } else {
 310                         if ($c =~ /\b$func\b/m) {
 311                                 $add_func{$func} =1 ;
 312                                 print "Uses $func\n";
 313                                 $need_include = 1;
 314                         }
 315                 }
 316         }
 317
 318         if (not $need_include) {
 319                 foreach $macro (keys %macros) {
 320                         if ($c =~ /\b$macro\b/m) {
 321                                 print "Uses $macro\n";
 322                                 $need_include = 1;
 323                         }
 324                 }
 325         }
 326
 327         foreach $badmacro (keys %badmacros) {
 328                 if ($c =~ /\b$badmacro\b/m) {
 329                         $changes += ($c =~ s/\b$badmacro\b/$badmacros{$badmacro}/gm);
 330                         print "Uses $badmacros{$badmacro} (instead of $badmacro)\n";
 331                         $need_include = 1;
 332                 }
 333         }
 334
 335         if (scalar(keys %add_func) or $need_include != $has_include) {
 336                 if (!$has_include) {
 337                         $inc = join('',map("#define NEED_$_\n", sort keys %add_func)).
 338                                "#include \"ppport.h\"\n";
 339                         $c = "$inc$c" unless $c =~ s/#.*include.*XSUB.*\n/$&$inc/m;
 340                 } elsif (keys %add_func) {
 341                         $inc = join('',map("#define NEED_$_\n", sort keys %add_func));
 342                         $c = "$inc$c" unless $c =~ s/^.*#.*include.*ppport.*$/$inc$&/m;
 343                 }
 344                 if (!$need_include) {
 345                         print "Doesn't seem to need ppport.h.\n";
 346                         $c =~ s/^.*#.*include.*ppport.*\n//m;
 347                 }
 348                 $changes++;
 349         }
 350
 351         if ($changes) {
 352                 open(OUT,"ppport.h.$$");
 353                 print OUT $c;
 354                 close(OUT);
 355                 open(DIFF, "diff -u $filename ppport.h.$$|");
 356                 while (<DIFF>) { s!ppport\.h\.$$!$filename.patched!; print STDOUT; }
 357                 close(DIFF);
 358                 unlink("ppport.h.$$");
 359         } else {
 360                 print "Looks OK\n";
 361         }
 362 }
 363 __DATA__
 364 */
 365
 366 #ifndef _P_P_PORTABILITY_H_
 367 #define _P_P_PORTABILITY_H_
 368
 369 #ifndef PERL_REVISION
 370 #   ifndef __PATCHLEVEL_H_INCLUDED__
 371 #       define PERL_PATCHLEVEL_H_IMPLICIT
 372 #       include <patchlevel.h>
 373 #   endif
 374 #   if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
 375 #       include <could_not_find_Perl_patchlevel.h>
 376 #   endif
 377 #   ifndef PERL_REVISION
 378 #       define PERL_REVISION    (5)
 379         /* Replace: 1 */
 380 #       define PERL_VERSION     PATCHLEVEL
 381 #       define PERL_SUBVERSION  SUBVERSION
 382         /* Replace PERL_PATCHLEVEL with PERL_VERSION */
 383         /* Replace: 0 */
 384 #   endif
 385 #endif
 386
 387 #define PERL_BCDVERSION ((PERL_REVISION * 0x1000000L) + (PERL_VERSION * 0x1000L) + PERL_SUBVERSION)
 388
 389 /* It is very unlikely that anyone will try to use this with Perl 6
 390    (or greater), but who knows.
 391  */
 392 #if PERL_REVISION != 5
 393 #       error ppport.h only works with Perl version 5
 394 #endif /* PERL_REVISION != 5 */
 395
 396 #ifndef ERRSV
 397 #       define ERRSV perl_get_sv("@",FALSE)
 398 #endif
 399
 400 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION <= 5))
 401 /* Replace: 1 */
 402 #       define PL_Sv            Sv
 403 #       define PL_compiling     compiling
 404 #       define PL_copline       copline
 405 #       define PL_curcop        curcop
 406 #       define PL_curstash      curstash
 407 #       define PL_defgv         defgv
 408 #       define PL_dirty         dirty
 409 #       define PL_dowarn        dowarn
 410 #       define PL_hints         hints
 411 #       define PL_na            na
 412 #       define PL_perldb        perldb
 413 #       define PL_rsfp_filters  rsfp_filters
 414 #       define PL_rsfpv         rsfp
 415 #       define PL_stdingv       stdingv
 416 #       define PL_sv_no         sv_no
 417 #       define PL_sv_undef      sv_undef
 418 #       define PL_sv_yes        sv_yes
 419 /* Replace: 0 */
 420 #endif
 421
 422 #ifdef HASATTRIBUTE
 423 #  if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
 424 #    define PERL_UNUSED_DECL
 425 #  else
 426 #    define PERL_UNUSED_DECL __attribute__((unused))
 427 #  endif
 428 #else
 429 #  define PERL_UNUSED_DECL
 430 #endif
 431
 432 #ifndef dNOOP
 433 #  define NOOP (void)0
 434 #  define dNOOP extern int Perl___notused PERL_UNUSED_DECL
 435 #endif
 436
 437 #ifndef dTHR
 438 #  define dTHR          dNOOP
 439 #endif
 440
 441 #ifndef dTHX
 442 #  define dTHX          dNOOP
 443 #  define dTHXa(x)      dNOOP
 444 #  define dTHXoa(x)     dNOOP
 445 #endif
 446
 447 #ifndef pTHX
 448 #    define pTHX        void
 449 #    define pTHX_
 450 #    define aTHX
 451 #    define aTHX_
 452 #endif
 453
 454 #ifndef dAX
 455 #   define dAX I32 ax = MARK - PL_stack_base + 1
 456 #endif
 457 #ifndef dITEMS
 458 #   define dITEMS I32 items = SP - MARK
 459 #endif
 460
 461 /* IV could also be a quad (say, a long long), but Perls
 462  * capable of those should have IVSIZE already. */
 463 #if !defined(IVSIZE) && defined(LONGSIZE)
 464 #   define IVSIZE LONGSIZE
 465 #endif
 466 #ifndef IVSIZE
 467 #   define IVSIZE 4 /* A bold guess, but the best we can make. */
 468 #endif
 469
 470 #ifndef UVSIZE
 471 #   define UVSIZE IVSIZE
 472 #endif
 473
 474 #ifndef NVTYPE
 475 #   if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
 476 #       define NVTYPE long double
 477 #   else
 478 #       define NVTYPE double
 479 #   endif
 480 typedef NVTYPE NV;
 481 #endif
 482
 483 #ifndef INT2PTR
 484
 485 #if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
 486 #  define PTRV                  UV
 487 #  define INT2PTR(any,d)        (any)(d)
 488 #else
 489 #  if PTRSIZE == LONGSIZE
 490 #    define PTRV                unsigned long
 491 #  else
 492 #    define PTRV                unsigned
 493 #  endif
 494 #  define INT2PTR(any,d)        (any)(PTRV)(d)
 495 #endif
 496 #define NUM2PTR(any,d)  (any)(PTRV)(d)
 497 #define PTR2IV(p)       INT2PTR(IV,p)
 498 #define PTR2UV(p)       INT2PTR(UV,p)
 499 #define PTR2NV(p)       NUM2PTR(NV,p)
 500 #if PTRSIZE == LONGSIZE
 501 #  define PTR2ul(p)     (unsigned long)(p)
 502 #else
 503 #  define PTR2ul(p)     INT2PTR(unsigned long,p)
 504 #endif
 505
 506 #endif /* !INT2PTR */
 507
 508 #ifndef boolSV
 509 #       define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
 510 #endif
 511
 512 #ifndef gv_stashpvn
 513 #       define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
 514 #endif
 515
 516 #ifndef newSVpvn
 517 #       define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
 518 #endif
 519
 520 #ifndef newRV_inc
 521 /* Replace: 1 */
 522 #       define newRV_inc(sv) newRV(sv)
 523 /* Replace: 0 */
 524 #endif
 525
 526 /* DEFSV appears first in 5.004_56 */
 527 #ifndef DEFSV
 528 #  define DEFSV GvSV(PL_defgv)
 529 #endif
 530
 531 #ifndef SAVE_DEFSV
 532 #    define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
 533 #endif
 534
 535 #ifndef newRV_noinc
 536 #  ifdef __GNUC__
 537 #    define newRV_noinc(sv)               \
 538       ({                                  \
 539           SV *nsv = (SV*)newRV(sv);       \
 540           SvREFCNT_dec(sv);               \
 541           nsv;                            \
 542       })
 543 #  else
 544 #    if defined(USE_THREADS)
 545 static SV * newRV_noinc (SV * sv)
 546 {
 547           SV *nsv = (SV*)newRV(sv);
 548           SvREFCNT_dec(sv);
 549           return nsv;
 550 }
 551 #    else
 552 #      define newRV_noinc(sv)    \
 553         (PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
 554 #    endif
 555 #  endif
 556 #endif
 557
 558 /* Provide: newCONSTSUB */
 559
 560 /* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
 561 #if (PERL_VERSION < 4) || ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
 562
 563 #if defined(NEED_newCONSTSUB)
 564 static
 565 #else
 566 extern void newCONSTSUB(HV * stash, char * name, SV *sv);
 567 #endif
 568
 569 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
 570 void
 571 newCONSTSUB(stash,name,sv)
 572 HV *stash;
 573 char *name;
 574 SV *sv;
 575 {
 576         U32 oldhints = PL_hints;
 577         HV *old_cop_stash = PL_curcop->cop_stash;
 578         HV *old_curstash = PL_curstash;
 579         line_t oldline = PL_curcop->cop_line;
 580         PL_curcop->cop_line = PL_copline;
 581
 582         PL_hints &= ~HINT_BLOCK_SCOPE;
 583         if (stash)
 584                 PL_curstash = PL_curcop->cop_stash = stash;
 585
 586         newSUB(
 587
 588 #if (PERL_VERSION < 3) || ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
 589      /* before 5.003_22 */
 590                 start_subparse(),
 591 #else
 592 #  if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
 593      /* 5.003_22 */
 594                 start_subparse(0),
 595 #  else
 596      /* 5.003_23  onwards */
 597                 start_subparse(FALSE, 0),
 598 #  endif
 599 #endif
 600
 601                 newSVOP(OP_CONST, 0, newSVpv(name,0)),
 602                 newSVOP(OP_CONST, 0, &PL_sv_no),   /* SvPV(&PL_sv_no) == "" -- GMB */
 603                 newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
 604         );
 605
 606         PL_hints = oldhints;
 607         PL_curcop->cop_stash = old_cop_stash;
 608         PL_curstash = old_curstash;
 609         PL_curcop->cop_line = oldline;
 610 }
 611 #endif
 612
 613 #endif /* newCONSTSUB */
 614
 615 #ifndef START_MY_CXT
 616
 617 /*
 618  * Boilerplate macros for initializing and accessing interpreter-local
 619  * data from C.  All statics in extensions should be reworked to use
 620  * this, if you want to make the extension thread-safe.  See ext/re/re.xs
 621  * for an example of the use of these macros.
 622  *
 623  * Code that uses these macros is responsible for the following:
 624  * 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
 625  * 2. Declare a typedef named my_cxt_t that is a structure that contains
 626  *    all the data that needs to be interpreter-local.
 627  * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
 628  * 4. Use the MY_CXT_INIT macro such that it is called exactly once
 629  *    (typically put in the BOOT: section).
 630  * 5. Use the members of the my_cxt_t structure everywhere as
 631  *    MY_CXT.member.
 632  * 6. Use the dMY_CXT macro (a declaration) in all the functions that
 633  *    access MY_CXT.
 634  */
 635
 636 #if defined(MULTIPLICITY) || defined(PERL_OBJECT) || \
 637     defined(PERL_CAPI)    || defined(PERL_IMPLICIT_CONTEXT)
 638
 639 /* This must appear in all extensions that define a my_cxt_t structure,
 640  * right after the definition (i.e. at file scope).  The non-threads
 641  * case below uses it to declare the data as static. */
 642 #define START_MY_CXT
 643
 644 #if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
 645 /* Fetches the SV that keeps the per-interpreter data. */
 646 #define dMY_CXT_SV \
 647         SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
 648 #else /* >= perl5.004_68 */
 649 #define dMY_CXT_SV \
 650         SV *my_cxt_sv = *hv_fetch(PL_modglobal, MY_CXT_KEY,             \
 651                                   sizeof(MY_CXT_KEY)-1, TRUE)
 652 #endif /* < perl5.004_68 */
 653
 654 /* This declaration should be used within all functions that use the
 655  * interpreter-local data. */
 656 #define dMY_CXT \
 657         dMY_CXT_SV;                                                     \
 658         my_cxt_t *my_cxtp = INT2PTR(my_cxt_t*,SvUV(my_cxt_sv))
 659
 660 /* Creates and zeroes the per-interpreter data.
 661  * (We allocate my_cxtp in a Perl SV so that it will be released when
 662  * the interpreter goes away.) */
 663 #define MY_CXT_INIT \
 664         dMY_CXT_SV;                                                     \
 665         /* newSV() allocates one more than needed */                    \
 666         my_cxt_t *my_cxtp = (my_cxt_t*)SvPVX(newSV(sizeof(my_cxt_t)-1));\
 667         Zero(my_cxtp, 1, my_cxt_t);                                     \
 668         sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
 669
 670 /* This macro must be used to access members of the my_cxt_t structure.
 671  * e.g. MYCXT.some_data */
 672 #define MY_CXT          (*my_cxtp)
 673
 674 /* Judicious use of these macros can reduce the number of times dMY_CXT
 675  * is used.  Use is similar to pTHX, aTHX etc. */
 676 #define pMY_CXT         my_cxt_t *my_cxtp
 677 #define pMY_CXT_        pMY_CXT,
 678 #define _pMY_CXT        ,pMY_CXT
 679 #define aMY_CXT         my_cxtp
 680 #define aMY_CXT_        aMY_CXT,
 681 #define _aMY_CXT        ,aMY_CXT
 682
 683 #else /* single interpreter */
 684
 685 #define START_MY_CXT    static my_cxt_t my_cxt;
 686 #define dMY_CXT_SV      dNOOP
 687 #define dMY_CXT         dNOOP
 688 #define MY_CXT_INIT     NOOP
 689 #define MY_CXT          my_cxt
 690
 691 #define pMY_CXT         void
 692 #define pMY_CXT_
 693 #define _pMY_CXT
 694 #define aMY_CXT
 695 #define aMY_CXT_
 696 #define _aMY_CXT
 697
 698 #endif
 699
 700 #endif /* START_MY_CXT */
 701
 702 #ifndef IVdf
 703 #  if IVSIZE == LONGSIZE
 704 #       define  IVdf            "ld"
 705 #       define  UVuf            "lu"
 706 #       define  UVof            "lo"
 707 #       define  UVxf            "lx"
 708 #       define  UVXf            "lX"
 709 #   else
 710 #       if IVSIZE == INTSIZE
 711 #           define      IVdf    "d"
 712 #           define      UVuf    "u"
 713 #           define      UVof    "o"
 714 #           define      UVxf    "x"
 715 #           define      UVXf    "X"
 716 #       endif
 717 #   endif
 718 #endif
 719
 720 #ifndef NVef
 721 #   if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
 722         defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
 723 #       define NVef             PERL_PRIeldbl
 724 #       define NVff             PERL_PRIfldbl
 725 #       define NVgf             PERL_PRIgldbl
 726 #   else
 727 #       define NVef             "e"
 728 #       define NVff             "f"
 729 #       define NVgf             "g"
 730 #   endif
 731 #endif
 732
 733 #ifndef AvFILLp                 /* Older perls (<=5.003) lack AvFILLp */
 734 #   define AvFILLp AvFILL
 735 #endif
 736
 737 #ifdef SvPVbyte
 738 #   if PERL_REVISION == 5 && PERL_VERSION < 7
 739        /* SvPVbyte does not work in perl-5.6.1, borrowed version for 5.7.3 */
 740 #       undef SvPVbyte
 741 #       define SvPVbyte(sv, lp) \
 742           ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
 743            ? ((lp = SvCUR(sv)), SvPVX(sv)) : my_sv_2pvbyte(aTHX_ sv, &lp))
 744        static char *
 745        my_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
 746        {
 747            sv_utf8_downgrade(sv,0);
 748            return SvPV(sv,*lp);
 749        }
 750 #   endif
 751 #else
 752 #   define SvPVbyte SvPV
 753 #endif
 754
 755 #ifndef SvPV_nolen
 756 #   define SvPV_nolen(sv) \
 757         ((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
 758          ? SvPVX(sv) : sv_2pv_nolen(sv))
 759     static char *
 760     sv_2pv_nolen(pTHX_ register SV *sv)
 761     {
 762         STRLEN n_a;
 763         return sv_2pv(sv, &n_a);
 764     }
 765 #endif
 766
 767 #ifndef get_cv
 768 #   define get_cv(name,create) perl_get_cv(name,create)
 769 #endif
 770
 771 #ifndef get_sv
 772 #   define get_sv(name,create) perl_get_sv(name,create)
 773 #endif
 774
 775 #ifndef get_av
 776 #   define get_av(name,create) perl_get_av(name,create)
 777 #endif
 778
 779 #ifndef get_hv
 780 #   define get_hv(name,create) perl_get_hv(name,create)
 781 #endif
 782
 783 #ifndef call_argv
 784 #   define call_argv perl_call_argv
 785 #endif
 786
 787 #ifndef call_method
 788 #   define call_method perl_call_method
 789 #endif
 790
 791 #ifndef call_pv
 792 #   define call_pv perl_call_pv
 793 #endif
 794
 795 #ifndef call_sv
 796 #   define call_sv perl_call_sv
 797 #endif
 798
 799 #ifndef eval_pv
 800 #   define eval_pv perl_eval_pv
 801 #endif
 802
 803 #ifndef eval_sv
 804 #   define eval_sv perl_eval_sv
 805 #endif
 806
 807 #ifndef PERL_SCAN_GREATER_THAN_UV_MAX
 808 #   define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
 809 #endif
 810
 811 #ifndef PERL_SCAN_SILENT_ILLDIGIT
 812 #   define PERL_SCAN_SILENT_ILLDIGIT 0x04
 813 #endif
 814
 815 #ifndef PERL_SCAN_ALLOW_UNDERSCORES
 816 #   define PERL_SCAN_ALLOW_UNDERSCORES 0x01
 817 #endif
 818
 819 #ifndef PERL_SCAN_DISALLOW_PREFIX
 820 #   define PERL_SCAN_DISALLOW_PREFIX 0x02
 821 #endif
 822
 823 #if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1))
 824 #define I32_CAST
 825 #else
 826 #define I32_CAST (I32*)
 827 #endif
 828
 829 #ifndef grok_hex
 830 static UV _grok_hex (char *string, STRLEN *len, I32 *flags, NV *result) {
 831     NV r = scan_hex(string, *len, I32_CAST len);
 832     if (r > UV_MAX) {
 833         *flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
 834         if (result) *result = r;
 835         return UV_MAX;
 836     }
 837     return (UV)r;
 838 }
 839
 840 #   define grok_hex(string, len, flags, result)     \
 841         _grok_hex((string), (len), (flags), (result))
 842 #endif
 843
 844 #ifndef grok_oct
 845 static UV _grok_oct (char *string, STRLEN *len, I32 *flags, NV *result) {
 846     NV r = scan_oct(string, *len, I32_CAST len);
 847     if (r > UV_MAX) {
 848         *flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
 849         if (result) *result = r;
 850         return UV_MAX;
 851     }
 852     return (UV)r;
 853 }
 854
 855 #   define grok_oct(string, len, flags, result)     \
 856         _grok_oct((string), (len), (flags), (result))
 857 #endif
 858
 859 #if !defined(grok_bin) && defined(scan_bin)
 860 static UV _grok_bin (char *string, STRLEN *len, I32 *flags, NV *result) {
 861     NV r = scan_bin(string, *len, I32_CAST len);
 862     if (r > UV_MAX) {
 863         *flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
 864         if (result) *result = r;
 865         return UV_MAX;
 866     }
 867     return (UV)r;
 868 }
 869
 870 #   define grok_bin(string, len, flags, result)     \
 871         _grok_bin((string), (len), (flags), (result))
 872 #endif
 873
 874 #ifndef IN_LOCALE
 875 #   define IN_LOCALE \
 876         (PL_curcop == &PL_compiling ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
 877 #endif
 878
 879 #ifndef IN_LOCALE_RUNTIME
 880 #   define IN_LOCALE_RUNTIME   (PL_curcop->op_private & HINT_LOCALE)
 881 #endif
 882
 883 #ifndef IN_LOCALE_COMPILETIME
 884 #   define IN_LOCALE_COMPILETIME   (PL_hints & HINT_LOCALE)
 885 #endif
 886
 887
 888 #ifndef IS_NUMBER_IN_UV
 889 #   define IS_NUMBER_IN_UV                          0x01
 890 #   define IS_NUMBER_GREATER_THAN_UV_MAX    0x02
 891 #   define IS_NUMBER_NOT_INT                0x04
 892 #   define IS_NUMBER_NEG                            0x08
 893 #   define IS_NUMBER_INFINITY               0x10
 894 #   define IS_NUMBER_NAN                    0x20
 895 #endif
 896
 897 #ifndef grok_numeric_radix
 898 #   define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(aTHX_ sp, send)
 899
 900 #define grok_numeric_radix Perl_grok_numeric_radix
 901
 902 bool
 903 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
 904 {
 905 #ifdef USE_LOCALE_NUMERIC
 906 #if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1))
 907     if (PL_numeric_radix_sv && IN_LOCALE) {
 908         STRLEN len;
 909         char* radix = SvPV(PL_numeric_radix_sv, len);
 910         if (*sp + len <= send && memEQ(*sp, radix, len)) {
 911             *sp += len;
 912             return TRUE;
 913         }
 914     }
 915 #else
 916     /* pre5.6.0 perls don't have PL_numeric_radix_sv so the radix
 917      * must manually be requested from locale.h */
 918 #include <locale.h>
 919     struct lconv *lc = localeconv();
 920     char *radix = lc->decimal_point;
 921     if (radix && IN_LOCALE) {
 922         STRLEN len = strlen(radix);
 923         if (*sp + len <= send && memEQ(*sp, radix, len)) {
 924             *sp += len;
 925             return TRUE;
 926         }
 927     }
 928 #endif /* PERL_VERSION */
 929 #endif /* USE_LOCALE_NUMERIC */
 930     /* always try "." if numeric radix didn't match because
 931      * we may have data from different locales mixed */
 932     if (*sp < send && **sp == '.') {
 933         ++*sp;
 934         return TRUE;
 935     }
 936     return FALSE;
 937 }
 938 #endif /* grok_numeric_radix */
 939
 940 #ifndef grok_number
 941
 942 #define grok_number Perl_grok_number
 943
 944 int
 945 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
 946 {
 947   const char *s = pv;
 948   const char *send = pv + len;
 949   const UV max_div_10 = UV_MAX / 10;
 950   const char max_mod_10 = UV_MAX % 10;
 951   int numtype = 0;
 952   int sawinf = 0;
 953   int sawnan = 0;
 954
 955   while (s < send && isSPACE(*s))
 956     s++;
 957   if (s == send) {
 958     return 0;
 959   } else if (*s == '-') {
 960     s++;
 961     numtype = IS_NUMBER_NEG;
 962   }
 963   else if (*s == '+')
 964   s++;
 965
 966   if (s == send)
 967     return 0;
 968
 969   /* next must be digit or the radix separator or beginning of infinity */
 970   if (isDIGIT(*s)) {
 971     /* UVs are at least 32 bits, so the first 9 decimal digits cannot
 972        overflow.  */
 973     UV value = *s - '0';
 974     /* This construction seems to be more optimiser friendly.
 975        (without it gcc does the isDIGIT test and the *s - '0' separately)
 976        With it gcc on arm is managing 6 instructions (6 cycles) per digit.
 977        In theory the optimiser could deduce how far to unroll the loop
 978        before checking for overflow.  */
 979     if (++s < send) {
 980       int digit = *s - '0';
 981       if (digit >= 0 && digit <= 9) {
 982         value = value * 10 + digit;
 983         if (++s < send) {
 984           digit = *s - '0';
 985           if (digit >= 0 && digit <= 9) {
 986             value = value * 10 + digit;
 987             if (++s < send) {
 988               digit = *s - '0';
 989               if (digit >= 0 && digit <= 9) {
 990                 value = value * 10 + digit;
 991                         if (++s < send) {
 992                   digit = *s - '0';
 993                   if (digit >= 0 && digit <= 9) {
 994                     value = value * 10 + digit;
 995                     if (++s < send) {
 996                       digit = *s - '0';
 997                       if (digit >= 0 && digit <= 9) {
 998                         value = value * 10 + digit;
 999                         if (++s < send) {
1000                           digit = *s - '0';
1001                           if (digit >= 0 && digit <= 9) {
1002                             value = value * 10 + digit;
1003                             if (++s < send) {
1004                               digit = *s - '0';
1005                               if (digit >= 0 && digit <= 9) {
1006                                 value = value * 10 + digit;
1007                                 if (++s < send) {
1008                                   digit = *s - '0';
1009                                   if (digit >= 0 && digit <= 9) {
1010                                     value = value * 10 + digit;
1011                                     if (++s < send) {
1012                                       /* Now got 9 digits, so need to check
1013                                          each time for overflow.  */
1014                                       digit = *s - '0';
1015                                       while (digit >= 0 && digit <= 9
1016                                              && (value < max_div_10
1017                                                  || (value == max_div_10
1018                                                      && digit <= max_mod_10))) {
1019                                         value = value * 10 + digit;
1020                                         if (++s < send)
1021                                           digit = *s - '0';
1022                                         else
1023                                           break;
1024                                       }
1025                                       if (digit >= 0 && digit <= 9
1026                                           && (s < send)) {
1027                                         /* value overflowed.
1028                                            skip the remaining digits, don't
1029                                            worry about setting *valuep.  */
1030                                         do {
1031                                           s++;
1032                                         } while (s < send && isDIGIT(*s));
1033                                         numtype |=
1034                                           IS_NUMBER_GREATER_THAN_UV_MAX;
1035                                         goto skip_value;
1036                                       }
1037                                     }
1038                                   }
1039                                                 }
1040                               }
1041                             }
1042                           }
1043                         }
1044                       }
1045                     }
1046                   }
1047                 }
1048               }
1049             }
1050           }
1051             }
1052       }
1053     }
1054     numtype |= IS_NUMBER_IN_UV;
1055     if (valuep)
1056       *valuep = value;
1057
1058   skip_value:
1059     if (GROK_NUMERIC_RADIX(&s, send)) {
1060       numtype |= IS_NUMBER_NOT_INT;
1061       while (s < send && isDIGIT(*s))  /* optional digits after the radix */
1062         s++;
1063     }
1064   }
1065   else if (GROK_NUMERIC_RADIX(&s, send)) {
1066     numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
1067     /* no digits before the radix means we need digits after it */
1068     if (s < send && isDIGIT(*s)) {
1069       do {
1070         s++;
1071       } while (s < send && isDIGIT(*s));
1072       if (valuep) {
1073         /* integer approximation is valid - it's 0.  */
1074         *valuep = 0;
1075       }
1076     }
1077     else
1078       return 0;
1079   } else if (*s == 'I' || *s == 'i') {
1080     s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
1081     s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
1082     s++; if (s < send && (*s == 'I' || *s == 'i')) {
1083       s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
1084       s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
1085       s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
1086       s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
1087       s++;
1088     }
1089     sawinf = 1;
1090   } else if (*s == 'N' || *s == 'n') {
1091     /* XXX TODO: There are signaling NaNs and quiet NaNs. */
1092     s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
1093     s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
1094     s++;
1095     sawnan = 1;
1096   } else
1097     return 0;
1098
1099   if (sawinf) {
1100     numtype &= IS_NUMBER_NEG; /* Keep track of sign  */
1101     numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
1102   } else if (sawnan) {
1103     numtype &= IS_NUMBER_NEG; /* Keep track of sign  */
1104     numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
1105   } else if (s < send) {
1106     /* we can have an optional exponent part */
1107     if (*s == 'e' || *s == 'E') {
1108       /* The only flag we keep is sign.  Blow away any "it's UV"  */
1109       numtype &= IS_NUMBER_NEG;
1110       numtype |= IS_NUMBER_NOT_INT;
1111       s++;
1112       if (s < send && (*s == '-' || *s == '+'))
1113         s++;
1114       if (s < send && isDIGIT(*s)) {
1115         do {
1116           s++;
1117         } while (s < send && isDIGIT(*s));
1118       }
1119       else
1120       return 0;
1121     }
1122   }
1123   while (s < send && isSPACE(*s))
1124     s++;
1125   if (s >= send)
1126     return numtype;
1127   if (len == 10 && memEQ(pv, "0 but true", 10)) {
1128     if (valuep)
1129       *valuep = 0;
1130     return IS_NUMBER_IN_UV;
1131   }
1132   return 0;
1133 }
1134 #endif /* grok_number */
1135
1136 #ifndef PERL_MAGIC_sv
1137 #   define PERL_MAGIC_sv             '\0'
1138 #endif
1139
1140 #ifndef PERL_MAGIC_overload
1141 #   define PERL_MAGIC_overload       'A'
1142 #endif
1143
1144 #ifndef PERL_MAGIC_overload_elem
1145 #   define PERL_MAGIC_overload_elem  'a'
1146 #endif
1147
1148 #ifndef PERL_MAGIC_overload_table
1149 #   define PERL_MAGIC_overload_table 'c'
1150 #endif
1151
1152 #ifndef PERL_MAGIC_bm
1153 #   define PERL_MAGIC_bm             'B'
1154 #endif
1155
1156 #ifndef PERL_MAGIC_regdata
1157 #   define PERL_MAGIC_regdata        'D'
1158 #endif
1159
1160 #ifndef PERL_MAGIC_regdatum
1161 #   define PERL_MAGIC_regdatum       'd'
1162 #endif
1163
1164 #ifndef PERL_MAGIC_env
1165 #   define PERL_MAGIC_env            'E'
1166 #endif
1167
1168 #ifndef PERL_MAGIC_envelem
1169 #   define PERL_MAGIC_envelem        'e'
1170 #endif
1171
1172 #ifndef PERL_MAGIC_fm
1173 #   define PERL_MAGIC_fm             'f'
1174 #endif
1175
1176 #ifndef PERL_MAGIC_regex_global
1177 #   define PERL_MAGIC_regex_global   'g'
1178 #endif
1179
1180 #ifndef PERL_MAGIC_isa
1181 #   define PERL_MAGIC_isa            'I'
1182 #endif
1183
1184 #ifndef PERL_MAGIC_isaelem
1185 #   define PERL_MAGIC_isaelem        'i'
1186 #endif
1187
1188 #ifndef PERL_MAGIC_nkeys
1189 #   define PERL_MAGIC_nkeys          'k'
1190 #endif
1191
1192 #ifndef PERL_MAGIC_dbfile
1193 #   define PERL_MAGIC_dbfile         'L'
1194 #endif
1195
1196 #ifndef PERL_MAGIC_dbline
1197 #   define PERL_MAGIC_dbline         'l'
1198 #endif
1199
1200 #ifndef PERL_MAGIC_mutex
1201 #   define PERL_MAGIC_mutex          'm'
1202 #endif
1203
1204 #ifndef PERL_MAGIC_shared
1205 #   define PERL_MAGIC_shared         'N'
1206 #endif
1207
1208 #ifndef PERL_MAGIC_shared_scalar
1209 #   define PERL_MAGIC_shared_scalar  'n'
1210 #endif
1211
1212 #ifndef PERL_MAGIC_collxfrm
1213 #   define PERL_MAGIC_collxfrm       'o'
1214 #endif
1215
1216 #ifndef PERL_MAGIC_tied
1217 #   define PERL_MAGIC_tied           'P'
1218 #endif
1219
1220 #ifndef PERL_MAGIC_tiedelem
1221 #   define PERL_MAGIC_tiedelem       'p'
1222 #endif
1223
1224 #ifndef PERL_MAGIC_tiedscalar
1225 #   define PERL_MAGIC_tiedscalar     'q'
1226 #endif
1227
1228 #ifndef PERL_MAGIC_qr
1229 #   define PERL_MAGIC_qr             'r'
1230 #endif
1231
1232 #ifndef PERL_MAGIC_sig
1233 #   define PERL_MAGIC_sig            'S'
1234 #endif
1235
1236 #ifndef PERL_MAGIC_sigelem
1237 #   define PERL_MAGIC_sigelem        's'
1238 #endif
1239
1240 #ifndef PERL_MAGIC_taint
1241 #   define PERL_MAGIC_taint          't'
1242 #endif
1243
1244 #ifndef PERL_MAGIC_uvar
1245 #   define PERL_MAGIC_uvar           'U'
1246 #endif
1247
1248 #ifndef PERL_MAGIC_uvar_elem
1249 #   define PERL_MAGIC_uvar_elem      'u'
1250 #endif
1251
1252 #ifndef PERL_MAGIC_vstring
1253 #   define PERL_MAGIC_vstring        'V'
1254 #endif
1255
1256 #ifndef PERL_MAGIC_vec
1257 #   define PERL_MAGIC_vec            'v'
1258 #endif
1259
1260 #ifndef PERL_MAGIC_utf8
1261 #   define PERL_MAGIC_utf8           'w'
1262 #endif
1263
1264 #ifndef PERL_MAGIC_substr
1265 #   define PERL_MAGIC_substr         'x'
1266 #endif
1267
1268 #ifndef PERL_MAGIC_defelem
1269 #   define PERL_MAGIC_defelem        'y'
1270 #endif
1271
1272 #ifndef PERL_MAGIC_glob
1273 #   define PERL_MAGIC_glob           '*'
1274 #endif
1275
1276 #ifndef PERL_MAGIC_arylen
1277 #   define PERL_MAGIC_arylen         '#'
1278 #endif
1279
1280 #ifndef PERL_MAGIC_pos
1281 #   define PERL_MAGIC_pos            '.'
1282 #endif
1283
1284 #ifndef PERL_MAGIC_backref
1285 #   define PERL_MAGIC_backref        '<'
1286 #endif
1287
1288 #ifndef PERL_MAGIC_ext
1289 #   define PERL_MAGIC_ext            '~'
1290 #endif
1291
1292 #endif /* _P_P_PORTABILITY_H_ */
1293
1294 /* End of File ppport.h */