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