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