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