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