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;
85 foreach (<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 }
92 foreach $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
284 typedef 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)
newRV_noinc(SV * sv)349 static 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)
368 static
369 #else
370 extern void newCONSTSUB(HV * stash, char * name, SV *sv);
371 #endif
372 
373 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
374 void
newCONSTSUB(stash,name,sv)375 newCONSTSUB(stash,name,sv)
376 HV *stash;
377 char *name;
378 SV *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 *
my_sv_2pvbyte(pTHX_ register SV * sv,STRLEN * lp)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 *
sv_2pv_nolen(pTHX_ register SV * sv)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
_grok_hex(char * string,STRLEN * len,I32 * flags,NV * result)634 static 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
_grok_oct(char * string,STRLEN * len,I32 * flags,NV * result)649 static 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)
_grok_bin(char * string,STRLEN * len,I32 * flags,NV * result)664 static 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 
706 bool
Perl_grok_numeric_radix(pTHX_ const char ** sp,const char * send)707 Perl_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 
748 int
Perl_grok_number(pTHX_ const char * pv,STRLEN len,UV * valuep)749 Perl_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