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