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