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.010";
 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 #       define PERL_PATCHLEVEL_H_IMPLICIT
 370 #       include <patchlevel.h>
 371 #   endif
 372 #   if !(defined(PERL_VERSION) || (defined(SUBVERSION) && 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)) || defined(__INTEL_COMPILER)
 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 eval_pv
 791 #   define eval_pv perl_eval_pv
 792 #endif
 793
 794 #ifndef eval_sv
 795 #   define eval_sv perl_eval_sv
 796 #endif
 797
 798 #ifndef PERL_SCAN_GREATER_THAN_UV_MAX
 799 #   define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
 800 #endif
 801
 802 #ifndef PERL_SCAN_SILENT_ILLDIGIT
 803 #   define PERL_SCAN_SILENT_ILLDIGIT 0x04
 804 #endif
 805
 806 #ifndef PERL_SCAN_ALLOW_UNDERSCORES
 807 #   define PERL_SCAN_ALLOW_UNDERSCORES 0x01
 808 #endif
 809
 810 #ifndef PERL_SCAN_DISALLOW_PREFIX
 811 #   define PERL_SCAN_DISALLOW_PREFIX 0x02
 812 #endif
 813
 814 #if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1))
 815 #define I32_CAST
 816 #else
 817 #define I32_CAST (I32*)
 818 #endif
 819
 820 #ifndef grok_hex
 821 static UV _grok_hex (char *string, STRLEN *len, I32 *flags, NV *result) {
 822     NV r = scan_hex(string, *len, I32_CAST len);
 823     if (r > UV_MAX) {
 824         *flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
 825         if (result) *result = r;
 826         return UV_MAX;
 827     }
 828     return (UV)r;
 829 }
 830
 831 #   define grok_hex(string, len, flags, result)     \
 832         _grok_hex((string), (len), (flags), (result))
 833 #endif
 834
 835 #ifndef grok_oct
 836 static UV _grok_oct (char *string, STRLEN *len, I32 *flags, NV *result) {
 837     NV r = scan_oct(string, *len, I32_CAST len);
 838     if (r > UV_MAX) {
 839         *flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
 840         if (result) *result = r;
 841         return UV_MAX;
 842     }
 843     return (UV)r;
 844 }
 845
 846 #   define grok_oct(string, len, flags, result)     \
 847         _grok_oct((string), (len), (flags), (result))
 848 #endif
 849
 850 #if !defined(grok_bin) && defined(scan_bin)
 851 static UV _grok_bin (char *string, STRLEN *len, I32 *flags, NV *result) {
 852     NV r = scan_bin(string, *len, I32_CAST len);
 853     if (r > UV_MAX) {
 854         *flags |= PERL_SCAN_GREATER_THAN_UV_MAX;
 855         if (result) *result = r;
 856         return UV_MAX;
 857     }
 858     return (UV)r;
 859 }
 860
 861 #   define grok_bin(string, len, flags, result)     \
 862         _grok_bin((string), (len), (flags), (result))
 863 #endif
 864
 865 #ifndef IN_LOCALE
 866 #   define IN_LOCALE \
 867         (PL_curcop == &PL_compiling ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
 868 #endif
 869
 870 #ifndef IN_LOCALE_RUNTIME
 871 #   define IN_LOCALE_RUNTIME   (PL_curcop->op_private & HINT_LOCALE)
 872 #endif
 873
 874 #ifndef IN_LOCALE_COMPILETIME
 875 #   define IN_LOCALE_COMPILETIME   (PL_hints & HINT_LOCALE)
 876 #endif
 877
 878
 879 #ifndef IS_NUMBER_IN_UV
 880 #   define IS_NUMBER_IN_UV                          0x01
 881 #   define IS_NUMBER_GREATER_THAN_UV_MAX    0x02
 882 #   define IS_NUMBER_NOT_INT                0x04
 883 #   define IS_NUMBER_NEG                            0x08
 884 #   define IS_NUMBER_INFINITY               0x10
 885 #   define IS_NUMBER_NAN                    0x20
 886 #endif
 887
 888 #ifndef grok_numeric_radix
 889 #   define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(aTHX_ sp, send)
 890
 891 #define grok_numeric_radix Perl_grok_numeric_radix
 892
 893 bool
 894 Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
 895 {
 896 #ifdef USE_LOCALE_NUMERIC
 897 #if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1))
 898     if (PL_numeric_radix_sv && IN_LOCALE) {
 899         STRLEN len;
 900         char* radix = SvPV(PL_numeric_radix_sv, len);
 901         if (*sp + len <= send && memEQ(*sp, radix, len)) {
 902             *sp += len;
 903             return TRUE;
 904         }
 905     }
 906 #else
 907     /* pre5.6.0 perls don't have PL_numeric_radix_sv so the radix
 908      * must manually be requested from locale.h */
 909 #include <locale.h>
 910     struct lconv *lc = localeconv();
 911     char *radix = lc->decimal_point;
 912     if (radix && IN_LOCALE) {
 913         STRLEN len = strlen(radix);
 914         if (*sp + len <= send && memEQ(*sp, radix, len)) {
 915             *sp += len;
 916             return TRUE;
 917         }
 918     }
 919 #endif /* PERL_VERSION */
 920 #endif /* USE_LOCALE_NUMERIC */
 921     /* always try "." if numeric radix didn't match because
 922      * we may have data from different locales mixed */
 923     if (*sp < send && **sp == '.') {
 924         ++*sp;
 925         return TRUE;
 926     }
 927     return FALSE;
 928 }
 929 #endif /* grok_numeric_radix */
 930
 931 #ifndef grok_number
 932
 933 #define grok_number Perl_grok_number
 934
 935 int
 936 Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
 937 {
 938   const char *s = pv;
 939   const char *send = pv + len;
 940   const UV max_div_10 = UV_MAX / 10;
 941   const char max_mod_10 = UV_MAX % 10;
 942   int numtype = 0;
 943   int sawinf = 0;
 944   int sawnan = 0;
 945
 946   while (s < send && isSPACE(*s))
 947     s++;
 948   if (s == send) {
 949     return 0;
 950   } else if (*s == '-') {
 951     s++;
 952     numtype = IS_NUMBER_NEG;
 953   }
 954   else if (*s == '+')
 955   s++;
 956
 957   if (s == send)
 958     return 0;
 959
 960   /* next must be digit or the radix separator or beginning of infinity */
 961   if (isDIGIT(*s)) {
 962     /* UVs are at least 32 bits, so the first 9 decimal digits cannot
 963        overflow.  */
 964     UV value = *s - '0';
 965     /* This construction seems to be more optimiser friendly.
 966        (without it gcc does the isDIGIT test and the *s - '0' separately)
 967        With it gcc on arm is managing 6 instructions (6 cycles) per digit.
 968        In theory the optimiser could deduce how far to unroll the loop
 969        before checking for overflow.  */
 970     if (++s < send) {
 971       int 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                               digit = *s - '0';
 996                               if (digit >= 0 && digit <= 9) {
 997                                 value = value * 10 + digit;
 998                                 if (++s < send) {
 999                                   digit = *s - '0';
1000                                   if (digit >= 0 && digit <= 9) {
1001                                     value = value * 10 + digit;
1002                                     if (++s < send) {
1003                                       /* Now got 9 digits, so need to check
1004                                          each time for overflow.  */
1005                                       digit = *s - '0';
1006                                       while (digit >= 0 && digit <= 9
1007                                              && (value < max_div_10
1008                                                  || (value == max_div_10
1009                                                      && digit <= max_mod_10))) {
1010                                         value = value * 10 + digit;
1011                                         if (++s < send)
1012                                           digit = *s - '0';
1013                                         else
1014                                           break;
1015                                       }
1016                                       if (digit >= 0 && digit <= 9
1017                                           && (s < send)) {
1018                                         /* value overflowed.
1019                                            skip the remaining digits, don't
1020                                            worry about setting *valuep.  */
1021                                         do {
1022                                           s++;
1023                                         } while (s < send && isDIGIT(*s));
1024                                         numtype |=
1025                                           IS_NUMBER_GREATER_THAN_UV_MAX;
1026                                         goto skip_value;
1027                                       }
1028                                     }
1029                                   }
1030                                                 }
1031                               }
1032                             }
1033                           }
1034                         }
1035                       }
1036                     }
1037                   }
1038                 }
1039               }
1040             }
1041           }
1042             }
1043       }
1044     }
1045     numtype |= IS_NUMBER_IN_UV;
1046     if (valuep)
1047       *valuep = value;
1048
1049   skip_value:
1050     if (GROK_NUMERIC_RADIX(&s, send)) {
1051       numtype |= IS_NUMBER_NOT_INT;
1052       while (s < send && isDIGIT(*s))  /* optional digits after the radix */
1053         s++;
1054     }
1055   }
1056   else if (GROK_NUMERIC_RADIX(&s, send)) {
1057     numtype |= IS_NUMBER_NOT_INT | IS_NUMBER_IN_UV; /* valuep assigned below */
1058     /* no digits before the radix means we need digits after it */
1059     if (s < send && isDIGIT(*s)) {
1060       do {
1061         s++;
1062       } while (s < send && isDIGIT(*s));
1063       if (valuep) {
1064         /* integer approximation is valid - it's 0.  */
1065         *valuep = 0;
1066       }
1067     }
1068     else
1069       return 0;
1070   } else if (*s == 'I' || *s == 'i') {
1071     s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
1072     s++; if (s == send || (*s != 'F' && *s != 'f')) return 0;
1073     s++; if (s < send && (*s == 'I' || *s == 'i')) {
1074       s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
1075       s++; if (s == send || (*s != 'I' && *s != 'i')) return 0;
1076       s++; if (s == send || (*s != 'T' && *s != 't')) return 0;
1077       s++; if (s == send || (*s != 'Y' && *s != 'y')) return 0;
1078       s++;
1079     }
1080     sawinf = 1;
1081   } else if (*s == 'N' || *s == 'n') {
1082     /* XXX TODO: There are signaling NaNs and quiet NaNs. */
1083     s++; if (s == send || (*s != 'A' && *s != 'a')) return 0;
1084     s++; if (s == send || (*s != 'N' && *s != 'n')) return 0;
1085     s++;
1086     sawnan = 1;
1087   } else
1088     return 0;
1089
1090   if (sawinf) {
1091     numtype &= IS_NUMBER_NEG; /* Keep track of sign  */
1092     numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
1093   } else if (sawnan) {
1094     numtype &= IS_NUMBER_NEG; /* Keep track of sign  */
1095     numtype |= IS_NUMBER_NAN | IS_NUMBER_NOT_INT;
1096   } else if (s < send) {
1097     /* we can have an optional exponent part */
1098     if (*s == 'e' || *s == 'E') {
1099       /* The only flag we keep is sign.  Blow away any "it's UV"  */
1100       numtype &= IS_NUMBER_NEG;
1101       numtype |= IS_NUMBER_NOT_INT;
1102       s++;
1103       if (s < send && (*s == '-' || *s == '+'))
1104         s++;
1105       if (s < send && isDIGIT(*s)) {
1106         do {
1107           s++;
1108         } while (s < send && isDIGIT(*s));
1109       }
1110       else
1111       return 0;
1112     }
1113   }
1114   while (s < send && isSPACE(*s))
1115     s++;
1116   if (s >= send)
1117     return numtype;
1118   if (len == 10 && memEQ(pv, "0 but true", 10)) {
1119     if (valuep)
1120       *valuep = 0;
1121     return IS_NUMBER_IN_UV;
1122   }
1123   return 0;
1124 }
1125 #endif /* grok_number */
1126
1127 #ifndef PERL_MAGIC_sv
1128 #   define PERL_MAGIC_sv             '\0'
1129 #endif
1130
1131 #ifndef PERL_MAGIC_overload
1132 #   define PERL_MAGIC_overload       'A'
1133 #endif
1134
1135 #ifndef PERL_MAGIC_overload_elem
1136 #   define PERL_MAGIC_overload_elem  'a'
1137 #endif
1138
1139 #ifndef PERL_MAGIC_overload_table
1140 #   define PERL_MAGIC_overload_table 'c'
1141 #endif
1142
1143 #ifndef PERL_MAGIC_bm
1144 #   define PERL_MAGIC_bm             'B'
1145 #endif
1146
1147 #ifndef PERL_MAGIC_regdata
1148 #   define PERL_MAGIC_regdata        'D'
1149 #endif
1150
1151 #ifndef PERL_MAGIC_regdatum
1152 #   define PERL_MAGIC_regdatum       'd'
1153 #endif
1154
1155 #ifndef PERL_MAGIC_env
1156 #   define PERL_MAGIC_env            'E'
1157 #endif
1158
1159 #ifndef PERL_MAGIC_envelem
1160 #   define PERL_MAGIC_envelem        'e'
1161 #endif
1162
1163 #ifndef PERL_MAGIC_fm
1164 #   define PERL_MAGIC_fm             'f'
1165 #endif
1166
1167 #ifndef PERL_MAGIC_regex_global
1168 #   define PERL_MAGIC_regex_global   'g'
1169 #endif
1170
1171 #ifndef PERL_MAGIC_isa
1172 #   define PERL_MAGIC_isa            'I'
1173 #endif
1174
1175 #ifndef PERL_MAGIC_isaelem
1176 #   define PERL_MAGIC_isaelem        'i'
1177 #endif
1178
1179 #ifndef PERL_MAGIC_nkeys
1180 #   define PERL_MAGIC_nkeys          'k'
1181 #endif
1182
1183 #ifndef PERL_MAGIC_dbfile
1184 #   define PERL_MAGIC_dbfile         'L'
1185 #endif
1186
1187 #ifndef PERL_MAGIC_dbline
1188 #   define PERL_MAGIC_dbline         'l'
1189 #endif
1190
1191 #ifndef PERL_MAGIC_mutex
1192 #   define PERL_MAGIC_mutex          'm'
1193 #endif
1194
1195 #ifndef PERL_MAGIC_shared
1196 #   define PERL_MAGIC_shared         'N'
1197 #endif
1198
1199 #ifndef PERL_MAGIC_shared_scalar
1200 #   define PERL_MAGIC_shared_scalar  'n'
1201 #endif
1202
1203 #ifndef PERL_MAGIC_collxfrm
1204 #   define PERL_MAGIC_collxfrm       'o'
1205 #endif
1206
1207 #ifndef PERL_MAGIC_tied
1208 #   define PERL_MAGIC_tied           'P'
1209 #endif
1210
1211 #ifndef PERL_MAGIC_tiedelem
1212 #   define PERL_MAGIC_tiedelem       'p'
1213 #endif
1214
1215 #ifndef PERL_MAGIC_tiedscalar
1216 #   define PERL_MAGIC_tiedscalar     'q'
1217 #endif
1218
1219 #ifndef PERL_MAGIC_qr
1220 #   define PERL_MAGIC_qr             'r'
1221 #endif
1222
1223 #ifndef PERL_MAGIC_sig
1224 #   define PERL_MAGIC_sig            'S'
1225 #endif
1226
1227 #ifndef PERL_MAGIC_sigelem
1228 #   define PERL_MAGIC_sigelem        's'
1229 #endif
1230
1231 #ifndef PERL_MAGIC_taint
1232 #   define PERL_MAGIC_taint          't'
1233 #endif
1234
1235 #ifndef PERL_MAGIC_uvar
1236 #   define PERL_MAGIC_uvar           'U'
1237 #endif
1238
1239 #ifndef PERL_MAGIC_uvar_elem
1240 #   define PERL_MAGIC_uvar_elem      'u'
1241 #endif
1242
1243 #ifndef PERL_MAGIC_vstring
1244 #   define PERL_MAGIC_vstring        'V'
1245 #endif
1246
1247 #ifndef PERL_MAGIC_vec
1248 #   define PERL_MAGIC_vec            'v'
1249 #endif
1250
1251 #ifndef PERL_MAGIC_utf8
1252 #   define PERL_MAGIC_utf8           'w'
1253 #endif
1254
1255 #ifndef PERL_MAGIC_substr
1256 #   define PERL_MAGIC_substr         'x'
1257 #endif
1258
1259 #ifndef PERL_MAGIC_defelem
1260 #   define PERL_MAGIC_defelem        'y'
1261 #endif
1262
1263 #ifndef PERL_MAGIC_glob
1264 #   define PERL_MAGIC_glob           '*'
1265 #endif
1266
1267 #ifndef PERL_MAGIC_arylen
1268 #   define PERL_MAGIC_arylen         '#'
1269 #endif
1270
1271 #ifndef PERL_MAGIC_pos
1272 #   define PERL_MAGIC_pos            '.'
1273 #endif
1274
1275 #ifndef PERL_MAGIC_backref
1276 #   define PERL_MAGIC_backref        '<'
1277 #endif
1278
1279 #ifndef PERL_MAGIC_ext
1280 #   define PERL_MAGIC_ext            '~'
1281 #endif
1282
1283 #endif /* _P_P_PORTABILITY_H_ */
1284
1285 /* End of File ppport.h */