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