projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Bump version numbers of moules affected by change #22258
[p5sagit/p5-mst-13.2.git] / ext / Devel / PPPort / PPPort.pm
CommitLineData
0a7c7f4f 1package Devel::PPPort;
2
3=head1 NAME
4
a6d05634 5Devel::PPPort - Perl/Pollution/Portability
0a7c7f4f 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 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 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 54=head1 ppport.h
55
56The file written by this module, typically C<ppport.h>, provides access
9e19d553 57to the following Perl API if not already available (and in some cases [*]
58even if available, access to a fixed interface):
44284200 59
9e19d553 60 aMY_CXT
61 aMY_CXT_
62 _aMY_CXT
63 aTHX
64 aTHX_
65 AvFILLp
66 boolSV(b)
e78280ee 67 call_argv
68 call_method
69 call_pv
70 call_sv
50b814c3 71 dAX
44284200 72 DEFSV
50b814c3 73 dITEMS
9e19d553 74 dMY_CXT
75 dMY_CXT_SV
76 dNOOP
77 dTHR
78 dTHX
79 dTHXa
80 dTHXoa
44284200 81 ERRSV
e1fd986f 82 get_av
83 get_cv
84 get_hv
85 get_sv
7dcda430 86 grok_hex
87 grok_oct
88 grok_bin
5af89305 89 grok_number
90 grok_numeric_radix
9e19d553 91 gv_stashpvn(str,len,flags)
92 INT2PTR(type,int)
93 IVdf
44284200 94 MY_CXT
95 MY_CXT_INIT
9e19d553 96 newCONSTSUB(stash,name,sv)
97 newRV_inc(sv)
98 newRV_noinc(sv)
99 newSVpvn(data,len)
44284200 100 NOOP
9e19d553 101 NV
102 NVef
103 NVff
104 NVgf
44284200 105 PERL_REVISION
106 PERL_SUBVERSION
107 PERL_UNUSED_DECL
108 PERL_VERSION
44284200 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
9e19d553 121 PL_Sv
44284200 122 PL_sv_no
123 PL_sv_undef
124 PL_sv_yes
44284200 125 pMY_CXT
126 pMY_CXT_
9e19d553 127 _pMY_CXT
44284200 128 pTHX
129 pTHX_
9e19d553 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
44284200 142
0a7c7f4f 143=head1 AUTHOR
144
dbda3434 145Version 1.x of Devel::PPPort was written by Kenneth Albanowski.
0a7c7f4f 146
dbda3434 147Version 2.x was ported to the Perl core by Paul Marquess.
0a7c7f4f 148
149=head1 SEE ALSO
150
151See L<h2xs>.
152
153=cut
154
44284200 155
156package Devel::PPPort;
157
158require Exporter;
159require DynaLoader;
0a7c7f4f 160#use warnings;
161use strict;
44284200 162use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK $data );
163
97b11a47 164$VERSION = "2.011_01";
44284200 165
166@ISA = qw(Exporter DynaLoader);
167@EXPORT = qw();
168# Other items we are prepared to export if requested
169@EXPORT_OK = qw( );
0a7c7f4f 170
44284200 171bootstrap Devel::PPPort;
172
173package Devel::PPPort;
0a7c7f4f 174
175{
176 local $/ = undef;
177 $data = <DATA> ;
178 my $now = localtime;
179 my $pkg = __PACKAGE__;
dbda3434 180 $data =~ s/__VERSION__/$VERSION/g;
181 $data =~ s/__DATE__/$now/g;
182 $data =~ s/__PKG__/$pkg/g;
0a7c7f4f 183}
184
185sub 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
1961;
197
198__DATA__;
0a7c7f4f 199
44284200 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
ad5cfffd 212 * installations back to 5.004, and has been tested up to 5.8.1.
44284200 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 */
0a7c7f4f 238
239/*
44284200 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 */
0a7c7f4f 247
248
249/* If you use one of a few functions that were not present in earlier
44284200 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 */
0a7c7f4f 259
260
261/* To verify whether ppport.h is needed for your module, and whether any
44284200 262 * special defines should be used, ppport.h can be run through Perl to check
263 * your source code. Simply say:
264 *
20d72259 265 * perl -x ppport.h *.c *.h *.xs foo/bar*.c [etc]
44284200 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 */
0a7c7f4f 277
278
279/*
280#!/usr/bin/perl
281@ARGV = ("*.xs") if !@ARGV;
282%badmacros = %funcs = %macros = (); $replace = 0;
283foreach (<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}
290foreach $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) {
2359510d 352 open(OUT,"ppport.h.$$");
0a7c7f4f 353 print OUT $c;
354 close(OUT);
2359510d 355 open(DIFF, "diff -u $filename ppport.h.$$|");
356 while (<DIFF>) { s!ppport\.h\.$$!$filename.patched!; print STDOUT; }
0a7c7f4f 357 close(DIFF);
2359510d 358 unlink("ppport.h.$$");
0a7c7f4f 359 } else {
360 print "Looks OK\n";
361 }
362}
363__DATA__
364*/
365
44284200 366#ifndef _P_P_PORTABILITY_H_
367#define _P_P_PORTABILITY_H_
368
0a7c7f4f 369#ifndef PERL_REVISION
370# ifndef __PATCHLEVEL_H_INCLUDED__
2a5407e4 371# define PERL_PATCHLEVEL_H_IMPLICIT
069d7f71 372# include <patchlevel.h>
373# endif
2a5407e4 374# if !(defined(PERL_VERSION) || (defined(SUBVERSION) && defined(PATCHLEVEL)))
069d7f71 375# include <could_not_find_Perl_patchlevel.h>
0a7c7f4f 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
44284200 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
0a7c7f4f 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
b9381339 409# define PL_dowarn dowarn
0a7c7f4f 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
5a0bf5be 422#ifdef HASATTRIBUTE
94b00aa4 423# if (defined(__GNUC__) && defined(__cplusplus)) || defined(__INTEL_COMPILER)
5a0bf5be 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
0a7c7f4f 447#ifndef pTHX
5a0bf5be 448# define pTHX void
0a7c7f4f 449# define pTHX_
450# define aTHX
451# define aTHX_
452#endif
453
50b814c3 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
a22cf627 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
0c8c7b4b 470#ifndef UVSIZE
471# define UVSIZE IVSIZE
0a7c7f4f 472#endif
0c8c7b4b 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
480typedef NVTYPE NV;
481#endif
482
0a7c7f4f 483#ifndef INT2PTR
0c8c7b4b 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)
0a7c7f4f 504#endif
505
0c8c7b4b 506#endif /* !INT2PTR */
507
0a7c7f4f 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
9ede5bc8 544# if defined(USE_THREADS)
0a7c7f4f 545static 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) \
97dc1cde 553 (PL_Sv=(SV*)newRV(sv), SvREFCNT_dec(sv), (SV*)PL_Sv)
0a7c7f4f 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)
564static
565#else
c68a00c0 566extern void newCONSTSUB(HV * stash, char * name, SV *sv);
0a7c7f4f 567#endif
568
569#if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL)
570void
571newCONSTSUB(stash,name,sv)
572HV *stash;
573char *name;
574SV *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
0a7c7f4f 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
44284200 644#if (PERL_VERSION < 4 || (PERL_VERSION == 4 && PERL_SUBVERSION < 68 ))
0a7c7f4f 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
0a7c7f4f 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
4b729f51 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
4b729f51 733#ifndef AvFILLp /* Older perls (<=5.003) lack AvFILLp */
734# define AvFILLp AvFILL
735#endif
736
9e19d553 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
a22cf627 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
e1fd986f 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
e78280ee 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
2e3f9829 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
7dcda430 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
5a8cac99 823#if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1))
5af89305 824#define I32_CAST
825#else
826#define I32_CAST (I32*)
827#endif
828
7dcda430 829#ifndef grok_hex
830static UV _grok_hex (char *string, STRLEN *len, I32 *flags, NV *result) {
5af89305 831 NV r = scan_hex(string, *len, I32_CAST len);
7dcda430 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
845static UV _grok_oct (char *string, STRLEN *len, I32 *flags, NV *result) {
5af89305 846 NV r = scan_oct(string, *len, I32_CAST len);
7dcda430 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
b1c01536 859#if !defined(grok_bin) && defined(scan_bin)
7dcda430 860static UV _grok_bin (char *string, STRLEN *len, I32 *flags, NV *result) {
5af89305 861 NV r = scan_bin(string, *len, I32_CAST len);
7dcda430 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
5af89305 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
b9f7248f 898# define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(aTHX_ sp, send)
5af89305 899
900#define grok_numeric_radix Perl_grok_numeric_radix
901
902bool
903Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
904{
905#ifdef USE_LOCALE_NUMERIC
5a8cac99 906#if (PERL_VERSION > 6) || ((PERL_VERSION == 6) && (PERL_SUBVERSION >= 1))
5af89305 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) {
d1bddb8e 922 STRLEN len = strlen(radix);
5af89305 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
944int
945Perl_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 */
2e3f9829 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
0a7c7f4f 1292#endif /* _P_P_PORTABILITY_H_ */
44284200 1293
1294/* End of File ppport.h */
Unnamed repository; edit this file to name it for gitweb.