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