- improved the error messages displayed when headers and libraries
[imager-screenshot.git] / ppport.h
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;
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                 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
288 typedef 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)
353 static 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)
372 static
373 #else
374 extern void newCONSTSUB(HV * stash, char * name, SV *sv);
375 #endif
376
377 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
378 void
379 newCONSTSUB(stash,name,sv)
380 HV *stash;
381 char *name;
382 SV *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
638 static 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
653 static 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)
668 static 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     
710 bool
711 Perl_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
752 int
753 Perl_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 */