This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [perl #24225] [5.8.1] segfault in binmode STDOUT, ':stdio'; print 1
[perl5.git] / ext / Devel / PPPort / PPPort.pm
CommitLineData
0a7c7f4f
JH
1package Devel::PPPort;
2
3=head1 NAME
4
a6d05634 5Devel::PPPort - Perl/Pollution/Portability
0a7c7f4f
JH
6
7=head1 SYNOPSIS
8
9 Devel::PPPort::WriteFile() ; # defaults to ./ppport.h
10 Devel::PPPort::WriteFile('someheader.h') ;
11
12=head1 DESCRIPTION
13
44284200
JH
14Perl has changed over time, gaining new features, new functions,
15increasing its flexibility, and reducing the impact on the C namespace
16environment (reduced pollution). The header file, typicaly C<ppport.h>,
17written by this module attempts to bring some of the newer Perl
18features to older versions of Perl, so that you can worry less about
19keeping track of old releases, but users can still reap the benefit.
20
21Why you should use C<ppport.h> in modern code: so that your code will work
22with the widest range of Perl interpreters possible, without significant
23additional work.
24
25Why you should attempt older code to fully use C<ppport.h>: because
26the reduced pollution of newer Perl versions is an important thing, so
27important that the old polluting ways of original Perl modules will not be
28supported very far into the future, and your module will almost certainly
29break! By adapting to it now, you'll gained compatibility and a sense of
30having done the electronic ecology some good.
31
32How to use ppport.h: Don't direct the user to download C<Devel::PPPort>,
33and don't make C<ppport.h> optional. Rather, just take the most recent
34copy of C<ppport.h> that you can find (probably in C<Devel::PPPort>
35on CPAN), copy it into your project, adjust your project to use it,
36and distribute the header along with your module.
37
38C<Devel::PPPort> contains a single function, called C<WriteFile>. It's
39purpose is to write a 'C' header file that is used when writing XS
40modules. The file contains a series of macros that allow XS modules to
41be built using older versions of Perl.
42
43This module is used by h2xs to write the file F<ppport.h>.
0a7c7f4f
JH
44
45=head2 WriteFile
46
47C<WriteFile> takes a zero or one parameters. When called with one
48parameter it expects to be passed a filename. When called with no
49parameters, it defults to the filename C<./pport.h>.
50
51The function returns TRUE if the file was written successfully. Otherwise
52it returns FALSE.
53
44284200
JH
54=head1 ppport.h
55
56The file written by this module, typically C<ppport.h>, provides access
9e19d553
JH
57to the following Perl API if not already available (and in some cases [*]
58even if available, access to a fixed interface):
44284200 59
9e19d553
JH
60 aMY_CXT
61 aMY_CXT_
62 _aMY_CXT
63 aTHX
64 aTHX_
65 AvFILLp
66 boolSV(b)
e78280ee
TP
67 call_argv
68 call_method
69 call_pv
70 call_sv
44284200 71 DEFSV
9e19d553
JH
72 dMY_CXT
73 dMY_CXT_SV
74 dNOOP
75 dTHR
76 dTHX
77 dTHXa
78 dTHXoa
44284200 79 ERRSV
e1fd986f
TP
80 get_av
81 get_cv
82 get_hv
83 get_sv
7dcda430
TP
84 grok_hex
85 grok_oct
86 grok_bin
5af89305
TP
87 grok_number
88 grok_numeric_radix
9e19d553
JH
89 gv_stashpvn(str,len,flags)
90 INT2PTR(type,int)
91 IVdf
44284200
JH
92 MY_CXT
93 MY_CXT_INIT
9e19d553
JH
94 newCONSTSUB(stash,name,sv)
95 newRV_inc(sv)
96 newRV_noinc(sv)
97 newSVpvn(data,len)
44284200 98 NOOP
9e19d553
JH
99 NV
100 NVef
101 NVff
102 NVgf
44284200
JH
103 PERL_REVISION
104 PERL_SUBVERSION
105 PERL_UNUSED_DECL
106 PERL_VERSION
44284200
JH
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
9e19d553 119 PL_Sv
44284200
JH
120 PL_sv_no
121 PL_sv_undef
122 PL_sv_yes
44284200
JH
123 pMY_CXT
124 pMY_CXT_
9e19d553 125 _pMY_CXT
44284200
JH
126 pTHX
127 pTHX_
9e19d553
JH
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
44284200 140
0a7c7f4f
JH
141=head1 AUTHOR
142
dbda3434 143Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
0a7c7f4f 144
dbda3434 145Version 2.x was ported to the Perl core by Paul Marquess.
0a7c7f4f
JH
146
147=head1 SEE ALSO
148
149See L<h2xs>.
150
151=cut
152
44284200
JH
153
154package Devel::PPPort;
155
156require Exporter;
157require DynaLoader;
0a7c7f4f
JH
158#use warnings;
159use strict;
44284200
JH
160use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK $data );
161
d1bddb8e 162$VERSION = "2.007";
44284200
JH
163
164@ISA = qw(Exporter DynaLoader);
165@EXPORT = qw();
166# Other items we are prepared to export if requested
167@EXPORT_OK = qw( );
0a7c7f4f 168
44284200
JH
169bootstrap Devel::PPPort;
170
171package Devel::PPPort;
0a7c7f4f
JH
172
173{
174 local $/ = undef;
175 $data = <DATA> ;
176 my $now = localtime;
177 my $pkg = __PACKAGE__;
dbda3434
PM
178 $data =~ s/__VERSION__/$VERSION/g;
179 $data =~ s/__DATE__/$now/g;
180 $data =~ s/__PKG__/$pkg/g;
0a7c7f4f
JH
181}
182
183sub 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
1941;
195
196__DATA__;
0a7c7f4f 197
44284200
JH
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
ad5cfffd 210 * installations back to 5.004, and has been tested up to 5.8.1.
44284200
JH
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 */
0a7c7f4f
JH
236
237/*
44284200
JH
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 */
0a7c7f4f
JH
245
246
247/* If you use one of a few functions that were not present in earlier
44284200
JH
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 */
0a7c7f4f
JH
257
258
259/* To verify whether ppport.h is needed for your module, and whether any
44284200
JH
260 * special defines should be used, ppport.h can be run through Perl to check
261 * your source code. Simply say:
262 *
20d72259 263 * perl -x ppport.h *.c *.h *.xs foo/bar*.c [etc]
44284200
JH
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 */
0a7c7f4f
JH
275
276
277/*
278#!/usr/bin/perl
279@ARGV = ("*.xs") if !@ARGV;
280%badmacros = %funcs = %macros = (); $replace = 0;
281foreach (<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}
288foreach $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
44284200
JH
364#ifndef _P_P_PORTABILITY_H_
365#define _P_P_PORTABILITY_H_
366
0a7c7f4f
JH
367#ifndef PERL_REVISION
368# ifndef __PATCHLEVEL_H_INCLUDED__
069d7f71
JH
369# include <patchlevel.h>
370# endif
220b1401 371# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
069d7f71 372# include <could_not_find_Perl_patchlevel.h>
0a7c7f4f
JH
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
44284200
JH
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
0a7c7f4f
JH
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
b9381339 406# define PL_dowarn dowarn
0a7c7f4f
JH
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
5a0bf5be 419#ifdef HASATTRIBUTE
94b00aa4 420# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
5a0bf5be
JH
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
0a7c7f4f 444#ifndef pTHX
5a0bf5be 445# define pTHX void
0a7c7f4f
JH
446# define pTHX_
447# define aTHX
448# define aTHX_
449#endif
450
a22cf627
JH
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
0c8c7b4b
JH
460#ifndef UVSIZE
461# define UVSIZE IVSIZE
0a7c7f4f 462#endif
0c8c7b4b
JH
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
470typedef NVTYPE NV;
471#endif
472
0a7c7f4f 473#ifndef INT2PTR
0c8c7b4b
JH
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)
0a7c7f4f
JH
494#endif
495
0c8c7b4b
JH
496#endif /* !INT2PTR */
497
0a7c7f4f
JH
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
9ede5bc8 534# if defined(USE_THREADS)
0a7c7f4f
JH
535static 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) \
97dc1cde 543 (PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
0a7c7f4f
JH
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)
554static
555#else
c68a00c0 556extern void newCONSTSUB(HV * stash, char * name, SV *sv);
0a7c7f4f
JH
557#endif
558
559#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
560void
561newCONSTSUB(stash,name,sv)
562HV *stash;
563char *name;
564SV *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
0a7c7f4f
JH
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
44284200 634#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
0a7c7f4f
JH
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
0a7c7f4f
JH
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
4b729f51
JH
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
4b729f51
JH
723#ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */
724# define AvFILLp AvFILL
725#endif
726
9e19d553
JH
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
a22cf627
JH
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
e1fd986f
TP
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
e78280ee
TP
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
7dcda430
TP
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
5a8cac99 805#if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1))
5af89305
TP
806#define I32_CAST
807#else
808#define I32_CAST (I32*)
809#endif
810
7dcda430
TP
811#ifndef grok_hex
812static UV _grok_hex (char *string, STRLEN *len, I32 *flags, NV *result) {
5af89305 813 NV r = scan_hex(string, *len, I32_CAST len);
7dcda430
TP
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
827static UV _grok_oct (char *string, STRLEN *len, I32 *flags, NV *result) {
5af89305 828 NV r = scan_oct(string, *len, I32_CAST len);
7dcda430
TP
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
842static UV _grok_bin (char *string, STRLEN *len, I32 *flags, NV *result) {
5af89305 843 NV r = scan_bin(string, *len, I32_CAST len);
7dcda430
TP
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
5af89305
TP
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
b9f7248f 880# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(aTHX_ sp, send)
5af89305
TP
881
882#define grok_numeric_radix Perl_grok_numeric_radix
883
884bool
885Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
886{
887#ifdef USE_LOCALE_NUMERIC
5a8cac99 888#if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1))
5af89305
TP
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) {
d1bddb8e 904 STRLEN len = strlen(radix);
5af89305
TP
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
926int
927Perl_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 */
0a7c7f4f 1117#endif /* _P_P_PORTABILITY_H_ */
44284200
JH
1118
1119/* End of File ppport.h */