Context Navigation

ppport.h

Revision 14466, 29.1 kB (checked in by yappo, 7 months ago)
Perlのオペコードの数字が3の倍数の命令を実行する時だけPerl VMがアホになります。これでいいんかなぁ？

Line
1
2	/* ppport.h -- Perl/Pollution/Portability Version 2.011
3	*
4	* Automatically Created by Devel::PPPort on Mon Jun 23 18:02:46 2008
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 /^#\sdefine\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	#ifdef HASATTRIBUTE
225	# if (defined(__GNUC__) && defined(__cplusplus)) \|\| defined(__INTEL_COMPILER)
226	# define PERL_UNUSED_DECL
227	# else
228	# define PERL_UNUSED_DECL __attribute__((unused))
229	# endif
230	#else
231	# define PERL_UNUSED_DECL
232	#endif
233
234	#ifndef dNOOP
235	# define NOOP (void)0
236	# define dNOOP extern int Perl___notused PERL_UNUSED_DECL
237	#endif
238
239	#ifndef dTHR
240	# define dTHR dNOOP
241	#endif
242
243	#ifndef dTHX
244	# define dTHX dNOOP
245	# define dTHXa(x) dNOOP
246	# define dTHXoa(x) dNOOP
247	#endif
248
249	#ifndef pTHX
250	# define pTHX void
251	# define pTHX_
252	# define aTHX
253	# define aTHX_
254	#endif
255
256	#ifndef dAX
257	# define dAX I32 ax = MARK - PL_stack_base + 1
258	#endif
259	#ifndef dITEMS
260	# define dITEMS I32 items = SP - MARK
261	#endif
262
263	/* IV could also be a quad (say, a long long), but Perls
264	* capable of those should have IVSIZE already. */
265	#if !defined(IVSIZE) && defined(LONGSIZE)
266	# define IVSIZE LONGSIZE
267	#endif
268	#ifndef IVSIZE
269	# define IVSIZE 4 /* A bold guess, but the best we can make. */
270	#endif
271
272	#ifndef UVSIZE
273	# define UVSIZE IVSIZE
274	#endif
275
276	#ifndef NVTYPE
277	# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
278	# define NVTYPE long double
279	# else
280	# define NVTYPE double
281	# endif
282	typedef NVTYPE NV;
283	#endif
284
285	#ifndef INT2PTR
286
287	#if (IVSIZE == PTRSIZE) && (UVSIZE == PTRSIZE)
288	# define PTRV UV
289	# define INT2PTR(any,d) (any)(d)
290	#else
291	# if PTRSIZE == LONGSIZE
292	# define PTRV unsigned long
293	# else
294	# define PTRV unsigned
295	# endif
296	# define INT2PTR(any,d) (any)(PTRV)(d)
297	#endif
298	#define NUM2PTR(any,d) (any)(PTRV)(d)
299	#define PTR2IV(p) INT2PTR(IV,p)
300	#define PTR2UV(p) INT2PTR(UV,p)
301	#define PTR2NV(p) NUM2PTR(NV,p)
302	#if PTRSIZE == LONGSIZE
303	# define PTR2ul(p) (unsigned long)(p)
304	#else
305	# define PTR2ul(p) INT2PTR(unsigned long,p)
306	#endif
307
308	#endif /* !INT2PTR */
309
310	#ifndef boolSV
311	# define boolSV(b) ((b) ? &PL_sv_yes : &PL_sv_no)
312	#endif
313
314	#ifndef gv_stashpvn
315	# define gv_stashpvn(str,len,flags) gv_stashpv(str,flags)
316	#endif
317
318	#ifndef newSVpvn
319	# define newSVpvn(data,len) ((len) ? newSVpv ((data), (len)) : newSVpv ("", 0))
320	#endif
321
322	#ifndef newRV_inc
323	/* Replace: 1 */
324	# define newRV_inc(sv) newRV(sv)
325	/* Replace: 0 */
326	#endif
327
328	/* DEFSV appears first in 5.004_56 */
329	#ifndef DEFSV
330	# define DEFSV GvSV(PL_defgv)
331	#endif
332
333	#ifndef SAVE_DEFSV
334	# define SAVE_DEFSV SAVESPTR(GvSV(PL_defgv))
335	#endif
336
337	#ifndef newRV_noinc
338	# ifdef __GNUC__
339	# define newRV_noinc(sv) \
340	({ \
341	SV nsv = (SV)newRV(sv); \
342	SvREFCNT_dec(sv); \
343	nsv; \
344	})
345	# else
346	# if defined(USE_THREADS)
347	static SV * newRV_noinc (SV * sv)
348	{
349	SV nsv = (SV)newRV(sv);
350	SvREFCNT_dec(sv);
351	return nsv;
352	}
353	# else
354	# define newRV_noinc(sv) \
355	(PL_Sv=(SV)newRV(sv), SvREFCNT_dec(sv), (SV)PL_Sv)
356	# endif
357	# endif
358	#endif
359
360	/* Provide: newCONSTSUB */
361
362	/* newCONSTSUB from IO.xs is in the core starting with 5.004_63 */
363	#if (PERL_VERSION < 4) \|\| ((PERL_VERSION == 4) && (PERL_SUBVERSION < 63))
364
365	#if defined(NEED_newCONSTSUB)
366	static
367	#else
368	extern void newCONSTSUB(HV * stash, char * name, SV *sv);
369	#endif
370
371	#if defined(NEED_newCONSTSUB) \|\| defined(NEED_newCONSTSUB_GLOBAL)
372	void
373	newCONSTSUB(stash,name,sv)
374	HV *stash;
375	char *name;
376	SV *sv;
377	{
378	U32 oldhints = PL_hints;
379	HV *old_cop_stash = PL_curcop->cop_stash;
380	HV *old_curstash = PL_curstash;
381	line_t oldline = PL_curcop->cop_line;
382	PL_curcop->cop_line = PL_copline;
383
384	PL_hints &= ~HINT_BLOCK_SCOPE;
385	if (stash)
386	PL_curstash = PL_curcop->cop_stash = stash;
387
388	newSUB(
389
390	#if (PERL_VERSION < 3) \|\| ((PERL_VERSION == 3) && (PERL_SUBVERSION < 22))
391	/* before 5.003_22 */
392	start_subparse(),
393	#else
394	# if (PERL_VERSION == 3) && (PERL_SUBVERSION == 22)
395	/* 5.003_22 */
396	start_subparse(0),
397	# else
398	/* 5.003_23 onwards */
399	start_subparse(FALSE, 0),
400	# endif
401	#endif
402
403	newSVOP(OP_CONST, 0, newSVpv(name,0)),
404	newSVOP(OP_CONST, 0, &PL_sv_no), /* SvPV(&PL_sv_no) == "" -- GMB */
405	newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
406	);
407
408	PL_hints = oldhints;
409	PL_curcop->cop_stash = old_cop_stash;
410	PL_curstash = old_curstash;
411	PL_curcop->cop_line = oldline;
412	}
413	#endif
414
415	#endif /* newCONSTSUB */
416
417	#ifndef START_MY_CXT
418
419	/*
420	* Boilerplate macros for initializing and accessing interpreter-local
421	* data from C. All statics in extensions should be reworked to use
422	* this, if you want to make the extension thread-safe. See ext/re/re.xs
423	* for an example of the use of these macros.
424	*
425	* Code that uses these macros is responsible for the following:
426	* 1. #define MY_CXT_KEY to a unique string, e.g. "DynaLoader_guts"
427	* 2. Declare a typedef named my_cxt_t that is a structure that contains
428	* all the data that needs to be interpreter-local.
429	* 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
430	* 4. Use the MY_CXT_INIT macro such that it is called exactly once
431	* (typically put in the BOOT: section).
432	* 5. Use the members of the my_cxt_t structure everywhere as
433	* MY_CXT.member.
434	* 6. Use the dMY_CXT macro (a declaration) in all the functions that
435	* access MY_CXT.
436	*/
437
438	#if defined(MULTIPLICITY) \|\| defined(PERL_OBJECT) \|\| \
439	defined(PERL_CAPI) \|\| defined(PERL_IMPLICIT_CONTEXT)
440
441	/* This must appear in all extensions that define a my_cxt_t structure,
442	* right after the definition (i.e. at file scope). The non-threads
443	* case below uses it to declare the data as static. */
444	#define START_MY_CXT
445
446	#if (PERL_VERSION < 4 \|\| (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
447	/* Fetches the SV that keeps the per-interpreter data. */
448	#define dMY_CXT_SV \
449	SV *my_cxt_sv = perl_get_sv(MY_CXT_KEY, FALSE)
450	#else /* >= perl5.004_68 */
451	#define dMY_CXT_SV \
452	SV my_cxt_sv = hv_fetch(PL_modglobal, MY_CXT_KEY, \
453	sizeof(MY_CXT_KEY)-1, TRUE)
454	#endif /* < perl5.004_68 */
455
456	/* This declaration should be used within all functions that use the
457	* interpreter-local data. */
458	#define dMY_CXT \
459	dMY_CXT_SV; \
460	my_cxt_t my_cxtp = INT2PTR(my_cxt_t,SvUV(my_cxt_sv))
461
462	/* Creates and zeroes the per-interpreter data.
463	* (We allocate my_cxtp in a Perl SV so that it will be released when
464	* the interpreter goes away.) */
465	#define MY_CXT_INIT \
466	dMY_CXT_SV; \
467	/* newSV() allocates one more than needed */ \
468	my_cxt_t my_cxtp = (my_cxt_t)SvPVX(newSV(sizeof(my_cxt_t)-1));\
469	Zero(my_cxtp, 1, my_cxt_t); \
470	sv_setuv(my_cxt_sv, PTR2UV(my_cxtp))
471
472	/* This macro must be used to access members of the my_cxt_t structure.
473	* e.g. MYCXT.some_data */
474	#define MY_CXT (*my_cxtp)
475
476	/* Judicious use of these macros can reduce the number of times dMY_CXT
477	* is used. Use is similar to pTHX, aTHX etc. */
478	#define pMY_CXT my_cxt_t *my_cxtp
479	#define pMY_CXT_ pMY_CXT,
480	#define _pMY_CXT ,pMY_CXT
481	#define aMY_CXT my_cxtp
482	#define aMY_CXT_ aMY_CXT,
483	#define _aMY_CXT ,aMY_CXT
484
485	#else /* single interpreter */
486
487	#define START_MY_CXT static my_cxt_t my_cxt;
488	#define dMY_CXT_SV dNOOP
489	#define dMY_CXT dNOOP
490	#define MY_CXT_INIT NOOP
491	#define MY_CXT my_cxt
492
493	#define pMY_CXT void
494	#define pMY_CXT_
495	#define _pMY_CXT
496	#define aMY_CXT
497	#define aMY_CXT_
498	#define _aMY_CXT
499
500	#endif
501
502	#endif /* START_MY_CXT */
503
504	#ifndef IVdf
505	# if IVSIZE == LONGSIZE
506	# define IVdf "ld"
507	# define UVuf "lu"
508	# define UVof "lo"
509	# define UVxf "lx"
510	# define UVXf "lX"
511	# else
512	# if IVSIZE == INTSIZE
513	# define IVdf "d"
514	# define UVuf "u"
515	# define UVof "o"
516	# define UVxf "x"
517	# define UVXf "X"
518	# endif
519	# endif
520	#endif
521
522	#ifndef NVef
523	# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
524	defined(PERL_PRIfldbl) /* Not very likely, but let's try anyway. */
525	# define NVef PERL_PRIeldbl
526	# define NVff PERL_PRIfldbl
527	# define NVgf PERL_PRIgldbl
528	# else
529	# define NVef "e"
530	# define NVff "f"
531	# define NVgf "g"
532	# endif
533	#endif
534
535	#ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */
536	# define AvFILLp AvFILL
537	#endif
538
539	#ifdef SvPVbyte
540	# if PERL_REVISION == 5 && PERL_VERSION < 7
541	/* SvPVbyte does not work in perl-5.6.1, borrowed version for 5.7.3 */
542	# undef SvPVbyte
543	# define SvPVbyte(sv, lp) \
544	((SvFLAGS(sv) & (SVf_POK\|SVf_UTF8)) == (SVf_POK) \
545	? ((lp = SvCUR(sv)), SvPVX(sv)) : my_sv_2pvbyte(aTHX_ sv, &lp))
546	static char *
547	my_sv_2pvbyte(pTHX_ register SV sv, STRLEN lp)
548	{
549	sv_utf8_downgrade(sv,0);
550	return SvPV(sv,*lp);
551	}
552	# endif
553	#else
554	# define SvPVbyte SvPV
555	#endif
556
557	#ifndef SvPV_nolen
558	# define SvPV_nolen(sv) \
559	((SvFLAGS(sv) & (SVf_POK)) == SVf_POK \
560	? SvPVX(sv) : sv_2pv_nolen(sv))
561	static char *
562	sv_2pv_nolen(pTHX_ register SV *sv)
563	{
564	STRLEN n_a;
565	return sv_2pv(sv, &n_a);
566	}
567	#endif
568
569	#ifndef get_cv
570	# define get_cv(name,create) perl_get_cv(name,create)
571	#endif
572
573	#ifndef get_sv
574	# define get_sv(name,create) perl_get_sv(name,create)
575	#endif
576
577	#ifndef get_av
578	# define get_av(name,create) perl_get_av(name,create)
579	#endif
580
581	#ifndef get_hv
582	# define get_hv(name,create) perl_get_hv(name,create)
583	#endif
584
585	#ifndef call_argv
586	# define call_argv perl_call_argv
587	#endif
588
589	#ifndef call_method
590	# define call_method perl_call_method
591	#endif
592
593	#ifndef call_pv
594	# define call_pv perl_call_pv
595	#endif
596
597	#ifndef call_sv
598	# define call_sv perl_call_sv
599	#endif
600
601	#ifndef eval_pv
602	# define eval_pv perl_eval_pv
603	#endif
604
605	#ifndef eval_sv
606	# define eval_sv perl_eval_sv
607	#endif
608
609	#ifndef PERL_SCAN_GREATER_THAN_UV_MAX
610	# define PERL_SCAN_GREATER_THAN_UV_MAX 0x02
611	#endif
612
613	#ifndef PERL_SCAN_SILENT_ILLDIGIT
614	# define PERL_SCAN_SILENT_ILLDIGIT 0x04
615	#endif
616
617	#ifndef PERL_SCAN_ALLOW_UNDERSCORES
618	# define PERL_SCAN_ALLOW_UNDERSCORES 0x01
619	#endif
620
621	#ifndef PERL_SCAN_DISALLOW_PREFIX
622	# define PERL_SCAN_DISALLOW_PREFIX 0x02
623	#endif
624
625	#if (PERL_VERSION > 6) \|\| ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1))
626	#define I32_CAST
627	#else
628	#define I32_CAST (I32*)
629	#endif
630
631	#ifndef grok_hex
632	static UV _grok_hex (char string, STRLEN len, I32 flags, NV result) {
633	NV r = scan_hex(string, *len, I32_CAST len);
634	if (r > UV_MAX) {
635	*flags \|= PERL_SCAN_GREATER_THAN_UV_MAX;
636	if (result) *result = r;
637	return UV_MAX;
638	}
639	return (UV)r;
640	}
641
642	# define grok_hex(string, len, flags, result) \
643	_grok_hex((string), (len), (flags), (result))
644	#endif
645
646	#ifndef grok_oct
647	static UV _grok_oct (char string, STRLEN len, I32 flags, NV result) {
648	NV r = scan_oct(string, *len, I32_CAST len);
649	if (r > UV_MAX) {
650	*flags \|= PERL_SCAN_GREATER_THAN_UV_MAX;
651	if (result) *result = r;
652	return UV_MAX;
653	}
654	return (UV)r;
655	}
656
657	# define grok_oct(string, len, flags, result) \
658	_grok_oct((string), (len), (flags), (result))
659	#endif
660
661	#if !defined(grok_bin) && defined(scan_bin)
662	static UV _grok_bin (char string, STRLEN len, I32 flags, NV result) {
663	NV r = scan_bin(string, *len, I32_CAST len);
664	if (r > UV_MAX) {
665	*flags \|= PERL_SCAN_GREATER_THAN_UV_MAX;
666	if (result) *result = r;
667	return UV_MAX;
668	}
669	return (UV)r;
670	}
671
672	# define grok_bin(string, len, flags, result) \
673	_grok_bin((string), (len), (flags), (result))
674	#endif
675
676	#ifndef IN_LOCALE
677	# define IN_LOCALE \
678	(PL_curcop == &PL_compiling ? IN_LOCALE_COMPILETIME : IN_LOCALE_RUNTIME)
679	#endif
680
681	#ifndef IN_LOCALE_RUNTIME
682	# define IN_LOCALE_RUNTIME (PL_curcop->op_private & HINT_LOCALE)
683	#endif
684
685	#ifndef IN_LOCALE_COMPILETIME
686	# define IN_LOCALE_COMPILETIME (PL_hints & HINT_LOCALE)
687	#endif
688
689
690	#ifndef IS_NUMBER_IN_UV
691	# define IS_NUMBER_IN_UV 0x01
692	# define IS_NUMBER_GREATER_THAN_UV_MAX 0x02
693	# define IS_NUMBER_NOT_INT 0x04
694	# define IS_NUMBER_NEG 0x08
695	# define IS_NUMBER_INFINITY 0x10
696	# define IS_NUMBER_NAN 0x20
697	#endif
698
699	#ifndef grok_numeric_radix
700	# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(aTHX_ sp, send)
701
702	#define grok_numeric_radix Perl_grok_numeric_radix
703
704	bool
705	Perl_grok_numeric_radix(pTHX_ const char *sp, const char send)
706	{
707	#ifdef USE_LOCALE_NUMERIC
708	#if (PERL_VERSION > 6) \|\| ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1))
709	if (PL_numeric_radix_sv && IN_LOCALE) {
710	STRLEN len;
711	char* radix = SvPV(PL_numeric_radix_sv, len);
712	if (sp + len <= send && memEQ(sp, radix, len)) {
713	*sp += len;
714	return TRUE;
715	}
716	}
717	#else
718	/* pre5.6.0 perls don't have PL_numeric_radix_sv so the radix
719	* must manually be requested from locale.h */
720	#include <locale.h>
721	struct lconv *lc = localeconv();
722	char *radix = lc->decimal_point;
723	if (radix && IN_LOCALE) {
724	STRLEN len = strlen(radix);
725	if (sp + len <= send && memEQ(sp, radix, len)) {
726	*sp += len;
727	return TRUE;
728	}
729	}
730	#endif /* PERL_VERSION */
731	#endif /* USE_LOCALE_NUMERIC */
732	/* always try "." if numeric radix didn't match because
733	* we may have data from different locales mixed */
734	if (sp < send && *sp == '.') {
735	++*sp;
736	return TRUE;
737	}
738	return FALSE;
739	}
740	#endif /* grok_numeric_radix */
741
742	#ifndef grok_number
743
744	#define grok_number Perl_grok_number
745
746	int
747	Perl_grok_number(pTHX_ const char pv, STRLEN len, UV valuep)
748	{
749	const char *s = pv;
750	const char *send = pv + len;
751	const UV max_div_10 = UV_MAX / 10;
752	const char max_mod_10 = UV_MAX % 10;
753	int numtype = 0;
754	int sawinf = 0;
755	int sawnan = 0;
756
757	while (s < send && isSPACE(*s))
758	s++;
759	if (s == send) {
760	return 0;
761	} else if (*s == '-') {
762	s++;
763	numtype = IS_NUMBER_NEG;
764	}
765	else if (*s == '+')
766	s++;
767
768	if (s == send)
769	return 0;
770
771	/* next must be digit or the radix separator or beginning of infinity */
772	if (isDIGIT(*s)) {
773	/* UVs are at least 32 bits, so the first 9 decimal digits cannot
774	overflow. */
775	UV value = *s - '0';
776	/* This construction seems to be more optimiser friendly.
777	(without it gcc does the isDIGIT test and the *s - '0' separately)
778	With it gcc on arm is managing 6 instructions (6 cycles) per digit.
779	In theory the optimiser could deduce how far to unroll the loop
780	before checking for overflow. */
781	if (++s < send) {
782	int digit = *s - '0';
783	if (digit >= 0 && digit <= 9) {
784	value = value * 10 + digit;
785	if (++s < send) {
786	digit = *s - '0';
787	if (digit >= 0 && digit <= 9) {
788	value = value * 10 + digit;
789	if (++s < send) {
790	digit = *s - '0';
791	if (digit >= 0 && digit <= 9) {
792	value = value * 10 + digit;
793	if (++s < send) {
794	digit = *s - '0';
795	if (digit >= 0 && digit <= 9) {
796	value = value * 10 + digit;
797	if (++s < send) {
798	digit = *s - '0';
799	if (digit >= 0 && digit <= 9) {
800	value = value * 10 + digit;
801	if (++s < send) {
802	digit = *s - '0';
803	if (digit >= 0 && digit <= 9) {
804	value = value * 10 + digit;
805	if (++s < send) {
806	digit = *s - '0';
807	if (digit >= 0 && digit <= 9) {
808	value = value * 10 + digit;
809	if (++s < send) {
810	digit = *s - '0';
811	if (digit >= 0 && digit <= 9) {
812	value = value * 10 + digit;
813	if (++s < send) {
814	/* Now got 9 digits, so need to check
815	each time for overflow. */
816	digit = *s - '0';
817	while (digit >= 0 && digit <= 9
818	&& (value < max_div_10
819	\|\| (value == max_div_10
820	&& digit <= max_mod_10))) {
821	value = value * 10 + digit;
822	if (++s < send)
823	digit = *s - '0';
824	else
825	break;
826	}
827	if (digit >= 0 && digit <= 9
828	&& (s < send)) {
829	/* value overflowed.
830	skip the remaining digits, don't
831	worry about setting valuep. /
832	do {
833	s++;
834	} while (s < send && isDIGIT(*s));
835	numtype \|=
836	IS_NUMBER_GREATER_THAN_UV_MAX;
837	goto skip_value;
838	}
839	}
840	}
841	}
842	}
843	}
844	}
845	}
846	}
847	}
848	}
849	}
850	}
851	}
852	}
853	}
854	}
855	}
856	numtype \|= IS_NUMBER_IN_UV;
857	if (valuep)
858	*valuep = value;
859
860	skip_value:
861	if (GROK_NUMERIC_RADIX(&s, send)) {
862	numtype \|= IS_NUMBER_NOT_INT;
863	while (s < send && isDIGIT(s)) / optional digits after the radix */
864	s++;
865	}
866	}
867	else if (GROK_NUMERIC_RADIX(&s, send)) {
868	numtype \|= IS_NUMBER_NOT_INT \| IS_NUMBER_IN_UV; /* valuep assigned below */
869	/* no digits before the radix means we need digits after it */
870	if (s < send && isDIGIT(*s)) {
871	do {
872	s++;
873	} while (s < send && isDIGIT(*s));
874	if (valuep) {
875	/* integer approximation is valid - it's 0. */
876	*valuep = 0;
877	}
878	}
879	else
880	return 0;
881	} else if (s == 'I' \|\| s == 'i') {
882	s++; if (s == send \|\| (s != 'N' && s != 'n')) return 0;
883	s++; if (s == send \|\| (s != 'F' && s != 'f')) return 0;
884	s++; if (s < send && (s == 'I' \|\| s == 'i')) {
885	s++; if (s == send \|\| (s != 'N' && s != 'n')) return 0;
886	s++; if (s == send \|\| (s != 'I' && s != 'i')) return 0;
887	s++; if (s == send \|\| (s != 'T' && s != 't')) return 0;
888	s++; if (s == send \|\| (s != 'Y' && s != 'y')) return 0;
889	s++;
890	}
891	sawinf = 1;
892	} else if (s == 'N' \|\| s == 'n') {
893	/* XXX TODO: There are signaling NaNs and quiet NaNs. */
894	s++; if (s == send \|\| (s != 'A' && s != 'a')) return 0;
895	s++; if (s == send \|\| (s != 'N' && s != 'n')) return 0;
896	s++;
897	sawnan = 1;
898	} else
899	return 0;
900
901	if (sawinf) {
902	numtype &= IS_NUMBER_NEG; /* Keep track of sign */
903	numtype \|= IS_NUMBER_INFINITY \| IS_NUMBER_NOT_INT;
904	} else if (sawnan) {
905	numtype &= IS_NUMBER_NEG; /* Keep track of sign */
906	numtype \|= IS_NUMBER_NAN \| IS_NUMBER_NOT_INT;
907	} else if (s < send) {
908	/* we can have an optional exponent part */
909	if (s == 'e' \|\| s == 'E') {
910	/* The only flag we keep is sign. Blow away any "it's UV" */
911	numtype &= IS_NUMBER_NEG;
912	numtype \|= IS_NUMBER_NOT_INT;
913	s++;
914	if (s < send && (s == '-' \|\| s == '+'))
915	s++;
916	if (s < send && isDIGIT(*s)) {
917	do {
918	s++;
919	} while (s < send && isDIGIT(*s));
920	}
921	else
922	return 0;
923	}
924	}
925	while (s < send && isSPACE(*s))
926	s++;
927	if (s >= send)
928	return numtype;
929	if (len == 10 && memEQ(pv, "0 but true", 10)) {
930	if (valuep)
931	*valuep = 0;
932	return IS_NUMBER_IN_UV;
933	}
934	return 0;
935	}
936	#endif /* grok_number */
937
938	#ifndef PERL_MAGIC_sv
939	# define PERL_MAGIC_sv '\0'
940	#endif
941
942	#ifndef PERL_MAGIC_overload
943	# define PERL_MAGIC_overload 'A'
944	#endif
945
946	#ifndef PERL_MAGIC_overload_elem
947	# define PERL_MAGIC_overload_elem 'a'
948	#endif
949
950	#ifndef PERL_MAGIC_overload_table
951	# define PERL_MAGIC_overload_table 'c'
952	#endif
953
954	#ifndef PERL_MAGIC_bm
955	# define PERL_MAGIC_bm 'B'
956	#endif
957
958	#ifndef PERL_MAGIC_regdata
959	# define PERL_MAGIC_regdata 'D'
960	#endif
961
962	#ifndef PERL_MAGIC_regdatum
963	# define PERL_MAGIC_regdatum 'd'
964	#endif
965
966	#ifndef PERL_MAGIC_env
967	# define PERL_MAGIC_env 'E'
968	#endif
969
970	#ifndef PERL_MAGIC_envelem
971	# define PERL_MAGIC_envelem 'e'
972	#endif
973
974	#ifndef PERL_MAGIC_fm
975	# define PERL_MAGIC_fm 'f'
976	#endif
977
978	#ifndef PERL_MAGIC_regex_global
979	# define PERL_MAGIC_regex_global 'g'
980	#endif
981
982	#ifndef PERL_MAGIC_isa
983	# define PERL_MAGIC_isa 'I'
984	#endif
985
986	#ifndef PERL_MAGIC_isaelem
987	# define PERL_MAGIC_isaelem 'i'
988	#endif
989
990	#ifndef PERL_MAGIC_nkeys
991	# define PERL_MAGIC_nkeys 'k'
992	#endif
993
994	#ifndef PERL_MAGIC_dbfile
995	# define PERL_MAGIC_dbfile 'L'
996	#endif
997
998	#ifndef PERL_MAGIC_dbline
999	# define PERL_MAGIC_dbline 'l'
1000	#endif
1001
1002	#ifndef PERL_MAGIC_mutex
1003	# define PERL_MAGIC_mutex 'm'
1004	#endif
1005
1006	#ifndef PERL_MAGIC_shared
1007	# define PERL_MAGIC_shared 'N'
1008	#endif
1009
1010	#ifndef PERL_MAGIC_shared_scalar
1011	# define PERL_MAGIC_shared_scalar 'n'
1012	#endif
1013
1014	#ifndef PERL_MAGIC_collxfrm
1015	# define PERL_MAGIC_collxfrm 'o'
1016	#endif
1017
1018	#ifndef PERL_MAGIC_tied
1019	# define PERL_MAGIC_tied 'P'
1020	#endif
1021
1022	#ifndef PERL_MAGIC_tiedelem
1023	# define PERL_MAGIC_tiedelem 'p'
1024	#endif
1025
1026	#ifndef PERL_MAGIC_tiedscalar
1027	# define PERL_MAGIC_tiedscalar 'q'
1028	#endif
1029
1030	#ifndef PERL_MAGIC_qr
1031	# define PERL_MAGIC_qr 'r'
1032	#endif
1033
1034	#ifndef PERL_MAGIC_sig
1035	# define PERL_MAGIC_sig 'S'
1036	#endif
1037
1038	#ifndef PERL_MAGIC_sigelem
1039	# define PERL_MAGIC_sigelem 's'
1040	#endif
1041
1042	#ifndef PERL_MAGIC_taint
1043	# define PERL_MAGIC_taint 't'
1044	#endif
1045
1046	#ifndef PERL_MAGIC_uvar
1047	# define PERL_MAGIC_uvar 'U'
1048	#endif
1049
1050	#ifndef PERL_MAGIC_uvar_elem
1051	# define PERL_MAGIC_uvar_elem 'u'
1052	#endif
1053
1054	#ifndef PERL_MAGIC_vstring
1055	# define PERL_MAGIC_vstring 'V'
1056	#endif
1057
1058	#ifndef PERL_MAGIC_vec
1059	# define PERL_MAGIC_vec 'v'
1060	#endif
1061
1062	#ifndef PERL_MAGIC_utf8
1063	# define PERL_MAGIC_utf8 'w'
1064	#endif
1065
1066	#ifndef PERL_MAGIC_substr
1067	# define PERL_MAGIC_substr 'x'
1068	#endif
1069
1070	#ifndef PERL_MAGIC_defelem
1071	# define PERL_MAGIC_defelem 'y'
1072	#endif
1073
1074	#ifndef PERL_MAGIC_glob
1075	# define PERL_MAGIC_glob '*'
1076	#endif
1077
1078	#ifndef PERL_MAGIC_arylen
1079	# define PERL_MAGIC_arylen '#'
1080	#endif
1081
1082	#ifndef PERL_MAGIC_pos
1083	# define PERL_MAGIC_pos '.'
1084	#endif
1085
1086	#ifndef PERL_MAGIC_backref
1087	# define PERL_MAGIC_backref '<'
1088	#endif
1089
1090	#ifndef PERL_MAGIC_ext
1091	# define PERL_MAGIC_ext '~'
1092	#endif
1093
1094	#endif /* _P_P_PORTABILITY_H_ */
1095
1096	/* End of File ppport.h */

Note: See TracBrowser for help on using the browser.

Context Navigation

root/lang/perl/Acme-NabeAtzz/trunk/ppport.h

Download in other formats: