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