This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Change name of mutex macro.
[perl5.git] / ext / POSIX / POSIX.xs
<
CommitLineData
6e22d046 1#define PERL_EXT_POSIX
755599da 2#define PERL_EXT
6e22d046 3
2986a63f
JH
4#ifdef NETWARE
5 #define _POSIX_
4efcf9a2
SB
6 /*
7 * Ideally this should be somewhere down in the includes
8 * but putting it in other places is giving compiler errors.
9 * Also here I am unable to check for HAS_UNAME since it wouldn't have
10 * yet come into the file at this stage - sgp 18th Oct 2000
11 */
2986a63f
JH
12 #include <sys/utsname.h>
13#endif /* NETWARE */
14
c5be433b
GS
15#define PERL_NO_GET_CONTEXT
16
463ee0b2 17#include "EXTERN.h"
760ac839 18#define PERLIO_NOT_STDIO 1
463ee0b2
LW
19#include "perl.h"
20#include "XSUB.h"
effb4c81
JH
21
22static int not_here(const char *s);
23
acfe0abc 24#if defined(PERL_IMPLICIT_SYS)
873ef191
GS
25# undef signal
26# undef open
cd661bb6 27# undef setmode
35ff7856 28# define open PerlLIO_open3
873ef191 29#endif
2304df62 30#include <ctype.h>
a0d0e21e 31#ifdef I_DIRENT /* XXX maybe better to just rely on perl.h? */
2304df62 32#include <dirent.h>
a0d0e21e 33#endif
2304df62 34#include <errno.h>
b0ba2190
SH
35#ifdef WIN32
36#include <sys/errno2.h>
37#endif
2304df62 38#include <float.h>
a5713e21 39#ifdef I_FENV
84e4d7a5 40#if !(defined(__vax__) && defined(__NetBSD__))
a5713e21
JH
41#include <fenv.h>
42#endif
84e4d7a5 43#endif
2304df62
AD
44#include <limits.h>
45#include <locale.h>
46#include <math.h>
85e6fe83 47#ifdef I_PWD
2304df62 48#include <pwd.h>
85e6fe83 49#endif
2304df62
AD
50#include <setjmp.h>
51#include <signal.h>
2304df62 52#include <stdarg.h>
2304df62 53#include <stddef.h>
6990d991 54
b5846a0b
BS
55#ifdef I_UNISTD
56#include <unistd.h>
57#endif
58
4fd667a8
TC
59#ifdef I_SYS_TIME
60# include <sys/time.h>
61#endif
62
63#ifdef I_SYS_RESOURCE
64# include <sys/resource.h>
65#endif
66
042887fa
TC
67/* Cygwin's stdio.h doesn't make cuserid() visible with -D_GNU_SOURCE,
68 unlike Linux.
69*/
70#ifdef __CYGWIN__
71# undef HAS_CUSERID
72#endif
73
05b4a618
JH
74#if defined(USE_QUADMATH) && defined(I_QUADMATH)
75
76# undef M_E
77# undef M_LOG2E
78# undef M_LOG10E
79# undef M_LN2
80# undef M_LN10
81# undef M_PI
82# undef M_PI_2
83# undef M_PI_4
84# undef M_1_PI
85# undef M_2_PI
86# undef M_2_SQRTPI
87# undef M_SQRT2
88# undef M_SQRT1_2
89
90# define M_E M_Eq
91# define M_LOG2E M_LOG2Eq
92# define M_LOG10E M_LOG10Eq
93# define M_LN2 M_LN2q
94# define M_LN10 M_LN10q
95# define M_PI M_PIq
96# define M_PI_2 M_PI_2q
97# define M_PI_4 M_PI_4q
98# define M_1_PI M_1_PIq
99# define M_2_PI M_2_PIq
100# define M_2_SQRTPI M_2_SQRTPIq
101# define M_SQRT2 M_SQRT2q
102# define M_SQRT1_2 M_SQRT1_2q
103
104#else
105
19035550
JH
106# ifdef USE_LONG_DOUBLE
107# undef M_E
108# undef M_LOG2E
109# undef M_LOG10E
110# undef M_LN2
111# undef M_LN10
112# undef M_PI
113# undef M_PI_2
114# undef M_PI_4
115# undef M_1_PI
116# undef M_2_PI
117# undef M_2_SQRTPI
118# undef M_SQRT2
119# undef M_SQRT1_2
120# define FLOAT_C(c) CAT2(c,L)
121# else
122# define FLOAT_C(c) (c)
123# endif
124
05b4a618 125# ifndef M_E
19035550 126# define M_E FLOAT_C(2.71828182845904523536028747135266250)
05b4a618
JH
127# endif
128# ifndef M_LOG2E
19035550 129# define M_LOG2E FLOAT_C(1.44269504088896340735992468100189214)
05b4a618
JH
130# endif
131# ifndef M_LOG10E
19035550 132# define M_LOG10E FLOAT_C(0.434294481903251827651128918916605082)
05b4a618
JH
133# endif
134# ifndef M_LN2
19035550 135# define M_LN2 FLOAT_C(0.693147180559945309417232121458176568)
05b4a618
JH
136# endif
137# ifndef M_LN10
19035550 138# define M_LN10 FLOAT_C(2.30258509299404568401799145468436421)
05b4a618
JH
139# endif
140# ifndef M_PI
19035550 141# define M_PI FLOAT_C(3.14159265358979323846264338327950288)
05b4a618
JH
142# endif
143# ifndef M_PI_2
19035550 144# define M_PI_2 FLOAT_C(1.57079632679489661923132169163975144)
05b4a618
JH
145# endif
146# ifndef M_PI_4
19035550 147# define M_PI_4 FLOAT_C(0.785398163397448309615660845819875721)
05b4a618
JH
148# endif
149# ifndef M_1_PI
19035550 150# define M_1_PI FLOAT_C(0.318309886183790671537767526745028724)
05b4a618
JH
151# endif
152# ifndef M_2_PI
19035550 153# define M_2_PI FLOAT_C(0.636619772367581343075535053490057448)
05b4a618
JH
154# endif
155# ifndef M_2_SQRTPI
19035550 156# define M_2_SQRTPI FLOAT_C(1.12837916709551257389615890312154517)
05b4a618
JH
157# endif
158# ifndef M_SQRT2
19035550 159# define M_SQRT2 FLOAT_C(1.41421356237309504880168872420969808)
05b4a618
JH
160# endif
161# ifndef M_SQRT1_2
19035550 162# define M_SQRT1_2 FLOAT_C(0.707106781186547524400844362104849039)
05b4a618
JH
163# endif
164
39b5f1c4
JH
165#endif
166
a5f1a7e5
JH
167#if !defined(INFINITY) && defined(NV_INF)
168# define INFINITY NV_INF
169#endif
170
171#if !defined(NAN) && defined(NV_NAN)
172# define NAN NV_NAN
173#endif
174
175#if !defined(Inf) && defined(NV_INF)
176# define Inf NV_INF
177#endif
178
179#if !defined(NaN) && defined(NV_NAN)
180# define NaN NV_NAN
181#endif
182
935e3c48 183/* We will have an emulation. */
3f8e6f93 184#ifndef FP_INFINITE
935e3c48
JH
185# define FP_INFINITE 0
186# define FP_NAN 1
187# define FP_NORMAL 2
188# define FP_SUBNORMAL 3
189# define FP_ZERO 4
190#endif
191
e0939537
JH
192/* We will have an emulation. */
193#ifndef FE_TONEAREST
ebac59ac
JH
194# define FE_TOWARDZERO 0
195# define FE_TONEAREST 1
196# define FE_UPWARD 2
197# define FE_DOWNWARD 3
e0939537
JH
198#endif
199
7965edec
JH
200/* C89 math.h:
201
202 acos asin atan atan2 ceil cos cosh exp fabs floor fmod frexp ldexp
203 log log10 modf pow sin sinh sqrt tan tanh
204
205 * Implemented in core:
206
207 atan2 cos exp log pow sin sqrt
208
9d233e12 209 * C99 math.h added:
7965edec 210
9d233e12
JH
211 acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma fmax
212 fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal isinf
213 isless islessequal islessgreater isnan isnormal isunordered lgamma
9e010b89 214 log1p log2 logb lrint lround nan nearbyint nextafter nexttoward remainder
9d233e12 215 remquo rint round scalbn signbit tgamma trunc
7965edec 216
36467c3a
JH
217 See:
218 http://pubs.opengroup.org/onlinepubs/009695399/basedefs/math.h.html
219
26e0f0d3 220 * Berkeley/SVID extensions:
7965edec 221
26e0f0d3 222 j0 j1 jn y0 y1 yn
7965edec 223
427d28ce 224 * Configure already (5.21.5) scans for:
d2bce0fd 225
427d28ce 226 copysign*l* fpclassify isfinite isinf isnan isnan*l* ilogb*l* signbit scalbn*l*
d2bce0fd 227
26e0f0d3 228 * For floating-point round mode (which matters for e.g. lrint and rint)
9d233e12 229
26e0f0d3 230 fegetround fesetround
9d233e12 231
7965edec
JH
232*/
233
9d233e12
JH
234/* XXX Constant FP_FAST_FMA (if true, FMA is faster) */
235
5716d070
JH
236/* XXX Add ldiv(), lldiv()? It's C99, but from stdlib.h, not math.h */
237
39b5f1c4 238/* XXX Beware old gamma() -- one cannot know whether that is the
d334ccbe 239 * gamma or the log of gamma, that's why the new tgamma and lgamma.
2e9cdb62 240 * Though also remember lgamma_r. */
39b5f1c4 241
e0972548
JH
242/* Certain AIX releases have the C99 math, but not in long double.
243 * The <math.h> has them, e.g. __expl128, but no library has them!
78c93c95 244 *
42f1389c 245 * Also see the comments in hints/aix.sh about long doubles. */
e0972548 246
f1498836
JH
247#if defined(USE_QUADMATH) && defined(I_QUADMATH)
248# define c99_acosh acoshq
249# define c99_asinh asinhq
250# define c99_atanh atanhq
251# define c99_cbrt cbrtq
252# define c99_copysign copysignq
253# define c99_erf erfq
254# define c99_erfc erfcq
05b4a618 255/* no exp2q */
f1498836
JH
256# define c99_expm1 expm1q
257# define c99_fdim fdimq
258# define c99_fma fmaq
259# define c99_fmax fmaxq
260# define c99_fmin fminq
261# define c99_hypot hypotq
262# define c99_ilogb ilogbq
263# define c99_lgamma lgammaq
264# define c99_log1p log1pq
265# define c99_log2 log2q
05b4a618 266/* no logbq */
568793b6
JH
267# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG
268# define c99_lrint llrintq
269# define c99_lround llroundq
270# else
271# define c99_lrint lrintq
272# define c99_lround lroundq
273# endif
f1498836
JH
274# define c99_nan nanq
275# define c99_nearbyint nearbyintq
276# define c99_nextafter nextafterq
05b4a618 277/* no nexttowardq */
f1498836
JH
278# define c99_remainder remainderq
279# define c99_remquo remquoq
280# define c99_rint rintq
281# define c99_round roundq
282# define c99_scalbn scalbnq
283# define c99_signbit signbitq
284# define c99_tgamma tgammaq
285# define c99_trunc truncq
286# define bessel_j0 j0q
287# define bessel_j1 j1q
288# define bessel_jn jnq
289# define bessel_y0 y0q
290# define bessel_y1 y1q
291# define bessel_yn ynq
292#elif defined(USE_LONG_DOUBLE) && \
22192125
JH
293 (defined(HAS_FREXPL) || defined(HAS_ILOGBL)) && defined(HAS_SQRTL)
294/* Use some of the Configure scans for long double math functions
295 * as the canary for all the C99 *l variants being defined. */
f1498836
JH
296# define c99_acosh acoshl
297# define c99_asinh asinhl
298# define c99_atanh atanhl
299# define c99_cbrt cbrtl
300# define c99_copysign copysignl
301# define c99_erf erfl
302# define c99_erfc erfcl
303# define c99_exp2 exp2l
304# define c99_expm1 expm1l
305# define c99_fdim fdiml
306# define c99_fma fmal
307# define c99_fmax fmaxl
308# define c99_fmin fminl
309# define c99_hypot hypotl
310# define c99_ilogb ilogbl
311# define c99_lgamma lgammal
312# define c99_log1p log1pl
313# define c99_log2 log2l
314# define c99_logb logbl
755cce00
JH
315# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLRINTL)
316# define c99_lrint llrintl
317# elif defined(HAS_LRINTL)
f1498836
JH
318# define c99_lrint lrintl
319# endif
755cce00 320# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLROUNDL)
f1498836 321# define c99_lround llroundl
755cce00 322# elif defined(HAS_LROUNDL)
f1498836
JH
323# define c99_lround lroundl
324# endif
325# define c99_nan nanl
326# define c99_nearbyint nearbyintl
327# define c99_nextafter nextafterl
328# define c99_nexttoward nexttowardl
329# define c99_remainder remainderl
330# define c99_remquo remquol
331# define c99_rint rintl
332# define c99_round roundl
333# define c99_scalbn scalbnl
334# ifdef HAS_SIGNBIT /* possibly bad assumption */
335# define c99_signbit signbitl
336# endif
337# define c99_tgamma tgammal
338# define c99_trunc truncl
339#else
340# define c99_acosh acosh
341# define c99_asinh asinh
342# define c99_atanh atanh
343# define c99_cbrt cbrt
344# define c99_copysign copysign
345# define c99_erf erf
346# define c99_erfc erfc
347# define c99_exp2 exp2
348# define c99_expm1 expm1
349# define c99_fdim fdim
350# define c99_fma fma
351# define c99_fmax fmax
352# define c99_fmin fmin
353# define c99_hypot hypot
354# define c99_ilogb ilogb
355# define c99_lgamma lgamma
356# define c99_log1p log1p
357# define c99_log2 log2
358# define c99_logb logb
359# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLRINT)
360# define c99_lrint llrint
361# else
362# define c99_lrint lrint
363# endif
364# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLROUND)
365# define c99_lround llround
7965edec 366# else
f1498836
JH
367# define c99_lround lround
368# endif
369# define c99_nan nan
370# define c99_nearbyint nearbyint
371# define c99_nextafter nextafter
372# define c99_nexttoward nexttoward
373# define c99_remainder remainder
374# define c99_remquo remquo
375# define c99_rint rint
376# define c99_round round
377# define c99_scalbn scalbn
5716d070 378/* We already define Perl_signbit in perl.h. */
f1498836
JH
379# ifdef HAS_SIGNBIT
380# define c99_signbit signbit
7965edec 381# endif
f1498836
JH
382# define c99_tgamma tgamma
383# define c99_trunc trunc
384#endif
03397f96 385
b8b5f83a
JH
386/* AIX xlc (__IBMC__) really doesn't have the following long double
387 * math interfaces (no __acoshl128 aka acoshl, etc.), see
388 * hints/aix.sh. These are in the -lc128 but fail to be found
389 * during dynamic linking/loading.
390 *
391 * XXX1 Better Configure scans
392 * XXX2 Is this xlc version dependent? */
393#if defined(USE_LONG_DOUBLE) && defined(__IBMC__)
394# undef c99_acosh
395# undef c99_asinh
396# undef c99_atanh
397# undef c99_cbrt
398# undef c99_copysign
399# undef c99_exp2
400# undef c99_expm1
401# undef c99_fdim
402# undef c99_fma
403# undef c99_fmax
404# undef c99_fmin
405# undef c99_hypot
406# undef c99_ilogb
407# undef c99_lrint
408# undef c99_lround
409# undef c99_log1p
410# undef c99_log2
411# undef c99_logb
412# undef c99_nan
413# undef c99_nearbyint
414# undef c99_nextafter
415# undef c99_nexttoward
416# undef c99_remainder
417# undef c99_remquo
418# undef c99_rint
419# undef c99_round
420# undef c99_scalbn
421# undef c99_tgamma
422# undef c99_trunc
423#endif
424
1411f32b
TC
425/* The cc with NetBSD 8.0 and 9.0 claims to be a C11 hosted compiler,
426 * but doesn't define several functions required by C99, let alone C11.
427 * http://gnats.netbsd.org/53234
428 */
429#if defined(USE_LONG_DOUBLE) && defined(__NetBSD__) \
430 && !defined(NETBSD_HAVE_FIXED_LONG_DOUBLE_MATH)
431# undef c99_expm1
432# undef c99_lgamma
433# undef c99_log1p
434# undef c99_log2
435# undef c99_nexttoward
436# undef c99_remainder
437# undef c99_remquo
438# undef c99_tgamma
439#endif
440
f1498836
JH
441#ifndef isunordered
442# ifdef Perl_isnan
443# define isunordered(x, y) (Perl_isnan(x) || Perl_isnan(y))
444# elif defined(HAS_UNORDERED)
445# define isunordered(x, y) unordered(x, y)
2bf3fd6f 446# endif
f1498836 447#endif
2bf3fd6f 448
a0d9739d
JH
449/* XXX these isgreater/isnormal/isunordered macros definitions should
450 * be moved further in the file to be part of the emulations, so that
451 * platforms can e.g. #undef c99_isunordered and have it work like
452 * it does for the other interfaces. */
453
f1498836
JH
454#if !defined(isgreater) && defined(isunordered)
455# define isgreater(x, y) (!isunordered((x), (y)) && (x) > (y))
456# define isgreaterequal(x, y) (!isunordered((x), (y)) && (x) >= (y))
457# define isless(x, y) (!isunordered((x), (y)) && (x) < (y))
458# define islessequal(x, y) (!isunordered((x), (y)) && (x) <= (y))
459# define islessgreater(x, y) (!isunordered((x), (y)) && \
2bf3fd6f 460 ((x) > (y) || (y) > (x)))
f1498836 461#endif
2bf3fd6f 462
03397f96 463/* Check both the Configure symbol and the macro-ness (like C99 promises). */
f1498836
JH
464#if defined(HAS_FPCLASSIFY) && defined(fpclassify)
465# define c99_fpclassify fpclassify
466#endif
03397f96
JH
467/* Like isnormal(), the isfinite(), isinf(), and isnan() are also C99
468 and also (sizeof-arg-aware) macros, but they are already well taken
469 care of by Configure et al, and defined in perl.h as
470 Perl_isfinite(), Perl_isinf(), and Perl_isnan(). */
f1498836
JH
471#ifdef isnormal
472# define c99_isnormal isnormal
473#endif
474#ifdef isgreater /* canary for all the C99 is*<cmp>* macros. */
475# define c99_isgreater isgreater
476# define c99_isgreaterequal isgreaterequal
477# define c99_isless isless
478# define c99_islessequal islessequal
479# define c99_islessgreater islessgreater
480# define c99_isunordered isunordered
7965edec
JH
481#endif
482
d0e3c0f2
JH
483/* The Great Wall of Undef where according to the definedness of HAS_FOO symbols
484 * the corresponding c99_foo wrappers are undefined. This list doesn't include
485 * the isfoo() interfaces because they are either type-aware macros, or dealt
486 * separately, already in perl.h */
487
488#ifndef HAS_ACOSH
489# undef c99_acosh
490#endif
491#ifndef HAS_ASINH
492# undef c99_asinh
493#endif
494#ifndef HAS_ATANH
495# undef c99_atanh
496#endif
497#ifndef HAS_CBRT
498# undef c99_cbrt
499#endif
500#ifndef HAS_COPYSIGN
501# undef c99_copysign
502#endif
503#ifndef HAS_ERF
504# undef c99_erf
505#endif
506#ifndef HAS_ERFC
507# undef c99_erfc
508#endif
509#ifndef HAS_EXP2
510# undef c99_exp2
511#endif
512#ifndef HAS_EXPM1
513# undef c99_expm1
514#endif
515#ifndef HAS_FDIM
516# undef c99_fdim
517#endif
518#ifndef HAS_FMA
519# undef c99_fma
520#endif
521#ifndef HAS_FMAX
522# undef c99_fmax
523#endif
524#ifndef HAS_FMIN
525# undef c99_fmin
526#endif
527#ifndef HAS_FPCLASSIFY
528# undef c99_fpclassify
529#endif
530#ifndef HAS_HYPOT
531# undef c99_hypot
532#endif
533#ifndef HAS_ILOGB
534# undef c99_ilogb
535#endif
536#ifndef HAS_LGAMMA
537# undef c99_lgamma
538#endif
539#ifndef HAS_LOG1P
540# undef c99_log1p
541#endif
542#ifndef HAS_LOG2
543# undef c99_log2
544#endif
545#ifndef HAS_LOGB
546# undef c99_logb
547#endif
548#ifndef HAS_LRINT
549# undef c99_lrint
550#endif
551#ifndef HAS_LROUND
552# undef c99_lround
553#endif
554#ifndef HAS_NAN
555# undef c99_nan
556#endif
557#ifndef HAS_NEARBYINT
558# undef c99_nearbyint
559#endif
560#ifndef HAS_NEXTAFTER
561# undef c99_nextafter
562#endif
563#ifndef HAS_NEXTTOWARD
564# undef c99_nexttoward
565#endif
566#ifndef HAS_REMAINDER
567# undef c99_remainder
568#endif
569#ifndef HAS_REMQUO
570# undef c99_remquo
571#endif
572#ifndef HAS_RINT
573# undef c99_rint
574#endif
575#ifndef HAS_ROUND
576# undef c99_round
577#endif
578#ifndef HAS_SCALBN
579# undef c99_scalbn
580#endif
581#ifndef HAS_SIGNBIT
582# undef c99_signbit
583#endif
584#ifndef HAS_TGAMMA
585# undef c99_tgamma
586#endif
587#ifndef HAS_TRUNC
588# undef c99_trunc
589#endif
590
238ed136 591#ifdef _MSC_VER
39b5f1c4
JH
592
593/* Some APIs exist under Win32 with "underbar" names. */
594# undef c99_hypot
595# undef c99_logb
596# undef c99_nextafter
597# define c99_hypot _hypot
598# define c99_logb _logb
599# define c99_nextafter _nextafter
600
85c93440
JH
601# define bessel_j0 _j0
602# define bessel_j1 _j1
603# define bessel_jn _jn
604# define bessel_y0 _y0
605# define bessel_y1 _y1
606# define bessel_yn _yn
607
5716d070 608#endif
bfce4ab3 609
39b5f1c4 610/* The Bessel functions: BSD, SVID, XPG4, and POSIX. But not C99. */
05b4a618 611#if defined(HAS_J0) && !defined(bessel_j0)
5716d070
JH
612# if defined(USE_LONG_DOUBLE) && defined(HAS_J0L)
613# define bessel_j0 j0l
614# define bessel_j1 j1l
615# define bessel_jn jnl
616# define bessel_y0 y0l
617# define bessel_y1 y1l
618# define bessel_yn ynl
619# else
85c93440
JH
620# define bessel_j0 j0
621# define bessel_j1 j1
622# define bessel_jn jn
623# define bessel_y0 y0
624# define bessel_y1 y1
625# define bessel_yn yn
5716d070 626# endif
bfce4ab3
JH
627#endif
628
39b5f1c4 629/* Emulations for missing math APIs.
bfce4ab3
JH
630 *
631 * Keep in mind that the point of many of these functions is that
632 * they, if available, are supposed to give more precise/more
39b5f1c4
JH
633 * numerically stable results.
634 *
635 * See e.g. http://www.johndcook.com/math_h.html
636 */
637
39b5f1c4
JH
638#ifndef c99_acosh
639static NV my_acosh(NV x)
640{
641 return Perl_log(x + Perl_sqrt(x * x - 1));
642}
643# define c99_acosh my_acosh
644#endif
645
646#ifndef c99_asinh
647static NV my_asinh(NV x)
648{
649 return Perl_log(x + Perl_sqrt(x * x + 1));
650}
651# define c99_asinh my_asinh
652#endif
653
654#ifndef c99_atanh
655static NV my_atanh(NV x)
656{
657 return (Perl_log(1 + x) - Perl_log(1 - x)) / 2;
658}
659# define c99_atanh my_atanh
660#endif
661
662#ifndef c99_cbrt
663static NV my_cbrt(NV x)
664{
665 static const NV one_third = (NV)1.0/3;
666 return x >= 0.0 ? Perl_pow(x, one_third) : -Perl_pow(-x, one_third);
667}
668# define c99_cbrt my_cbrt
669#endif
670
671#ifndef c99_copysign
672static NV my_copysign(NV x, NV y)
673{
674 return y >= 0 ? (x < 0 ? -x : x) : (x < 0 ? x : -x);
675}
676# define c99_copysign my_copysign
677#endif
678
1ae51000 679/* XXX cosh (though c89) */
d5f4f26a 680
7895eac5
JH
681#ifndef c99_erf
682static NV my_erf(NV x)
683{
684 /* http://www.johndcook.com/cpp_erf.html -- public domain */
685 NV a1 = 0.254829592;
686 NV a2 = -0.284496736;
687 NV a3 = 1.421413741;
688 NV a4 = -1.453152027;
689 NV a5 = 1.061405429;
690 NV p = 0.3275911;
efc74307 691 NV t, y;
7895eac5
JH
692 int sign = x < 0 ? -1 : 1; /* Save the sign. */
693 x = PERL_ABS(x);
694
695 /* Abramowitz and Stegun formula 7.1.26 */
efc74307 696 t = 1.0 / (1.0 + p * x);
6347c79c 697 y = 1.0 - (((((a5*t + a4)*t) + a3)*t + a2)*t + a1) * t * Perl_exp(-x*x);
7895eac5
JH
698
699 return sign * y;
700}
701# define c99_erf my_erf
702#endif
703
ffbadafb
JH
704#ifndef c99_erfc
705static NV my_erfc(NV x) {
aed13ba6
JH
706 /* This is not necessarily numerically stable, but better than nothing. */
707 return 1.0 - c99_erf(x);
ffbadafb
JH
708}
709# define c99_erfc my_erfc
710#endif
d5f4f26a 711
39b5f1c4
JH
712#ifndef c99_exp2
713static NV my_exp2(NV x)
714{
715 return Perl_pow((NV)2.0, x);
716}
717# define c99_exp2 my_exp2
718#endif
719
720#ifndef c99_expm1
721static NV my_expm1(NV x)
722{
723 if (PERL_ABS(x) < 1e-5)
7895eac5 724 /* http://www.johndcook.com/cpp_expm1.html -- public domain.
2783359f 725 * Taylor series, the first four terms (the last term quartic). */
39b5f1c4 726 /* Probably not enough for long doubles. */
2783359f 727 return x * (1.0 + x * (1/2.0 + x * (1/6.0 + x/24.0)));
39b5f1c4
JH
728 else
729 return Perl_exp(x) - 1;
730}
731# define c99_expm1 my_expm1
732#endif
733
734#ifndef c99_fdim
735static NV my_fdim(NV x, NV y)
736{
effb4c81 737#ifdef NV_NAN
eaa53991 738 return (Perl_isnan(x) || Perl_isnan(y)) ? NV_NAN : (x > y ? x - y : 0);
effb4c81
JH
739#else
740 return (x > y ? x - y : 0);
741#endif
39b5f1c4
JH
742}
743# define c99_fdim my_fdim
744#endif
745
7678a27f
JH
746#ifndef c99_fma
747static NV my_fma(NV x, NV y, NV z)
748{
749 return (x * y) + z;
750}
751# define c99_fma my_fma
752#endif
753
39b5f1c4
JH
754#ifndef c99_fmax
755static NV my_fmax(NV x, NV y)
756{
effb4c81 757#ifdef NV_NAN
39b5f1c4
JH
758 if (Perl_isnan(x)) {
759 return Perl_isnan(y) ? NV_NAN : y;
760 } else if (Perl_isnan(y)) {
761 return x;
762 }
effb4c81 763#endif
39b5f1c4
JH
764 return x > y ? x : y;
765}
766# define c99_fmax my_fmax
767#endif
768
769#ifndef c99_fmin
770static NV my_fmin(NV x, NV y)
771{
effb4c81 772#ifdef NV_NAN
39b5f1c4
JH
773 if (Perl_isnan(x)) {
774 return Perl_isnan(y) ? NV_NAN : y;
775 } else if (Perl_isnan(y)) {
776 return x;
777 }
effb4c81 778#endif
39b5f1c4
JH
779 return x < y ? x : y;
780}
781# define c99_fmin my_fmin
782#endif
783
26e0f0d3
JH
784#ifndef c99_fpclassify
785
ea464252 786static IV my_fpclassify(NV x)
935e3c48 787{
c3607571 788#ifdef Perl_fp_class_inf
935e3c48
JH
789 if (Perl_fp_class_inf(x)) return FP_INFINITE;
790 if (Perl_fp_class_nan(x)) return FP_NAN;
791 if (Perl_fp_class_norm(x)) return FP_NORMAL;
792 if (Perl_fp_class_denorm(x)) return FP_SUBNORMAL;
793 if (Perl_fp_class_zero(x)) return FP_ZERO;
935e3c48
JH
794# define c99_fpclassify my_fpclassify
795#endif
c3607571 796 return -1;
935e3c48 797}
935e3c48 798
26e0f0d3
JH
799#endif
800
39b5f1c4
JH
801#ifndef c99_hypot
802static NV my_hypot(NV x, NV y)
803{
7bbf2c9b
JH
804 /* http://en.wikipedia.org/wiki/Hypot */
805 NV t;
806 x = PERL_ABS(x); /* Take absolute values. */
807 if (y == 0)
808 return x;
effb4c81 809#ifdef NV_INF
7bbf2c9b
JH
810 if (Perl_isnan(y))
811 return NV_INF;
effb4c81 812#endif
7bbf2c9b
JH
813 y = PERL_ABS(y);
814 if (x < y) { /* Swap so that y is less. */
815 t = x;
816 x = y;
817 y = t;
39b5f1c4 818 }
7bbf2c9b 819 t = y / x;
6347c79c 820 return x * Perl_sqrt(1.0 + t * t);
39b5f1c4
JH
821}
822# define c99_hypot my_hypot
823#endif
824
825#ifndef c99_ilogb
826static IV my_ilogb(NV x)
827{
828 return (IV)(Perl_log(x) * M_LOG2E);
829}
830# define c99_ilogb my_ilogb
831#endif
832
8e65ef33
JH
833/* tgamma and lgamma emulations based on
834 * http://www.johndcook.com/cpp_gamma.html,
2e9cdb62
JH
835 * code placed in public domain.
836 *
837 * Note that these implementations (neither the johndcook originals
838 * nor these) do NOT set the global signgam variable. This is not
839 * necessarily a bad thing. */
840
8e65ef33
JH
841/* Note that the tgamma() and lgamma() implementations
842 * here depend on each other. */
256fef93 843
dc7cecfb 844#if !defined(HAS_TGAMMA) || !defined(c99_tgamma)
2e9cdb62 845static NV my_tgamma(NV x);
256fef93 846# define c99_tgamma my_tgamma
dc7cecfb 847# define USE_MY_TGAMMA
256fef93 848#endif
dc7cecfb 849#if !defined(HAS_LGAMMA) || !defined(c99_lgamma)
2e9cdb62 850static NV my_lgamma(NV x);
256fef93 851# define c99_lgamma my_lgamma
dc7cecfb 852# define USE_MY_LGAMMA
2e9cdb62
JH
853#endif
854
dc7cecfb 855#ifdef USE_MY_TGAMMA
2e9cdb62
JH
856static NV my_tgamma(NV x)
857{
f5802bf0 858 const NV gamma = 0.577215664901532860606512090; /* Euler's gamma constant. */
effb4c81 859#ifdef NV_NAN
2e9cdb62
JH
860 if (Perl_isnan(x) || x < 0.0)
861 return NV_NAN;
effb4c81
JH
862#endif
863#ifdef NV_INF
2e9cdb62 864 if (x == 0.0 || x == NV_INF)
98492e81 865#ifdef DOUBLE_IS_IEEE_FORMAT
2e9cdb62 866 return x == -0.0 ? -NV_INF : NV_INF;
98492e81
JH
867#else
868 return NV_INF;
869#endif
effb4c81 870#endif
2e9cdb62
JH
871
872 /* The function domain is split into three intervals:
873 * (0, 0.001), [0.001, 12), and (12, infinity) */
874
875 /* First interval: (0, 0.001)
f5802bf0 876 * For small values, 1/tgamma(x) has power series x + gamma x^2,
2e9cdb62
JH
877 * so in this range, 1/tgamma(x) = x + gamma x^2 with error on the order of x^3.
878 * The relative error over this interval is less than 6e-7. */
879 if (x < 0.001)
880 return 1.0 / (x * (1.0 + gamma * x));
881
882 /* Second interval: [0.001, 12) */
883 if (x < 12.0) {
884 double y = x; /* Working copy. */
885 int n = 0;
886 /* Numerator coefficients for approximation over the interval (1,2) */
887 static const NV p[] = {
888 -1.71618513886549492533811E+0,
889 2.47656508055759199108314E+1,
890 -3.79804256470945635097577E+2,
891 6.29331155312818442661052E+2,
892 8.66966202790413211295064E+2,
893 -3.14512729688483675254357E+4,
894 -3.61444134186911729807069E+4,
895 6.64561438202405440627855E+4
896 };
897 /* Denominator coefficients for approximation over the interval (1, 2) */
898 static const NV q[] = {
899 -3.08402300119738975254353E+1,
900 3.15350626979604161529144E+2,
901 -1.01515636749021914166146E+3,
902 -3.10777167157231109440444E+3,
903 2.25381184209801510330112E+4,
904 4.75584627752788110767815E+3,
905 -1.34659959864969306392456E+5,
906 -1.15132259675553483497211E+5
907 };
908 NV num = 0.0;
909 NV den = 1.0;
910 NV z;
911 NV result;
912 int i;
913
914 if (x < 1.0)
915 y += 1.0;
916 else {
5306a04c 917 n = (int)Perl_floor(y) - 1;
2e9cdb62
JH
918 y -= n;
919 }
920 z = y - 1;
921 for (i = 0; i < 8; i++) {
922 num = (num + p[i]) * z;
923 den = den * z + q[i];
924 }
925 result = num / den + 1.0;
926
927 if (x < 1.0) {
928 /* Use the identity tgamma(z) = tgamma(z+1)/z
929 * The variable "result" now holds tgamma of the original y + 1
930 * Thus we use y - 1 to get back the original y. */
931 result /= (y - 1.0);
932 }
933 else {
934 /* Use the identity tgamma(z+n) = z*(z+1)* ... *(z+n-1)*tgamma(z) */
935 for (i = 0; i < n; i++)
936 result *= y++;
937 }
938
939 return result;
940 }
941
effb4c81 942#ifdef NV_INF
2e9cdb62 943 /* Third interval: [12, +Inf) */
ec7c51d0
JH
944#if LDBL_MANT_DIG == 113 /* IEEE quad prec */
945 if (x > 1755.548) {
2e9cdb62
JH
946 return NV_INF;
947 }
ec7c51d0
JH
948#else
949 if (x > 171.624) {
950 return NV_INF;
951 }
952#endif
effb4c81 953#endif
2e9cdb62 954
256fef93 955 return Perl_exp(c99_lgamma(x));
2e9cdb62 956}
2e9cdb62
JH
957#endif
958
dc7cecfb 959#ifdef USE_MY_LGAMMA
2e9cdb62
JH
960static NV my_lgamma(NV x)
961{
effb4c81 962#ifdef NV_NAN
2e9cdb62
JH
963 if (Perl_isnan(x))
964 return NV_NAN;
effb4c81
JH
965#endif
966#ifdef NV_INF
2e9cdb62
JH
967 if (x <= 0 || x == NV_INF)
968 return NV_INF;
effb4c81 969#endif
2e9cdb62
JH
970 if (x == 1.0 || x == 2.0)
971 return 0;
972 if (x < 12.0)
256fef93 973 return Perl_log(PERL_ABS(c99_tgamma(x)));
f5802bf0
JH
974 /* Abramowitz and Stegun 6.1.41
975 * Asymptotic series should be good to at least 11 or 12 figures
976 * For error analysis, see Whittiker and Watson
977 * A Course in Modern Analysis (1927), page 252 */
2e9cdb62
JH
978 {
979 static const NV c[8] = {
980 1.0/12.0,
981 -1.0/360.0,
982 1.0/1260.0,
983 -1.0/1680.0,
984 1.0/1188.0,
985 -691.0/360360.0,
986 1.0/156.0,
987 -3617.0/122400.0
988 };
989 NV z = 1.0 / (x * x);
990 NV sum = c[7];
991 static const NV half_log_of_two_pi =
992 0.91893853320467274178032973640562;
993 NV series;
994 int i;
995 for (i = 6; i >= 0; i--) {
996 sum *= z;
997 sum += c[i];
998 }
999 series = sum / x;
1000 return (x - 0.5) * Perl_log(x) - x + half_log_of_two_pi + series;
1001 }
1002}
2e9cdb62 1003#endif
d5f4f26a 1004
39b5f1c4
JH
1005#ifndef c99_log1p
1006static NV my_log1p(NV x)
1007{
7895eac5 1008 /* http://www.johndcook.com/cpp_log_one_plus_x.html -- public domain.
2783359f 1009 * Taylor series, the first four terms (the last term quartic). */
effb4c81 1010#ifdef NV_NAN
3ae4cd6c 1011 if (x < -1.0)
731a2bdb 1012 return NV_NAN;
effb4c81
JH
1013#endif
1014#ifdef NV_INF
3ae4cd6c
JH
1015 if (x == -1.0)
1016 return -NV_INF;
effb4c81 1017#endif
39b5f1c4
JH
1018 if (PERL_ABS(x) > 1e-4)
1019 return Perl_log(1.0 + x);
1020 else
1021 /* Probably not enough for long doubles. */
2783359f 1022 return x * (1.0 + x * (-1/2.0 + x * (1/3.0 - x/4.0)));
39b5f1c4
JH
1023}
1024# define c99_log1p my_log1p
1025#endif
1026
1027#ifndef c99_log2
1028static NV my_log2(NV x)
1029{
1030 return Perl_log(x) * M_LOG2E;
1031}
1032# define c99_log2 my_log2
1033#endif
1034
d5f4f26a
JH
1035/* XXX nextafter */
1036
1037/* XXX nexttoward */
1038
1039static int my_fegetround()
1040{
1041#ifdef HAS_FEGETROUND
1042 return fegetround();
e0939537
JH
1043#elif defined(HAS_FPGETROUND)
1044 switch (fpgetround()) {
e0939537
JH
1045 case FP_RN: return FE_TONEAREST;
1046 case FP_RZ: return FE_TOWARDZERO;
1047 case FP_RM: return FE_DOWNWARD;
cc639810 1048 case FP_RP: return FE_UPWARD;
9d491117 1049 default: return -1;
e0939537 1050 }
c35bb41d
JH
1051#elif defined(FLT_ROUNDS)
1052 switch (FLT_ROUNDS) {
c35bb41d 1053 case 0: return FE_TOWARDZERO;
ebac59ac
JH
1054 case 1: return FE_TONEAREST;
1055 case 2: return FE_UPWARD;
1056 case 3: return FE_DOWNWARD;
c35bb41d
JH
1057 default: return -1;
1058 }
877206df
JH
1059#elif defined(__osf__) /* Tru64 */
1060 switch (read_rnd()) {
1061 case FP_RND_RN: return FE_TONEAREST;
1062 case FP_RND_RZ: return FE_TOWARDZERO;
1063 case FP_RND_RM: return FE_DOWNWARD;
1064 case FP_RND_RP: return FE_UPWARD;
1065 default: return -1;
1066 }
d5f4f26a
JH
1067#else
1068 return -1;
1069#endif
1070}
1071
c4125715
JH
1072/* Toward closest integer. */
1073#define MY_ROUND_NEAREST(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x) - 0.5)))
1074
1075/* Toward zero. */
1076#define MY_ROUND_TRUNC(x) ((NV)((IV)(x)))
1077
e0939537 1078/* Toward minus infinity. */
c4125715 1079#define MY_ROUND_DOWN(x) ((NV)((IV)((x) >= 0.0 ? (x) : (x) - 0.5)))
e0939537
JH
1080
1081/* Toward plus infinity. */
c4125715 1082#define MY_ROUND_UP(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x))))
e0939537 1083
5a4dabf8 1084#if (!defined(c99_nearbyint) || !defined(c99_lrint)) && defined(FE_TONEAREST)
d5f4f26a
JH
1085static NV my_rint(NV x)
1086{
1087#ifdef FE_TONEAREST
1088 switch (my_fegetround()) {
c4125715
JH
1089 case FE_TONEAREST: return MY_ROUND_NEAREST(x);
1090 case FE_TOWARDZERO: return MY_ROUND_TRUNC(x);
1091 case FE_DOWNWARD: return MY_ROUND_DOWN(x);
1092 case FE_UPWARD: return MY_ROUND_UP(x);
effb4c81 1093 default: break;
e0939537
JH
1094 }
1095#elif defined(HAS_FPGETROUND)
1096 switch (fpgetround()) {
c4125715
JH
1097 case FP_RN: return MY_ROUND_NEAREST(x);
1098 case FP_RZ: return MY_ROUND_TRUNC(x);
1099 case FP_RM: return MY_ROUND_DOWN(x);
1100 case FE_RP: return MY_ROUND_UP(x);
effb4c81 1101 default: break;
d5f4f26a 1102 }
d5f4f26a 1103#endif
effb4c81 1104 not_here("rint");
4d770d00 1105 NOT_REACHED; /* NOTREACHED */
d5f4f26a 1106}
5a4dabf8 1107#endif
d5f4f26a
JH
1108
1109/* XXX nearbyint() and rint() are not really identical -- but the difference
1110 * is messy: nearbyint is defined NOT to raise FE_INEXACT floating point
1111 * exceptions, while rint() is defined to MAYBE raise them. At the moment
1112 * Perl is blissfully unaware of such fine detail of floating point. */
1113#ifndef c99_nearbyint
1114# ifdef FE_TONEAREST
1115# define c99_nearbyrint my_rint
1116# endif
1117#endif
1118
1119#ifndef c99_lrint
1120# ifdef FE_TONEAREST
c40e90c4 1121static IV my_lrint(NV x)
d5f4f26a
JH
1122{
1123 return (IV)my_rint(x);
1124}
1125# define c99_lrint my_lrint
1126# endif
1127#endif
1128
9e010b89
JH
1129#ifndef c99_lround
1130static IV my_lround(NV x)
1131{
c63c00af 1132 return (IV)MY_ROUND_NEAREST(x);
9e010b89
JH
1133}
1134# define c99_lround my_lround
1135#endif
1136
d5f4f26a
JH
1137/* XXX remainder */
1138
1139/* XXX remquo */
1140
1141#ifndef c99_rint
1142# ifdef FE_TONEAREST
1143# define c99_rint my_rint
1144# endif
1145#endif
1146
39b5f1c4
JH
1147#ifndef c99_round
1148static NV my_round(NV x)
1149{
c4125715 1150 return MY_ROUND_NEAREST(x);
39b5f1c4
JH
1151}
1152# define c99_round my_round
1153#endif
1154
1155#ifndef c99_scalbn
93ddb856 1156# if defined(Perl_ldexp) && FLT_RADIX == 2
ea464252 1157static NV my_scalbn(NV x, int y)
39b5f1c4
JH
1158{
1159 return Perl_ldexp(x, y);
1160}
1161# define c99_scalbn my_scalbn
1162# endif
1163#endif
1164
1ae51000 1165/* XXX sinh (though c89) */
39b5f1c4 1166
2e9cdb62 1167/* tgamma -- see lgamma */
bfce4ab3 1168
1ae51000 1169/* XXX tanh (though c89) */
d5f4f26a
JH
1170
1171#ifndef c99_trunc
1172static NV my_trunc(NV x)
1173{
c4125715 1174 return MY_ROUND_TRUNC(x);
d5f4f26a
JH
1175}
1176# define c99_trunc my_trunc
1177#endif
1178
effb4c81
JH
1179#ifdef NV_NAN
1180
07bb61ac
JH
1181#undef NV_PAYLOAD_DEBUG
1182
1183/* NOTE: the NaN payload API implementation is hand-rolled, since the
1184 * APIs are only proposed ones as of June 2015, so very few, if any,
1185 * platforms have implementations yet, so HAS_SETPAYLOAD and such are
1186 * unlikely to be helpful.
1187 *
1188 * XXX - if the core numification wants to actually generate
1189 * the nan payload in "nan(123)", and maybe "nans(456)", for
1190 * signaling payload", this needs to be moved to e.g. numeric.c
1191 * (look for grok_infnan)
1192 *
1193 * Conversely, if the core stringification wants the nan payload
1194 * and/or the nan quiet/signaling distinction, S_getpayload()
1195 * from this file needs to be moved, to e.g. sv.c (look for S_infnan_2pv),
1196 * and the (trivial) functionality of issignaling() copied
1197 * (for generating "NaNS", or maybe even "NaNQ") -- or maybe there
1198 * are too many formatting parameters for simple stringification?
1199 */
1200
1201/* While it might make sense for the payload to be UV or IV,
1202 * to avoid conversion loss, the proposed ISO interfaces use
1203 * a floating point input, which is then truncated to integer,
1204 * and only the integer part being used. This is workable,
1205 * except for: (1) the conversion loss (2) suboptimal for
1206 * 32-bit integer platforms. A workaround API for (2) and
1207 * in general for bit-honesty would be an array of integers
1208 * as the payload... but the proposed C API does nothing of
1209 * the kind. */
1210#if NVSIZE == UVSIZE
1211# define NV_PAYLOAD_TYPE UV
1212#else
1213# define NV_PAYLOAD_TYPE NV
1214#endif
1215
d80a6052 1216#if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE)
555e2b18
FC
1217# define NV_PAYLOAD_SIZEOF_ASSERT(a) \
1218 STATIC_ASSERT_STMT(sizeof(a) == NVSIZE / 2)
07bb61ac 1219#else
555e2b18
FC
1220# define NV_PAYLOAD_SIZEOF_ASSERT(a) \
1221 STATIC_ASSERT_STMT(sizeof(a) == NVSIZE)
07bb61ac
JH
1222#endif
1223
1224static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling)
1225{
1226 dTHX;
1227 static const U8 m[] = { NV_NAN_PAYLOAD_MASK };
1228 static const U8 p[] = { NV_NAN_PAYLOAD_PERM };
1229 UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 };
1230 int i;
1231 NV_PAYLOAD_SIZEOF_ASSERT(m);
1232 NV_PAYLOAD_SIZEOF_ASSERT(p);
1233 *nvp = NV_NAN;
1234 /* Divide the input into the array in "base unsigned integer" in
1235 * little-endian order. Note that the integer might be smaller than
1236 * an NV (if UV is U32, for example). */
1237#if NVSIZE == UVSIZE
1238 a[0] = payload; /* The trivial case. */
1239#else
1240 {
1241 NV t1 = c99_trunc(payload); /* towards zero (drop fractional) */
1242#ifdef NV_PAYLOAD_DEBUG
147e3846 1243 Perl_warn(aTHX_ "t1 = %" NVgf " (payload %" NVgf ")\n", t1, payload);
07bb61ac
JH
1244#endif
1245 if (t1 <= UV_MAX) {
1246 a[0] = (UV)t1; /* Fast path, also avoids rounding errors (right?) */
1247 } else {
1248 /* UVSIZE < NVSIZE or payload > UV_MAX.
1249 *
1250 * This may happen for example if:
1251 * (1) UVSIZE == 32 and common 64-bit double NV
1252 * (32-bit system not using -Duse64bitint)
1253 * (2) UVSIZE == 64 and the x86-style 80-bit long double NV
1254 * (note that here the room for payload is actually the 64 bits)
1255 * (3) UVSIZE == 64 and the 128-bit IEEE 764 quadruple NV
1256 * (112 bits in mantissa, 111 bits room for payload)
1257 *
1258 * NOTE: this is very sensitive to correctly functioning
1259 * fmod()/fmodl(), and correct casting of big-unsigned-integer to NV.
1260 * If these don't work right, especially the low order bits
1261 * are in danger. For example Solaris and AIX seem to have issues
1262 * here, especially if using 32-bit UVs. */
1263 NV t2;
1264 for (i = 0, t2 = t1; i < (int)C_ARRAY_LENGTH(a); i++) {
1265 a[i] = (UV)Perl_fmod(t2, (NV)UV_MAX);
1266 t2 = Perl_floor(t2 / (NV)UV_MAX);
1267 }
1268 }
1269 }
1270#endif
1271#ifdef NV_PAYLOAD_DEBUG
1272 for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) {
147e3846 1273 Perl_warn(aTHX_ "a[%d] = 0x%" UVxf "\n", i, a[i]);
07bb61ac
JH
1274 }
1275#endif
1276 for (i = 0; i < (int)sizeof(p); i++) {
1277 if (m[i] && p[i] < sizeof(p)) {
1278 U8 s = (p[i] % UVSIZE) << 3;
1279 UV u = a[p[i] / UVSIZE] & ((UV)0xFF << s);
1280 U8 b = (U8)((u >> s) & m[i]);
1281 ((U8 *)(nvp))[i] &= ~m[i]; /* For NaNs with non-zero payload bits. */
1282 ((U8 *)(nvp))[i] |= b;
1283#ifdef NV_PAYLOAD_DEBUG
147e3846
KW
1284 Perl_warn(aTHX_
1285 "set p[%2d] = %02x (i = %d, m = %02x, s = %2d, b = %02x, u = %08"
1286 UVxf ")\n", i, ((U8 *)(nvp))[i], i, m[i], s, b, u);
07bb61ac
JH
1287#endif
1288 a[p[i] / UVSIZE] &= ~u;
1289 }
1290 }
1291 if (signaling) {
1292 NV_NAN_SET_SIGNALING(nvp);
1293 }
1294#ifdef USE_LONG_DOUBLE
1295# if LONG_DOUBLEKIND == 3 || LONG_DOUBLEKIND == 4
2f125fcc 1296# if LONG_DOUBLESIZE > 10
07bb61ac 1297 memset((char *)nvp + 10, '\0', LONG_DOUBLESIZE - 10); /* x86 long double */
2f125fcc 1298# endif
07bb61ac
JH
1299# endif
1300#endif
1301 for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) {
1302 if (a[i]) {
147e3846 1303 Perl_warn(aTHX_ "payload lost bits (%" UVxf ")", a[i]);
07bb61ac
JH
1304 break;
1305 }
1306 }
1307#ifdef NV_PAYLOAD_DEBUG
1308 for (i = 0; i < NVSIZE; i++) {
1309 PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(nvp))[i]);
1310 }
1311 PerlIO_printf(Perl_debug_log, "\n");
1312#endif
1313}
1314
1315static NV_PAYLOAD_TYPE S_getpayload(NV nv)
1316{
1317 dTHX;
1318 static const U8 m[] = { NV_NAN_PAYLOAD_MASK };
1319 static const U8 p[] = { NV_NAN_PAYLOAD_PERM };
1320 UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 };
1321 int i;
1322 NV payload;
1323 NV_PAYLOAD_SIZEOF_ASSERT(m);
1324 NV_PAYLOAD_SIZEOF_ASSERT(p);
1325 payload = 0;
1326 for (i = 0; i < (int)sizeof(p); i++) {
1327 if (m[i] && p[i] < NVSIZE) {
1328 U8 s = (p[i] % UVSIZE) << 3;
1329 a[p[i] / UVSIZE] |= (UV)(((U8 *)(&nv))[i] & m[i]) << s;
1330 }
1331 }
1332 for (i = (int)C_ARRAY_LENGTH(a) - 1; i >= 0; i--) {
1333#ifdef NV_PAYLOAD_DEBUG
147e3846 1334 Perl_warn(aTHX_ "a[%d] = %" UVxf "\n", i, a[i]);
07bb61ac 1335#endif
ef0a8475 1336 payload *= (NV) UV_MAX;
07bb61ac
JH
1337 payload += a[i];
1338 }
1339#ifdef NV_PAYLOAD_DEBUG
1340 for (i = 0; i < NVSIZE; i++) {
1341 PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(&nv))[i]);
1342 }
1343 PerlIO_printf(Perl_debug_log, "\n");
1344#endif
1345 return payload;
1346}
1347
effb4c81
JH
1348#endif /* #ifdef NV_NAN */
1349
3609ea0d 1350/* XXX This comment is just to make I_TERMIO and I_SGTTY visible to
a0d0e21e
LW
1351 metaconfig for future extension writers. We don't use them in POSIX.
1352 (This is really sneaky :-) --AD
1353*/
1354#if defined(I_TERMIOS)
1355#include <termios.h>
1356#endif
2304df62 1357#include <stdlib.h>
5518ecd4 1358#ifndef __ultrix__
2304df62 1359#include <string.h>
5518ecd4 1360#endif
2304df62 1361#include <sys/stat.h>
2304df62 1362#include <sys/types.h>
2304df62 1363#include <time.h>
6dead956 1364#ifdef I_UNISTD
1d2dff63 1365#include <unistd.h>
6dead956 1366#endif
71be2cbc
PP
1367#include <fcntl.h>
1368
e2465f50 1369#ifdef HAS_TZNAME
fb207d52 1370# if !defined(WIN32) && !defined(__CYGWIN__) && !defined(NETWARE) && !defined(__UWIN__)
e2465f50
JH
1371extern char *tzname[];
1372# endif
1373#else
fb207d52 1374#if !defined(WIN32) && !defined(__UWIN__) || (defined(__MINGW32__) && !defined(tzname))
e2465f50
JH
1375char *tzname[] = { "" , "" };
1376#endif
cb2479a8
JH
1377#endif
1378
6c418a22 1379#if defined(__VMS) && !defined(__POSIX_SOURCE)
294c8bc4
CB
1380
1381# include <utsname.h>
6c418a22 1382
6990d991 1383# undef mkfifo
6c418a22 1384# define mkfifo(a,b) (not_here("mkfifo"),-1)
6c418a22
PP
1385
1386 /* The POSIX notion of ttyname() is better served by getname() under VMS */
1387 static char ttnambuf[64];
1388# define ttyname(fd) (isatty(fd) > 0 ? getname(fd,ttnambuf,0) : NULL)
1389
6c418a22 1390#else
d308986b 1391#if defined (__CYGWIN__)
f89d6eaa
FE
1392# define tzname _tzname
1393#endif
2986a63f 1394#if defined (WIN32) || defined (NETWARE)
6990d991 1395# undef mkfifo
6dead956 1396# define mkfifo(a,b) not_here("mkfifo")
873ef191 1397# define ttyname(a) (char*)not_here("ttyname")
6dead956 1398# define sigset_t long
86200d5c 1399# define pid_t long
6dead956
GS
1400# ifdef _MSC_VER
1401# define mode_t short
1402# endif
62520c91
GS
1403# ifdef __MINGW32__
1404# define mode_t short
f6c6487a
GS
1405# ifndef tzset
1406# define tzset() not_here("tzset")
1407# endif
1408# ifndef _POSIX_OPEN_MAX
1409# define _POSIX_OPEN_MAX FOPEN_MAX /* XXX bogus ? */
1410# endif
62520c91 1411# endif
6dead956
GS
1412# define sigaction(a,b,c) not_here("sigaction")
1413# define sigpending(a) not_here("sigpending")
1414# define sigprocmask(a,b,c) not_here("sigprocmask")
1415# define sigsuspend(a) not_here("sigsuspend")
1416# define sigemptyset(a) not_here("sigemptyset")
1417# define sigaddset(a,b) not_here("sigaddset")
1418# define sigdelset(a,b) not_here("sigdelset")
1419# define sigfillset(a) not_here("sigfillset")
1420# define sigismember(a,b) not_here("sigismember")
2986a63f 1421#ifndef NETWARE
6e22d046
JH
1422# undef setuid
1423# undef setgid
2986a63f
JH
1424# define setuid(a) not_here("setuid")
1425# define setgid(a) not_here("setgid")
1426#endif /* NETWARE */
d172007e 1427#ifndef USE_LONG_DOUBLE
73e21afd 1428# define strtold(s1,s2) not_here("strtold")
d172007e 1429#endif /* USE_LONG_DOUBLE */
6dead956 1430#else
6990d991
JH
1431
1432# ifndef HAS_MKFIFO
b3599c2e 1433# if defined(OS2) || defined(__amigaos4__)
d6a255e6 1434# define mkfifo(a,b) not_here("mkfifo")
3609ea0d 1435# else /* !( defined OS2 ) */
d6a255e6
IZ
1436# ifndef mkfifo
1437# define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0))
1438# endif
6990d991
JH
1439# endif
1440# endif /* !HAS_MKFIFO */
1441
e37778c2
NC
1442# ifdef I_GRP
1443# include <grp.h>
1444# endif
1445# include <sys/times.h>
1446# ifdef HAS_UNAME
1447# include <sys/utsname.h>
6c418a22 1448# endif
ea34f6bd
AB
1449# ifndef __amigaos4__
1450# include <sys/wait.h>
1451# endif
6c418a22
PP
1452# ifdef I_UTIME
1453# include <utime.h>
1454# endif
2986a63f 1455#endif /* WIN32 || NETWARE */
6dead956 1456#endif /* __VMS */
2304df62
AD
1457
1458typedef int SysRet;
a0d0e21e 1459typedef long SysRetLong;
2304df62
AD
1460typedef sigset_t* POSIX__SigSet;
1461typedef HV* POSIX__SigAction;
69b5fd06 1462typedef int POSIX__SigNo;
ddc7c5c7 1463typedef int POSIX__Fd;
a0d0e21e
LW
1464#ifdef I_TERMIOS
1465typedef struct termios* POSIX__Termios;
1466#else /* Define termios types to int, and call not_here for the functions.*/
1467#define POSIX__Termios int
1468#define speed_t int
1469#define tcflag_t int
1470#define cc_t int
1471#define cfgetispeed(x) not_here("cfgetispeed")
1472#define cfgetospeed(x) not_here("cfgetospeed")
1473#define tcdrain(x) not_here("tcdrain")
1474#define tcflush(x,y) not_here("tcflush")
1475#define tcsendbreak(x,y) not_here("tcsendbreak")
1476#define cfsetispeed(x,y) not_here("cfsetispeed")
1477#define cfsetospeed(x,y) not_here("cfsetospeed")
1478#define ctermid(x) (char *) not_here("ctermid")
1479#define tcflow(x,y) not_here("tcflow")
1480#define tcgetattr(x,y) not_here("tcgetattr")
1481#define tcsetattr(x,y,z) not_here("tcsetattr")
1482#endif
1483
1484/* Possibly needed prototypes */
6e22d046 1485#ifndef WIN32
a2e65780 1486START_EXTERN_C
20ce7b12
GS
1487double strtod (const char *, char **);
1488long strtol (const char *, char **, int);
1489unsigned long strtoul (const char *, char **, int);
0ff7b9da
JH
1490#ifdef HAS_STRTOLD
1491long double strtold (const char *, char **);
1492#endif
a2e65780 1493END_EXTERN_C
6e22d046 1494#endif
a0d0e21e 1495
a0d0e21e
LW
1496#ifndef HAS_DIFFTIME
1497#ifndef difftime
1498#define difftime(a,b) not_here("difftime")
1499#endif
1500#endif
1501#ifndef HAS_FPATHCONF
3609ea0d 1502#define fpathconf(f,n) (SysRetLong) not_here("fpathconf")
a0d0e21e
LW
1503#endif
1504#ifndef HAS_MKTIME
1505#define mktime(a) not_here("mktime")
8990e307
LW
1506#endif
1507#ifndef HAS_NICE
1508#define nice(a) not_here("nice")
1509#endif
a0d0e21e 1510#ifndef HAS_PATHCONF
3609ea0d 1511#define pathconf(f,n) (SysRetLong) not_here("pathconf")
a0d0e21e
LW
1512#endif
1513#ifndef HAS_SYSCONF
3609ea0d 1514#define sysconf(n) (SysRetLong) not_here("sysconf")
a0d0e21e 1515#endif
8990e307
LW
1516#ifndef HAS_READLINK
1517#define readlink(a,b,c) not_here("readlink")
1518#endif
1519#ifndef HAS_SETPGID
1520#define setpgid(a,b) not_here("setpgid")
1521#endif
8990e307
LW
1522#ifndef HAS_SETSID
1523#define setsid() not_here("setsid")
1524#endif
a0d0e21e
LW
1525#ifndef HAS_STRCOLL
1526#define strcoll(s1,s2) not_here("strcoll")
1527#endif
a89d8a78
DH
1528#ifndef HAS_STRTOD
1529#define strtod(s1,s2) not_here("strtod")
1530#endif
0ff7b9da
JH
1531#ifndef HAS_STRTOLD
1532#define strtold(s1,s2) not_here("strtold")
1533#endif
a89d8a78
DH
1534#ifndef HAS_STRTOL
1535#define strtol(s1,s2,b) not_here("strtol")
1536#endif
1537#ifndef HAS_STRTOUL
1538#define strtoul(s1,s2,b) not_here("strtoul")
1539#endif
a0d0e21e
LW
1540#ifndef HAS_STRXFRM
1541#define strxfrm(s1,s2,n) not_here("strxfrm")
8990e307
LW
1542#endif
1543#ifndef HAS_TCGETPGRP
1544#define tcgetpgrp(a) not_here("tcgetpgrp")
1545#endif
1546#ifndef HAS_TCSETPGRP
1547#define tcsetpgrp(a,b) not_here("tcsetpgrp")
1548#endif
1549#ifndef HAS_TIMES
2986a63f 1550#ifndef NETWARE
8990e307 1551#define times(a) not_here("times")
2986a63f 1552#endif /* NETWARE */
8990e307
LW
1553#endif
1554#ifndef HAS_UNAME
1555#define uname(a) not_here("uname")
1556#endif
1557#ifndef HAS_WAITPID
1558#define waitpid(a,b,c) not_here("waitpid")
1559#endif
1560
d2c9cb53 1561#if ! defined(HAS_MBLEN) && ! defined(HAS_MBRLEN)
f5ed3ba7 1562# define mblen(a,b) not_here("mblen")
a0d0e21e 1563#endif
5a6637f0 1564#if ! defined(HAS_MBTOWC) && ! defined(HAS_MBRTOWC)
f5ed3ba7 1565# define mbtowc(pwc, s, n) not_here("mbtowc")
a0d0e21e 1566#endif
954418fb 1567#if ! defined(HAS_WCTOMB) && ! defined(HAS_WCRTOMB)
f5ed3ba7 1568# define wctomb(s, wchar) not_here("wctomb")
a0d0e21e
LW
1569#endif
1570#if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB)
1571/* If we don't have these functions, then we wouldn't have gotten a typedef
1572 for wchar_t, the wide character type. Defining wchar_t allows the
1573 functions referencing it to compile. Its actual type is then meaningless,
1574 since without the above functions, all sections using it end up calling
1575 not_here() and croak. --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */
1576#ifndef wchar_t
1577#define wchar_t char
1578#endif
1579#endif
1580
954418fb 1581#if ! defined(HAS_LOCALECONV) && ! defined(HAS_LOCALECONV_L)
3f3bcbfc
KW
1582# define localeconv() not_here("localeconv")
1583#else
2f0945cb
NC
1584struct lconv_offset {
1585 const char *name;
1586 size_t offset;
1587};
1588
0b057af7 1589static const struct lconv_offset lconv_strings[] = {
03ceeedf 1590#ifdef USE_LOCALE_NUMERIC
3800c318
JH
1591 {"decimal_point", STRUCT_OFFSET(struct lconv, decimal_point)},
1592 {"thousands_sep", STRUCT_OFFSET(struct lconv, thousands_sep)},
03ceeedf 1593# ifndef NO_LOCALECONV_GROUPING
3800c318 1594 {"grouping", STRUCT_OFFSET(struct lconv, grouping)},
03ceeedf 1595# endif
2f0945cb 1596#endif
03ceeedf 1597#ifdef USE_LOCALE_MONETARY
3800c318
JH
1598 {"int_curr_symbol", STRUCT_OFFSET(struct lconv, int_curr_symbol)},
1599 {"currency_symbol", STRUCT_OFFSET(struct lconv, currency_symbol)},
1600 {"mon_decimal_point", STRUCT_OFFSET(struct lconv, mon_decimal_point)},
03ceeedf 1601# ifndef NO_LOCALECONV_MON_THOUSANDS_SEP
3800c318 1602 {"mon_thousands_sep", STRUCT_OFFSET(struct lconv, mon_thousands_sep)},
03ceeedf
KW
1603# endif
1604# ifndef NO_LOCALECONV_MON_GROUPING
3800c318 1605 {"mon_grouping", STRUCT_OFFSET(struct lconv, mon_grouping)},
03ceeedf 1606# endif
3800c318
JH
1607 {"positive_sign", STRUCT_OFFSET(struct lconv, positive_sign)},
1608 {"negative_sign", STRUCT_OFFSET(struct lconv, negative_sign)},
03ceeedf 1609#endif
2f0945cb
NC
1610 {NULL, 0}
1611};
1612
c1284011
KW
1613#ifdef USE_LOCALE_NUMERIC
1614
1615/* The Linux man pages say these are the field names for the structure
1616 * components that are LC_NUMERIC; the rest being LC_MONETARY */
93e25eee
KW
1617# define isLC_NUMERIC_STRING(name) ( strEQ(name, "decimal_point") \
1618 || strEQ(name, "thousands_sep") \
c1284011
KW
1619 \
1620 /* There should be no harm done \
1621 * checking for this, even if \
1622 * NO_LOCALECONV_GROUPING */ \
f33b12f3 1623 || strEQ(name, "grouping"))
c1284011
KW
1624#else
1625# define isLC_NUMERIC_STRING(name) (0)
1626#endif
1627
0b057af7 1628static const struct lconv_offset lconv_integers[] = {
03ceeedf 1629#ifdef USE_LOCALE_MONETARY
3800c318
JH
1630 {"int_frac_digits", STRUCT_OFFSET(struct lconv, int_frac_digits)},
1631 {"frac_digits", STRUCT_OFFSET(struct lconv, frac_digits)},
1632 {"p_cs_precedes", STRUCT_OFFSET(struct lconv, p_cs_precedes)},
1633 {"p_sep_by_space", STRUCT_OFFSET(struct lconv, p_sep_by_space)},
1634 {"n_cs_precedes", STRUCT_OFFSET(struct lconv, n_cs_precedes)},
1635 {"n_sep_by_space", STRUCT_OFFSET(struct lconv, n_sep_by_space)},
1636 {"p_sign_posn", STRUCT_OFFSET(struct lconv, p_sign_posn)},
1637 {"n_sign_posn", STRUCT_OFFSET(struct lconv, n_sign_posn)},
b15c1b56
AF
1638#ifdef HAS_LC_MONETARY_2008
1639 {"int_p_cs_precedes", STRUCT_OFFSET(struct lconv, int_p_cs_precedes)},
1640 {"int_p_sep_by_space", STRUCT_OFFSET(struct lconv, int_p_sep_by_space)},
1641 {"int_n_cs_precedes", STRUCT_OFFSET(struct lconv, int_n_cs_precedes)},
1642 {"int_n_sep_by_space", STRUCT_OFFSET(struct lconv, int_n_sep_by_space)},
1643 {"int_p_sign_posn", STRUCT_OFFSET(struct lconv, int_p_sign_posn)},
1644 {"int_n_sign_posn", STRUCT_OFFSET(struct lconv, int_n_sign_posn)},
1645#endif
03ceeedf 1646#endif
2f0945cb
NC
1647 {NULL, 0}
1648};
1649
3f3bcbfc 1650#endif /* HAS_LOCALECONV */
a0d0e21e 1651
172ea7c8 1652#ifdef HAS_LONG_DOUBLE
53796371 1653# if LONG_DOUBLESIZE > NVSIZE
172ea7c8
JH
1654# undef HAS_LONG_DOUBLE /* XXX until we figure out how to use them */
1655# endif
1656#endif
1657
1658#ifndef HAS_LONG_DOUBLE
1659#ifdef LDBL_MAX
1660#undef LDBL_MAX
1661#endif
1662#ifdef LDBL_MIN
1663#undef LDBL_MIN
1664#endif
1665#ifdef LDBL_EPSILON
1666#undef LDBL_EPSILON
1667#endif
1668#endif
1669
ec193bec
JH
1670/* Background: in most systems the low byte of the wait status
1671 * is the signal (the lowest 7 bits) and the coredump flag is
1672 * the eight bit, and the second lowest byte is the exit status.
1673 * BeOS bucks the trend and has the bytes in different order.
1674 * See beos/beos.c for how the reality is bent even in BeOS
1675 * to follow the traditional. However, to make the POSIX
1676 * wait W*() macros to work in BeOS, we need to unbend the
1677 * reality back in place. --jhi */
17028706
IW
1678/* In actual fact the code below is to blame here. Perl has an internal
1679 * representation of the exit status ($?), which it re-composes from the
1680 * OS's representation using the W*() POSIX macros. The code below
1681 * incorrectly uses the W*() macros on the internal representation,
1682 * which fails for OSs that have a different representation (namely BeOS
1683 * and Haiku). WMUNGE() is a hack that converts the internal
1684 * representation into the OS specific one, so that the W*() macros work
1685 * as expected. The better solution would be not to use the W*() macros
1686 * in the first place, though. -- Ingo Weinhold
1687 */
b6c36746 1688#if defined(__HAIKU__)
ec193bec
JH
1689# define WMUNGE(x) (((x) & 0xFF00) >> 8 | ((x) & 0x00FF) << 8)
1690#else
1691# define WMUNGE(x) (x)
1692#endif
1693
8990e307 1694static int
4b48cf39 1695not_here(const char *s)
8990e307
LW
1696{
1697 croak("POSIX::%s not implemented on this architecture", s);
1698 return -1;
1699}
463ee0b2 1700
1cb0fb50 1701#include "const-c.inc"
a290f238 1702
1dfe7606 1703static void
40b7a5f5 1704restore_sigmask(pTHX_ SV *osset_sv)
1dfe7606 1705{
7feb700b
JH
1706 /* Fortunately, restoring the signal mask can't fail, because
1707 * there's nothing we can do about it if it does -- we're not
1708 * supposed to return -1 from sigaction unless the disposition
1709 * was unaffected.
1710 */
30b42e09 1711#if !(defined(__amigaos4__) && defined(__NEWLIB__))
7feb700b
JH
1712 sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv );
1713 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
30b42e09 1714#endif
1dfe7606 1715}
1716
a2261f90
NC
1717static void *
1718allocate_struct(pTHX_ SV *rv, const STRLEN size, const char *packname) {
1719 SV *const t = newSVrv(rv, packname);
1720 void *const p = sv_grow(t, size + 1);
1721
706d6f2a
DM
1722 /* Ensure at least one use of not_here() to avoid "defined but not
1723 * used" warning. This is not at all related to allocate_struct(); I
1724 * just needed somewhere to dump it - DAPM */
1725 if (0) { not_here(""); }
1726
a2261f90
NC
1727 SvCUR_set(t, size);
1728 SvPOK_on(t);
1729 return p;
1730}
1731
81ab4c44
SH
1732#ifdef WIN32
1733
1734/*
1735 * (1) The CRT maintains its own copy of the environment, separate from
1736 * the Win32API copy.
1737 *
1738 * (2) CRT getenv() retrieves from this copy. CRT putenv() updates this
1739 * copy, and then calls SetEnvironmentVariableA() to update the Win32API
1740 * copy.
1741 *
1742 * (3) win32_getenv() and win32_putenv() call GetEnvironmentVariableA() and
1743 * SetEnvironmentVariableA() directly, bypassing the CRT copy of the
1744 * environment.
1745 *
1746 * (4) The CRT strftime() "%Z" implementation calls __tzset(). That
1747 * calls CRT tzset(), but only the first time it is called, and in turn
1748 * that uses CRT getenv("TZ") to retrieve the timezone info from the CRT
1749 * local copy of the environment and hence gets the original setting as
1750 * perl never updates the CRT copy when assigning to $ENV{TZ}.
1751 *
1752 * Therefore, we need to retrieve the value of $ENV{TZ} and call CRT
1753 * putenv() to update the CRT copy of the environment (if it is different)
1754 * whenever we're about to call tzset().
1755 *
1756 * In addition to all that, when perl is built with PERL_IMPLICIT_SYS
1757 * defined:
1758 *
1759 * (a) Each interpreter has its own copy of the environment inside the
1760 * perlhost structure. That allows applications that host multiple
1761 * independent Perl interpreters to isolate environment changes from
1762 * each other. (This is similar to how the perlhost mechanism keeps a
1763 * separate working directory for each Perl interpreter, so that calling
1764 * chdir() will not affect other interpreters.)
1765 *
1766 * (b) Only the first Perl interpreter instantiated within a process will
1767 * "write through" environment changes to the process environment.
1768 *
1769 * (c) Even the primary Perl interpreter won't update the CRT copy of the
a3815e44 1770 * environment, only the Win32API copy (it calls win32_putenv()).
81ab4c44
SH
1771 *
1772 * As with CPerlHost::Getenv() and CPerlHost::Putenv() themselves, it makes
1773 * sense to only update the process environment when inside the main
1774 * interpreter, but we don't have access to CPerlHost's m_bTopLevel member
1775 * from here so we'll just have to check PL_curinterp instead.
1776 *
1777 * Therefore, we can simply #undef getenv() and putenv() so that those names
1778 * always refer to the CRT functions, and explicitly call win32_getenv() to
1779 * access perl's %ENV.
1780 *
1781 * We also #undef malloc() and free() to be sure we are using the CRT
1782 * functions otherwise under PERL_IMPLICIT_SYS they are redefined to calls
1783 * into VMem::Malloc() and VMem::Free() and all allocations will be freed
1784 * when the Perl interpreter is being destroyed so we'd end up with a pointer
1785 * into deallocated memory in environ[] if a program embedding a Perl
1786 * interpreter continues to operate even after the main Perl interpreter has
1787 * been destroyed.
1788 *
1789 * Note that we don't free() the malloc()ed memory unless and until we call
1790 * malloc() again ourselves because the CRT putenv() function simply puts its
b7b1e41b 1791 * pointer argument into the environ[] array (it doesn't make a copy of it)
81ab4c44
SH
1792 * so this memory must otherwise be leaked.
1793 */
1794
1795#undef getenv
1796#undef putenv
1797#undef malloc
1798#undef free
1799
1800static void
1801fix_win32_tzenv(void)
1802{
1803 static char* oldenv = NULL;
1804 char* newenv;
1805 const char* perl_tz_env = win32_getenv("TZ");
1806 const char* crt_tz_env = getenv("TZ");
1807 if (perl_tz_env == NULL)
1808 perl_tz_env = "";
1809 if (crt_tz_env == NULL)
1810 crt_tz_env = "";
083b2a61 1811 if (strNE(perl_tz_env, crt_tz_env)) {
81ab4c44
SH
1812 newenv = (char*)malloc((strlen(perl_tz_env) + 4) * sizeof(char));
1813 if (newenv != NULL) {
1814 sprintf(newenv, "TZ=%s", perl_tz_env);
1815 putenv(newenv);
1816 if (oldenv != NULL)
1817 free(oldenv);
1818 oldenv = newenv;
1819 }
1820 }
1821}
1822
1823#endif
1824
1825/*
1826 * my_tzset - wrapper to tzset() with a fix to make it work (better) on Win32.
1827 * This code is duplicated in the Time-Piece module, so any changes made here
1828 * should be made there too.
1829 */
1830static void
1831my_tzset(pTHX)
1832{
1833#ifdef WIN32
1834#if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
1835 if (PL_curinterp == aTHX)
1836#endif
1837 fix_win32_tzenv();
1838#endif
1839 tzset();
1840}
1841
2304df62
AD
1842MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig
1843
92b39396 1844void
2304df62 1845new(packname = "POSIX::SigSet", ...)
d3f5e399 1846 const char * packname
2304df62
AD
1847 CODE:
1848 {
1849 int i;
92b39396
NC
1850 sigset_t *const s
1851 = (sigset_t *) allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
1852 sizeof(sigset_t),
1853 packname);
1854 sigemptyset(s);
3a5c73f3
TC
1855 for (i = 1; i < items; i++) {
1856 IV sig = SvIV(ST(i));
1857 if (sigaddset(s, sig) < 0)
1858 croak("POSIX::Sigset->new: failed to add signal %" IVdf, sig);
1859 }
92b39396 1860 XSRETURN(1);
2304df62 1861 }
2304df62
AD
1862
1863SysRet
df6c2df2 1864addset(sigset, sig)
2304df62 1865 POSIX::SigSet sigset
69b5fd06 1866 POSIX::SigNo sig
df6c2df2
NC
1867 ALIAS:
1868 delset = 1
1869 CODE:
1870 RETVAL = ix ? sigdelset(sigset, sig) : sigaddset(sigset, sig);
1871 OUTPUT:
1872 RETVAL
2304df62
AD
1873
1874SysRet
df6c2df2 1875emptyset(sigset)
2304df62 1876 POSIX::SigSet sigset
df6c2df2
NC
1877 ALIAS:
1878 fillset = 1
1879 CODE:
1880 RETVAL = ix ? sigfillset(sigset) : sigemptyset(sigset);
1881 OUTPUT:
1882 RETVAL
2304df62
AD
1883
1884int
1885sigismember(sigset, sig)
1886 POSIX::SigSet sigset
69b5fd06 1887 POSIX::SigNo sig
2304df62 1888
a0d0e21e
LW
1889MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf
1890
11a39fe4 1891void
a0d0e21e 1892new(packname = "POSIX::Termios", ...)
d3f5e399 1893 const char * packname
a0d0e21e
LW
1894 CODE:
1895 {
1896#ifdef I_TERMIOS
a2261f90
NC
1897 void *const p = allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
1898 sizeof(struct termios), packname);
11a39fe4
NC
1899 /* The previous implementation stored a pointer to an uninitialised
1900 struct termios. Seems safer to initialise it, particularly as
1901 this implementation exposes the struct to prying from perl-space.
1902 */
a2261f90 1903 memset(p, 0, 1 + sizeof(struct termios));
11a39fe4 1904 XSRETURN(1);
a0d0e21e
LW
1905#else
1906 not_here("termios");
1907#endif
1908 }
a0d0e21e
LW
1909
1910SysRet
1911getattr(termios_ref, fd = 0)
1912 POSIX::Termios termios_ref
ddc7c5c7 1913 POSIX::Fd fd
a0d0e21e
LW
1914 CODE:
1915 RETVAL = tcgetattr(fd, termios_ref);
1916 OUTPUT:
1917 RETVAL
1918
f90ac1a0
DM
1919 # If we define TCSANOW here then both a found and not found constant sub
1920 # are created causing a Constant subroutine TCSANOW redefined warning
1921
518487b2 1922#ifndef TCSANOW
e08f19f5
TC
1923# define DEF_SETATTR_ACTION 0
1924#else
1925# define DEF_SETATTR_ACTION TCSANOW
518487b2 1926#endif
a0d0e21e 1927SysRet
e08f19f5 1928setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION)
a0d0e21e 1929 POSIX::Termios termios_ref
ddc7c5c7 1930 POSIX::Fd fd
a0d0e21e
LW
1931 int optional_actions
1932 CODE:
ddc7c5c7
JH
1933 /* The second argument to the call is mandatory, but we'd like to give
1934 it a useful default. 0 isn't valid on all operating systems - on
1935 Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same
1936 values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF. */
1937 if (optional_actions < 0) {
1938 SETERRNO(EINVAL, LIB_INVARG);
8481e3d3 1939 RETVAL = -1;
ddc7c5c7
JH
1940 } else {
1941 RETVAL = tcsetattr(fd, optional_actions, termios_ref);
8481e3d3 1942 }
a0d0e21e
LW
1943 OUTPUT:
1944 RETVAL
1945
1946speed_t
2a59a32c 1947getispeed(termios_ref)
a0d0e21e 1948 POSIX::Termios termios_ref
2a59a32c
NC
1949 ALIAS:
1950 getospeed = 1
a0d0e21e 1951 CODE:
2a59a32c 1952 RETVAL = ix ? cfgetospeed(termios_ref) : cfgetispeed(termios_ref);
a0d0e21e
LW
1953 OUTPUT:
1954 RETVAL
1955
1956tcflag_t
2a59a32c 1957getiflag(termios_ref)
a0d0e21e 1958 POSIX::Termios termios_ref
2a59a32c
NC
1959 ALIAS:
1960 getoflag = 1
1961 getcflag = 2
1962 getlflag = 3
a0d0e21e
LW
1963 CODE:
1964#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2a59a32c
NC
1965 switch(ix) {
1966 case 0:
1967 RETVAL = termios_ref->c_iflag;
1968 break;
1969 case 1:
1970 RETVAL = termios_ref->c_oflag;
1971 break;
1972 case 2:
1973 RETVAL = termios_ref->c_cflag;
1974 break;
1975 case 3:
1976 RETVAL = termios_ref->c_lflag;
1977 break;
df164f52
DM
1978 default:
1979 RETVAL = 0; /* silence compiler warning */
2a59a32c 1980 }
a0d0e21e 1981#else
2a59a32c
NC
1982 not_here(GvNAME(CvGV(cv)));
1983 RETVAL = 0;
a0d0e21e
LW
1984#endif
1985 OUTPUT:
1986 RETVAL
1987
1988cc_t
1989getcc(termios_ref, ccix)
1990 POSIX::Termios termios_ref
b56fc9ec 1991 unsigned int ccix
a0d0e21e
LW
1992 CODE:
1993#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
1994 if (ccix >= NCCS)
1995 croak("Bad getcc subscript");
1996 RETVAL = termios_ref->c_cc[ccix];
1997#else
640cc986
HM
1998 not_here("getcc");
1999 RETVAL = 0;
a0d0e21e
LW
2000#endif
2001 OUTPUT:
2002 RETVAL
2003
2004SysRet
2a59a32c 2005setispeed(termios_ref, speed)
a0d0e21e
LW
2006 POSIX::Termios termios_ref
2007 speed_t speed
2a59a32c
NC
2008 ALIAS:
2009 setospeed = 1
a0d0e21e 2010 CODE:
2a59a32c
NC
2011 RETVAL = ix
2012 ? cfsetospeed(termios_ref, speed) : cfsetispeed(termios_ref, speed);
2013 OUTPUT:
2014 RETVAL
a0d0e21e
LW
2015
2016void
2a59a32c 2017setiflag(termios_ref, flag)
a0d0e21e 2018 POSIX::Termios termios_ref
2a59a32c
NC
2019 tcflag_t flag
2020 ALIAS:
2021 setoflag = 1
2022 setcflag = 2
2023 setlflag = 3
a0d0e21e
LW
2024 CODE:
2025#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2a59a32c
NC
2026 switch(ix) {
2027 case 0:
2028 termios_ref->c_iflag = flag;
2029 break;
2030 case 1:
2031 termios_ref->c_oflag = flag;
2032 break;
2033 case 2:
2034 termios_ref->c_cflag = flag;
2035 break;
2036 case 3:
2037 termios_ref->c_lflag = flag;
2038 break;
2039 }
a0d0e21e 2040#else
2a59a32c 2041 not_here(GvNAME(CvGV(cv)));
a0d0e21e
LW
2042#endif
2043
2044void
2045setcc(termios_ref, ccix, cc)
2046 POSIX::Termios termios_ref
b56fc9ec 2047 unsigned int ccix
a0d0e21e
LW
2048 cc_t cc
2049 CODE:
2050#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2051 if (ccix >= NCCS)
2052 croak("Bad setcc subscript");
2053 termios_ref->c_cc[ccix] = cc;
2054#else
2055 not_here("setcc");
2056#endif
2057
2058
a0d0e21e
LW
2059MODULE = POSIX PACKAGE = POSIX
2060
1cb0fb50 2061INCLUDE: const-xs.inc
a290f238 2062
e99d581a
NC
2063int
2064WEXITSTATUS(status)
2065 int status
72bfe1b2
NC
2066 ALIAS:
2067 POSIX::WIFEXITED = 1
2068 POSIX::WIFSIGNALED = 2
2069 POSIX::WIFSTOPPED = 3
2070 POSIX::WSTOPSIG = 4
2071 POSIX::WTERMSIG = 5
2072 CODE:
fabb67aa
SK
2073#if !defined(WEXITSTATUS) || !defined(WIFEXITED) || !defined(WIFSIGNALED) \
2074 || !defined(WIFSTOPPED) || !defined(WSTOPSIG) || !defined(WTERMSIG)
19c4478c
NC
2075 RETVAL = 0; /* Silence compilers that notice this, but don't realise
2076 that not_here() can't return. */
2077#endif
72bfe1b2
NC
2078 switch(ix) {
2079 case 0:
d49025b7 2080#ifdef WEXITSTATUS
17028706 2081 RETVAL = WEXITSTATUS(WMUNGE(status));
d49025b7
NC
2082#else
2083 not_here("WEXITSTATUS");
2084#endif
72bfe1b2
NC
2085 break;
2086 case 1:
d49025b7 2087#ifdef WIFEXITED
17028706 2088 RETVAL = WIFEXITED(WMUNGE(status));
d49025b7
NC
2089#else
2090 not_here("WIFEXITED");
2091#endif
72bfe1b2
NC
2092 break;
2093 case 2:
d49025b7 2094#ifdef WIFSIGNALED
17028706 2095 RETVAL = WIFSIGNALED(WMUNGE(status));
d49025b7
NC
2096#else
2097 not_here("WIFSIGNALED");
2098#endif
72bfe1b2
NC
2099 break;
2100 case 3:
d49025b7 2101#ifdef WIFSTOPPED
17028706 2102 RETVAL = WIFSTOPPED(WMUNGE(status));
d49025b7
NC
2103#else
2104 not_here("WIFSTOPPED");
2105#endif
72bfe1b2
NC
2106 break;
2107 case 4:
d49025b7 2108#ifdef WSTOPSIG
17028706 2109 RETVAL = WSTOPSIG(WMUNGE(status));
d49025b7
NC
2110#else
2111 not_here("WSTOPSIG");
2112#endif
72bfe1b2
NC
2113 break;
2114 case 5:
d49025b7 2115#ifdef WTERMSIG
17028706 2116 RETVAL = WTERMSIG(WMUNGE(status));
d49025b7
NC
2117#else
2118 not_here("WTERMSIG");
2119#endif
72bfe1b2
NC
2120 break;
2121 default:
42c07143 2122 croak("Illegal alias %d for POSIX::W*", (int)ix);
72bfe1b2
NC
2123 }
2124 OUTPUT:
2125 RETVAL
2304df62 2126
2304df62
AD
2127SysRet
2128open(filename, flags = O_RDONLY, mode = 0666)
2129 char * filename
2130 int flags
a0d0e21e 2131 Mode_t mode
748a9306
LW
2132 CODE:
2133 if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL))
2134 TAINT_PROPER("open");
2135 RETVAL = open(filename, flags, mode);
2136 OUTPUT:
2137 RETVAL
2138
2304df62
AD
2139
2140HV *
2141localeconv()
2142 CODE:
3f3bcbfc
KW
2143#ifndef HAS_LOCALECONV
2144 localeconv(); /* A stub to call not_here(). */
2145#else
2304df62 2146 struct lconv *lcbuf;
7d5966ae
KW
2147# if defined(USE_ITHREADS) \
2148 && defined(HAS_POSIX_2008_LOCALE) \
2149 && defined(HAS_LOCALECONV_L) /* Prefer this thread-safe version */
2150 bool do_free = FALSE;
a438847a 2151 locale_t cur = NULL;
69c5e0db
KW
2152# elif defined(TS_W32_BROKEN_LOCALECONV)
2153 const char * save_global;
2154 const char * save_thread;
7d5966ae 2155# endif
604d7733
KW
2156 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2157
a835cd47
KW
2158 /* localeconv() deals with both LC_NUMERIC and LC_MONETARY, but
2159 * LC_MONETARY is already in the correct locale */
604d7733
KW
2160# ifdef USE_LOCALE_MONETARY
2161
2162 const bool is_monetary_utf8 = _is_cur_LC_category_utf8(LC_MONETARY);
2163# endif
2164# ifdef USE_LOCALE_NUMERIC
2165
2166 bool is_numeric_utf8;
2167
67d796ae 2168 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
a835cd47 2169
604d7733
KW
2170 is_numeric_utf8 = _is_cur_LC_category_utf8(LC_NUMERIC);
2171# endif
2172
2304df62 2173 RETVAL = newHV();
c4e79b56 2174 sv_2mortal((SV*)RETVAL);
7d5966ae
KW
2175# if defined(USE_ITHREADS) \
2176 && defined(HAS_POSIX_2008_LOCALE) \
80306bb6
KW
2177 && defined(HAS_LOCALECONV_L) \
2178 && defined(HAS_DUPLOCALE)
7d5966ae 2179
8fc14efc 2180 cur = uselocale((locale_t) 0);
7d5966ae
KW
2181 if (cur == LC_GLOBAL_LOCALE) {
2182 cur = duplocale(LC_GLOBAL_LOCALE);
2183 do_free = TRUE;
2184 }
604d7733 2185
7d5966ae
KW
2186 lcbuf = localeconv_l(cur);
2187# else
8609fe00
KW
2188 LOCALECONV_LOCK; /* Prevent interference with other threads using
2189 localeconv() */
69c5e0db
KW
2190# ifdef TS_W32_BROKEN_LOCALECONV
2191 /* This is a workaround for a Windows bug prior to VS 15, in which
2192 * localeconv only looks at the global locale. We toggle to the global
2193 * locale; populate the return; then toggle back. We have to use
2194 * LC_ALL instead of the individual ones because of another bug in
2195 * Windows */
604d7733 2196
69c5e0db
KW
2197 save_thread = savepv(Perl_setlocale(LC_NUMERIC, NULL));
2198
2199 _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
2200
2201 save_global = savepv(Perl_setlocale(LC_ALL, NULL));
2202
2203 Perl_setlocale(LC_ALL, save_thread);
2204# endif
7d5966ae
KW
2205 lcbuf = localeconv();
2206# endif
604d7733 2207 if (lcbuf) {
2f0945cb
NC
2208 const struct lconv_offset *strings = lconv_strings;
2209 const struct lconv_offset *integers = lconv_integers;
2210 const char *ptr = (const char *) lcbuf;
2211
e3bf3304 2212 while (strings->name) {
c1284011
KW
2213 /* This string may be controlled by either LC_NUMERIC, or
2214 * LC_MONETARY */
604d7733
KW
2215 const bool is_utf8_locale =
2216# if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY)
2217 (isLC_NUMERIC_STRING(strings->name))
2218 ? is_numeric_utf8
2219 : is_monetary_utf8;
2220# elif defined(USE_LOCALE_NUMERIC)
2221 is_numeric_utf8;
2222# elif defined(USE_LOCALE_MONETARY)
2223 is_monetary_utf8;
2224# else
2225 FALSE;
2226# endif
c1284011 2227
2f0945cb
NC
2228 const char *value = *((const char **)(ptr + strings->offset));
2229
c1284011 2230 if (value && *value) {
40e3578e
KW
2231 const STRLEN value_len = strlen(value);
2232
2233 /* We mark it as UTF-8 if a utf8 locale and is valid and
2234 * variant under UTF-8 */
2235 const bool is_utf8 = is_utf8_locale
2236 && is_utf8_non_invariant_string(
2237 (U8*) value,
2238 value_len);
c1284011 2239 (void) hv_store(RETVAL,
40e3578e
KW
2240 strings->name,
2241 strlen(strings->name),
2242 newSVpvn_utf8(value, value_len, is_utf8),
2243 0);
c5f058df 2244 }
e3bf3304
KW
2245 strings++;
2246 }
2f0945cb 2247
e3bf3304 2248 while (integers->name) {
2f0945cb
NC
2249 const char value = *((const char *)(ptr + integers->offset));
2250
2251 if (value != CHAR_MAX)
2252 (void) hv_store(RETVAL, integers->name,
2253 strlen(integers->name), newSViv(value), 0);
e3bf3304
KW
2254 integers++;
2255 }
2304df62 2256 }
7d5966ae
KW
2257# if defined(USE_ITHREADS) \
2258 && defined(HAS_POSIX_2008_LOCALE) \
2259 && defined(HAS_LOCALECONV_L)
2260 if (do_free) {
2261 freelocale(cur);
2262 }
2263# else
69c5e0db
KW
2264# ifdef TS_W32_BROKEN_LOCALECONV
2265 Perl_setlocale(LC_ALL, save_global);
2266
2267 _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
2268
2269 Perl_setlocale(LC_ALL, save_thread);
2270
2271 Safefree(save_global);
2272 Safefree(save_thread);
2273# endif
8609fe00 2274 LOCALECONV_UNLOCK;
7d5966ae 2275# endif
688523a0 2276 RESTORE_LC_NUMERIC();
3f3bcbfc 2277#endif /* HAS_LOCALECONV */
2304df62
AD
2278 OUTPUT:
2279 RETVAL
2280
2281char *
c28ee57b 2282setlocale(category, locale = 0)
2304df62 2283 int category
8e70cf7a 2284 const char * locale
1ba01ae3
SH
2285 PREINIT:
2286 char * retval;
c28ee57b 2287 CODE:
9aac5db8
KW
2288 retval = (char *) Perl_setlocale(category, locale);
2289 if (! retval) {
fbd840df
KW
2290 XSRETURN_UNDEF;
2291 }
49efabc8 2292
a4f00dcc 2293 RETVAL = retval;
c28ee57b
JH
2294 OUTPUT:
2295 RETVAL
2304df62 2296
e1ca407b 2297NV
2304df62 2298acos(x)
e1ca407b 2299 NV x
b256643b 2300 ALIAS:
7965edec
JH
2301 acosh = 1
2302 asin = 2
2303 asinh = 3
2304 atan = 4
2305 atanh = 5
2306 cbrt = 6
2307 ceil = 7
2308 cosh = 8
2309 erf = 9
2310 erfc = 10
2311 exp2 = 11
2312 expm1 = 12
2313 floor = 13
2314 j0 = 14
2315 j1 = 15
2316 lgamma = 16
2317 log10 = 17
2318 log1p = 18
2319 log2 = 19
2320 logb = 20
2321 nearbyint = 21
2322 rint = 22
2323 round = 23
2324 sinh = 24
2325 tan = 25
2326 tanh = 26
2327 tgamma = 27
2328 trunc = 28
2329 y0 = 29
2330 y1 = 30
b256643b 2331 CODE:
7f4bfd0b 2332 PERL_UNUSED_VAR(x);
effb4c81 2333#ifdef NV_NAN
78a0541a 2334 RETVAL = NV_NAN;
effb4c81
JH
2335#else
2336 RETVAL = 0;
2337#endif
b256643b
NC
2338 switch (ix) {
2339 case 0:
8a00eddc 2340 RETVAL = Perl_acos(x); /* C89 math */
b256643b
NC
2341 break;
2342 case 1:
5716d070 2343#ifdef c99_acosh
7965edec 2344 RETVAL = c99_acosh(x);
5716d070
JH
2345#else
2346 not_here("acosh");
2347#endif
b256643b
NC
2348 break;
2349 case 2:
8a00eddc 2350 RETVAL = Perl_asin(x); /* C89 math */
b256643b
NC
2351 break;
2352 case 3:
5716d070 2353#ifdef c99_asinh
7965edec 2354 RETVAL = c99_asinh(x);
5716d070
JH
2355#else
2356 not_here("asinh");
2357#endif
b256643b
NC
2358 break;
2359 case 4:
8a00eddc 2360 RETVAL = Perl_atan(x); /* C89 math */
b256643b
NC
2361 break;
2362 case 5:
5716d070 2363#ifdef c99_atanh
7965edec 2364 RETVAL = c99_atanh(x);
5716d070
JH
2365#else
2366 not_here("atanh");
2367#endif
b256643b
NC
2368 break;
2369 case 6:
5716d070 2370#ifdef c99_cbrt
7965edec 2371 RETVAL = c99_cbrt(x);
5716d070
JH
2372#else
2373 not_here("cbrt");
2374#endif
b256643b
NC
2375 break;
2376 case 7:
8a00eddc 2377 RETVAL = Perl_ceil(x); /* C89 math */
b256643b
NC
2378 break;
2379 case 8:
8a00eddc 2380 RETVAL = Perl_cosh(x); /* C89 math */
7965edec
JH
2381 break;
2382 case 9:
5716d070 2383#ifdef c99_erf
7965edec 2384 RETVAL = c99_erf(x);
5716d070
JH
2385#else
2386 not_here("erf");
2387#endif
7965edec
JH
2388 break;
2389 case 10:
5716d070 2390#ifdef c99_erfc
d5799f37 2391 RETVAL = c99_erfc(x);
5716d070
JH
2392#else
2393 not_here("erfc");
2394#endif
7965edec
JH
2395 break;
2396 case 11:
5716d070 2397#ifdef c99_exp2
7965edec 2398 RETVAL = c99_exp2(x);
5716d070
JH
2399#else
2400 not_here("exp2");
2401#endif
7965edec
JH
2402 break;
2403 case 12:
5716d070 2404#ifdef c99_expm1
7965edec 2405 RETVAL = c99_expm1(x);
5716d070
JH
2406#else
2407 not_here("expm1");
2408#endif
7965edec
JH
2409 break;
2410 case 13:
8a00eddc 2411 RETVAL = Perl_floor(x); /* C89 math */
7965edec
JH
2412 break;
2413 case 14:
5716d070 2414#ifdef bessel_j0
7965edec 2415 RETVAL = bessel_j0(x);
5716d070 2416#else
85c93440 2417 not_here("j0");
5716d070 2418#endif
7965edec
JH
2419 break;
2420 case 15:
5716d070 2421#ifdef bessel_j1
7965edec 2422 RETVAL = bessel_j1(x);
5716d070 2423#else
85c93440 2424 not_here("j1");
5716d070 2425#endif
7965edec
JH
2426 break;
2427 case 16:
2e9cdb62 2428 /* XXX Note: the lgamma modifies a global variable (signgam),
d334ccbe 2429 * which is evil. Some platforms have lgamma_r, which has
2e9cdb62 2430 * extra output parameter instead of the global variable. */
5716d070 2431#ifdef c99_lgamma
7965edec 2432 RETVAL = c99_lgamma(x);
5716d070
JH
2433#else
2434 not_here("lgamma");
2435#endif
7965edec
JH
2436 break;
2437 case 17:
e6081c0e 2438 RETVAL = Perl_log10(x); /* C89 math */
7965edec
JH
2439 break;
2440 case 18:
5716d070 2441#ifdef c99_log1p
7965edec 2442 RETVAL = c99_log1p(x);
5716d070
JH
2443#else
2444 not_here("log1p");
2445#endif
7965edec
JH
2446 break;
2447 case 19:
5716d070 2448#ifdef c99_log2
7965edec 2449 RETVAL = c99_log2(x);
5716d070
JH
2450#else
2451 not_here("log2");
2452#endif
7965edec
JH
2453 break;
2454 case 20:
5716d070 2455#ifdef c99_logb
7965edec 2456 RETVAL = c99_logb(x);
eec978e5
JH
2457#elif defined(c99_log2) && FLT_RADIX == 2
2458 RETVAL = Perl_floor(c99_log2(PERL_ABS(x)));
5716d070
JH
2459#else
2460 not_here("logb");
2461#endif
7965edec
JH
2462 break;
2463 case 21:
5716d070 2464#ifdef c99_nearbyint
7965edec 2465 RETVAL = c99_nearbyint(x);
5716d070
JH
2466#else
2467 not_here("nearbyint");
2468#endif
7965edec
JH
2469 break;
2470 case 22:
5716d070 2471#ifdef c99_rint
7965edec 2472 RETVAL = c99_rint(x);
5716d070
JH
2473#else
2474 not_here("rint");
2475#endif
7965edec
JH
2476 break;
2477 case 23:
5716d070 2478#ifdef c99_round
7965edec 2479 RETVAL = c99_round(x);
5716d070
JH
2480#else
2481 not_here("round");
2482#endif
7965edec
JH
2483 break;
2484 case 24:
8a00eddc 2485 RETVAL = Perl_sinh(x); /* C89 math */
7965edec
JH
2486 break;
2487 case 25:
8a00eddc 2488 RETVAL = Perl_tan(x); /* C89 math */
b256643b 2489 break;
7965edec 2490 case 26:
8a00eddc 2491 RETVAL = Perl_tanh(x); /* C89 math */
7965edec
JH
2492 break;
2493 case 27:
5716d070 2494#ifdef c99_tgamma
7965edec 2495 RETVAL = c99_tgamma(x);
5716d070
JH
2496#else
2497 not_here("tgamma");
2498#endif
7965edec
JH
2499 break;
2500 case 28:
5716d070 2501#ifdef c99_trunc
7965edec 2502 RETVAL = c99_trunc(x);
5716d070
JH
2503#else
2504 not_here("trunc");
2505#endif
7965edec
JH
2506 break;
2507 case 29:
5716d070 2508#ifdef bessel_y0
7965edec 2509 RETVAL = bessel_y0(x);
5716d070 2510#else
85c93440 2511 not_here("y0");
5716d070 2512#endif
7965edec
JH
2513 break;
2514 case 30:
2515 default:
5716d070 2516#ifdef bessel_y1
7965edec 2517 RETVAL = bessel_y1(x);
5716d070 2518#else
85c93440 2519 not_here("y1");
5716d070 2520#endif
7965edec
JH
2521 }
2522 OUTPUT:
2523 RETVAL
2524
2525IV
a5713e21
JH
2526fegetround()
2527 CODE:
78a0541a 2528#ifdef HAS_FEGETROUND
d5f4f26a 2529 RETVAL = my_fegetround();
78a0541a
JH
2530#else
2531 RETVAL = -1;
a5713e21
JH
2532 not_here("fegetround");
2533#endif
2534 OUTPUT:
2535 RETVAL
2536
2537IV
2538fesetround(x)
2539 IV x
2540 CODE:
2541#ifdef HAS_FEGETROUND /* canary for fesetround */
2542 RETVAL = fesetround(x);
879d23d2 2543#elif defined(HAS_FPGETROUND) /* canary for fpsetround */
e0939537 2544 switch (x) {
e0939537
JH
2545 case FE_TONEAREST: RETVAL = fpsetround(FP_RN); break;
2546 case FE_TOWARDZERO: RETVAL = fpsetround(FP_RZ); break;
2547 case FE_DOWNWARD: RETVAL = fpsetround(FP_RM); break;
2548 case FE_UPWARD: RETVAL = fpsetround(FP_RP); break;
ebac59ac 2549 default: RETVAL = -1; break;
e0939537 2550 }
877206df
JH
2551#elif defined(__osf__) /* Tru64 */
2552 switch (x) {
2553 case FE_TONEAREST: RETVAL = write_rnd(FP_RND_RN); break;
2554 case FE_TOWARDZERO: RETVAL = write_rnd(FP_RND_RZ); break;
2555 case FE_DOWNWARD: RETVAL = write_rnd(FP_RND_RM); break;
2556 case FE_UPWARD: RETVAL = write_rnd(FP_RND_RP); break;
2557 default: RETVAL = -1; break;
2558 }
a5713e21 2559#else
7f4bfd0b 2560 PERL_UNUSED_VAR(x);
78a0541a 2561 RETVAL = -1;
a5713e21
JH
2562 not_here("fesetround");
2563#endif
2564 OUTPUT:
2565 RETVAL
2566
2567IV
7965edec
JH
2568fpclassify(x)
2569 NV x
2570 ALIAS:
2571 ilogb = 1
2572 isfinite = 2
2573 isinf = 3
2574 isnan = 4
2575 isnormal = 5
3823048b
JH
2576 lrint = 6
2577 lround = 7
2578 signbit = 8
7965edec 2579 CODE:
7f4bfd0b 2580 PERL_UNUSED_VAR(x);
78a0541a 2581 RETVAL = -1;
7965edec
JH
2582 switch (ix) {
2583 case 0:
5716d070 2584#ifdef c99_fpclassify
7965edec 2585 RETVAL = c99_fpclassify(x);
5716d070
JH
2586#else
2587 not_here("fpclassify");
2588#endif
7965edec
JH
2589 break;
2590 case 1:
5716d070 2591#ifdef c99_ilogb
7965edec 2592 RETVAL = c99_ilogb(x);
5716d070
JH
2593#else
2594 not_here("ilogb");
2595#endif
7965edec
JH
2596 break;
2597 case 2:
2598 RETVAL = Perl_isfinite(x);
2599 break;
2600 case 3:
2601 RETVAL = Perl_isinf(x);
2602 break;
2603 case 4:
2604 RETVAL = Perl_isnan(x);
2605 break;
2606 case 5:
5716d070 2607#ifdef c99_isnormal
7965edec 2608 RETVAL = c99_isnormal(x);
5716d070
JH
2609#else
2610 not_here("isnormal");
2611#endif
7965edec
JH
2612 break;
2613 case 6:
d5f4f26a
JH
2614#ifdef c99_lrint
2615 RETVAL = c99_lrint(x);
2616#else
2617 not_here("lrint");
2618#endif
2619 break;
3823048b 2620 case 7:
9e010b89
JH
2621#ifdef c99_lround
2622 RETVAL = c99_lround(x);
2623#else
2624 not_here("lround");
2625#endif
2626 break;
3823048b 2627 case 8:
7965edec 2628 default:
5716d070
JH
2629#ifdef Perl_signbit
2630 RETVAL = Perl_signbit(x);
2a7bb164 2631#else
0c61ae02
JH
2632 RETVAL = (x < 0);
2633#ifdef DOUBLE_IS_IEEE_FORMAT
2634 if (x == -0.0) {
2635 RETVAL = TRUE;
2636 }
2637#endif
5716d070 2638#endif
7965edec 2639 break;
b256643b
NC
2640 }
2641 OUTPUT:
2642 RETVAL
2304df62 2643
e1ca407b 2644NV
07bb61ac
JH
2645getpayload(nv)
2646 NV nv
2647 CODE:
effb4c81 2648#ifdef DOUBLE_HAS_NAN
07bb61ac 2649 RETVAL = S_getpayload(nv);
effb4c81
JH
2650#else
2651 PERL_UNUSED_VAR(nv);
9ec60511 2652 RETVAL = 0.0;
effb4c81
JH
2653 not_here("getpayload");
2654#endif
07bb61ac
JH
2655 OUTPUT:
2656 RETVAL
2657
2658void
2659setpayload(nv, payload)
2660 NV nv
2661 NV payload
2662 CODE:
effb4c81 2663#ifdef DOUBLE_HAS_NAN
07bb61ac 2664 S_setpayload(&nv, payload, FALSE);
effb4c81
JH
2665#else
2666 PERL_UNUSED_VAR(nv);
2667 PERL_UNUSED_VAR(payload);
2668 not_here("setpayload");
2669#endif
07bb61ac
JH
2670 OUTPUT:
2671 nv
2672
2673void
2674setpayloadsig(nv, payload)
2675 NV nv
2676 NV payload
2677 CODE:
effb4c81 2678#ifdef DOUBLE_HAS_NAN
07bb61ac
JH
2679 nv = NV_NAN;
2680 S_setpayload(&nv, payload, TRUE);
effb4c81
JH
2681#else
2682 PERL_UNUSED_VAR(nv);
2683 PERL_UNUSED_VAR(payload);
2684 not_here("setpayloadsig");
2685#endif
07bb61ac
JH
2686 OUTPUT:
2687 nv
2688
2689int
2690issignaling(nv)
2691 NV nv
2692 CODE:
effb4c81 2693#ifdef DOUBLE_HAS_NAN
07bb61ac 2694 RETVAL = Perl_isnan(nv) && NV_NAN_IS_SIGNALING(&nv);
effb4c81
JH
2695#else
2696 PERL_UNUSED_VAR(nv);
9ec60511 2697 RETVAL = 0.0;
effb4c81
JH
2698 not_here("issignaling");
2699#endif
07bb61ac
JH
2700 OUTPUT:
2701 RETVAL
2702
2703NV
7965edec 2704copysign(x,y)
e1ca407b
A
2705 NV x
2706 NV y
7965edec
JH
2707 ALIAS:
2708 fdim = 1
2709 fmax = 2
2710 fmin = 3
2711 fmod = 4
2712 hypot = 5
2713 isgreater = 6
2714 isgreaterequal = 7
2715 isless = 8
2716 islessequal = 9
2717 islessgreater = 10
2718 isunordered = 11
2719 nextafter = 12
2720 nexttoward = 13
2721 remainder = 14
2722 CODE:
7f4bfd0b
JH
2723 PERL_UNUSED_VAR(x);
2724 PERL_UNUSED_VAR(y);
effb4c81 2725#ifdef NV_NAN
78a0541a 2726 RETVAL = NV_NAN;
effb4c81
JH
2727#else
2728 RETVAL = 0;
2729#endif
7965edec
JH
2730 switch (ix) {
2731 case 0:
5716d070 2732#ifdef c99_copysign
7965edec 2733 RETVAL = c99_copysign(x, y);
5716d070
JH
2734#else
2735 not_here("copysign");
2736#endif
7965edec
JH
2737 break;
2738 case 1:
5716d070 2739#ifdef c99_fdim
7965edec 2740 RETVAL = c99_fdim(x, y);
5716d070
JH
2741#else
2742 not_here("fdim");
2743#endif
7965edec
JH
2744 break;
2745 case 2:
5716d070 2746#ifdef c99_fmax
7965edec 2747 RETVAL = c99_fmax(x, y);
5716d070
JH
2748#else
2749 not_here("fmax");
2750#endif
7965edec
JH
2751 break;
2752 case 3:
5716d070 2753#ifdef c99_fmin
7965edec 2754 RETVAL = c99_fmin(x, y);
5716d070
JH
2755#else
2756 not_here("fmin");
2757#endif
7965edec
JH
2758 break;
2759 case 4:
8a00eddc 2760 RETVAL = Perl_fmod(x, y); /* C89 math */
7965edec
JH
2761 break;
2762 case 5:
5716d070 2763#ifdef c99_hypot
7965edec 2764 RETVAL = c99_hypot(x, y);
5716d070
JH
2765#else
2766 not_here("hypot");
2767#endif
7965edec
JH
2768 break;
2769 case 6:
5716d070 2770#ifdef c99_isgreater
7965edec 2771 RETVAL = c99_isgreater(x, y);
5716d070
JH
2772#else
2773 not_here("isgreater");
2774#endif
7965edec
JH
2775 break;
2776 case 7:
5716d070 2777#ifdef c99_isgreaterequal
7965edec 2778 RETVAL = c99_isgreaterequal(x, y);
5716d070
JH
2779#else
2780 not_here("isgreaterequal");
2781#endif
7965edec
JH
2782 break;
2783 case 8:
5716d070 2784#ifdef c99_isless
7965edec 2785 RETVAL = c99_isless(x, y);
5716d070
JH
2786#else
2787 not_here("isless");
2788#endif
7965edec
JH
2789 break;
2790 case 9:
5716d070 2791#ifdef c99_islessequal
7965edec 2792 RETVAL = c99_islessequal(x, y);
5716d070
JH
2793#else
2794 not_here("islessequal");
2795#endif
7965edec
JH
2796 break;
2797 case 10:
5716d070 2798#ifdef c99_islessgreater
7965edec 2799 RETVAL = c99_islessgreater(x, y);
5716d070
JH
2800#else
2801 not_here("islessgreater");
2802#endif
7965edec
JH
2803 break;
2804 case 11:
5716d070 2805#ifdef c99_isunordered
7965edec 2806 RETVAL = c99_isunordered(x, y);
5716d070
JH
2807#else
2808 not_here("isunordered");
2809#endif
7965edec
JH
2810 break;
2811 case 12:
5716d070 2812#ifdef c99_nextafter
7965edec 2813 RETVAL = c99_nextafter(x, y);
5716d070
JH
2814#else
2815 not_here("nextafter");
2816#endif
7965edec
JH
2817 break;
2818 case 13:
5716d070 2819#ifdef c99_nexttoward
7965edec 2820 RETVAL = c99_nexttoward(x, y);
5716d070
JH
2821#else
2822 not_here("nexttoward");
2823#endif
7965edec
JH
2824 break;
2825 case 14:
2826 default:
5716d070 2827#ifdef c99_remainder
7f4bfd0b 2828 RETVAL = c99_remainder(x, y);
5716d070 2829#else
7f4bfd0b 2830 not_here("remainder");
5716d070 2831#endif
7965edec
JH
2832 break;
2833 }
2834 OUTPUT:
2835 RETVAL
2304df62
AD
2836
2837void
2838frexp(x)
e1ca407b 2839 NV x
2304df62
AD
2840 PPCODE:
2841 int expvar;
2304df62 2842 /* (We already know stack is long enough.) */
5716d070 2843 PUSHs(sv_2mortal(newSVnv(Perl_frexp(x,&expvar)))); /* C89 math */
2304df62
AD
2844 PUSHs(sv_2mortal(newSViv(expvar)));
2845
e1ca407b 2846NV
2304df62 2847ldexp(x,exp)
e1ca407b 2848 NV x
2304df62 2849 int exp
e6081c0e
TC
2850 CODE:
2851 RETVAL = Perl_ldexp(x, exp);
2852 OUTPUT:
2853 RETVAL
2304df62 2854
2304df62
AD
2855void
2856modf(x)
e1ca407b 2857 NV x
2304df62 2858 PPCODE:
e1ca407b 2859 NV intvar;
2304df62 2860 /* (We already know stack is long enough.) */
5716d070 2861 PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); /* C89 math */
2304df62
AD
2862 PUSHs(sv_2mortal(newSVnv(intvar)));
2863
7965edec
JH
2864void
2865remquo(x,y)
2866 NV x
2867 NV y
2868 PPCODE:
5716d070 2869#ifdef c99_remquo
7965edec
JH
2870 int intvar;
2871 PUSHs(sv_2mortal(newSVnv(c99_remquo(x,y,&intvar))));
2872 PUSHs(sv_2mortal(newSVnv(intvar)));
5716d070 2873#else
7f4bfd0b
JH
2874 PERL_UNUSED_VAR(x);
2875 PERL_UNUSED_VAR(y);
5716d070
JH
2876 not_here("remquo");
2877#endif
7965edec
JH
2878
2879NV
2880scalbn(x,y)
2881 NV x
2882 IV y
2883 CODE:
5716d070 2884#ifdef c99_scalbn
7965edec 2885 RETVAL = c99_scalbn(x, y);
5716d070 2886#else
7f4bfd0b
JH
2887 PERL_UNUSED_VAR(x);
2888 PERL_UNUSED_VAR(y);
78a0541a 2889 RETVAL = NV_NAN;
5716d070
JH
2890 not_here("scalbn");
2891#endif
7965edec
JH
2892 OUTPUT:
2893 RETVAL
2894
2895NV
2896fma(x,y,z)
2897 NV x
2898 NV y
2899 NV z
2900 CODE:
5716d070 2901#ifdef c99_fma
6b13befe
JH
2902 RETVAL = c99_fma(x, y, z);
2903#else
7f4bfd0b
JH
2904 PERL_UNUSED_VAR(x);
2905 PERL_UNUSED_VAR(y);
2906 PERL_UNUSED_VAR(z);
6b13befe 2907 not_here("fma");
5716d070 2908#endif
7965edec
JH
2909 OUTPUT:
2910 RETVAL
2911
2912NV
07bb61ac
JH
2913nan(payload = 0)
2914 NV payload
7965edec 2915 CODE:
07bb61ac
JH
2916#ifdef NV_NAN
2917 /* If no payload given, just return the default NaN.
2918 * This makes a difference in platforms where the default
2919 * NaN is not all zeros. */
2920 if (items == 0) {
2921 RETVAL = NV_NAN;
2922 } else {
2923 S_setpayload(&RETVAL, payload, FALSE);
2924 }
2925#elif defined(c99_nan)
2926 {
effb4c81 2927 STRLEN elen = my_snprintf(PL_efloatbuf, PL_efloatsize, "%g", payload);
07bb61ac 2928 if ((IV)elen == -1) {
effb4c81 2929#ifdef NV_NAN
07bb61ac 2930 RETVAL = NV_NAN;
effb4c81 2931#else
9ec60511 2932 RETVAL = 0.0;
effb4c81
JH
2933 not_here("nan");
2934#endif
07bb61ac
JH
2935 } else {
2936 RETVAL = c99_nan(PL_efloatbuf);
2937 }
2938 }
7c7d45f1 2939#else
5716d070
JH
2940 not_here("nan");
2941#endif
7965edec
JH
2942 OUTPUT:
2943 RETVAL
2944
2945NV
2946jn(x,y)
2947 IV x
2948 NV y
2949 ALIAS:
2950 yn = 1
2951 CODE:
effb4c81 2952#ifdef NV_NAN
78a0541a 2953 RETVAL = NV_NAN;
effb4c81
JH
2954#else
2955 RETVAL = 0;
2956#endif
7965edec
JH
2957 switch (ix) {
2958 case 0:
5716d070 2959#ifdef bessel_jn
7f4bfd0b 2960 RETVAL = bessel_jn(x, y);
5716d070 2961#else
6b13befe
JH
2962 PERL_UNUSED_VAR(x);
2963 PERL_UNUSED_VAR(y);
7f4bfd0b 2964 not_here("jn");
5716d070 2965#endif
7965edec
JH
2966 break;
2967 case 1:
2968 default:
5716d070 2969#ifdef bessel_yn
7f4bfd0b 2970 RETVAL = bessel_yn(x, y);
5716d070 2971#else
6b13befe
JH
2972 PERL_UNUSED_VAR(x);
2973 PERL_UNUSED_VAR(y);
7f4bfd0b 2974 not_here("yn");
5716d070 2975#endif
7965edec
JH
2976 break;
2977 }
2978 OUTPUT:
2979 RETVAL
2980
2304df62 2981SysRet
1dfe7606 2982sigaction(sig, optaction, oldaction = 0)
2304df62 2983 int sig
1dfe7606 2984 SV * optaction
2304df62
AD
2985 POSIX::SigAction oldaction
2986 CODE:
30b42e09 2987#if defined(WIN32) || defined(NETWARE) || (defined(__amigaos4__) && defined(__NEWLIB__))
6dead956
GS
2988 RETVAL = not_here("sigaction");
2989#else
3a8a1642 2990# This code is really grody because we are trying to make the signal
2304df62
AD
2991# interface look beautiful, which is hard.
2992
2304df62 2993 {
1dfe7606 2994 POSIX__SigAction action;
f584eb2d 2995 GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV);
2304df62
AD
2996 struct sigaction act;
2997 struct sigaction oact;
1dfe7606 2998 sigset_t sset;
183bde56 2999 SV *osset_sv;
27c1a449 3000 sigset_t osset;
2304df62
AD
3001 POSIX__SigSet sigset;
3002 SV** svp;
1d81eac9 3003 SV** sigsvp;
3609ea0d 3004
516d25e8
SP
3005 if (sig < 0) {
3006 croak("Negative signals are not allowed");
3007 }
3008
1d81eac9 3009 if (sig == 0 && SvPOK(ST(0))) {
aa07b2f6 3010 const char *s = SvPVX_const(ST(0));
1d81eac9
JH
3011 int i = whichsig(s);
3012
61e2287f 3013 if (i < 0 && memBEGINs(s, SvCUR(ST(0)), "SIG"))
1d81eac9
JH
3014 i = whichsig(s + 3);
3015 if (i < 0) {
3016 if (ckWARN(WARN_SIGNAL))
3017 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
3018 "No such signal: SIG%s", s);
3019 XSRETURN_UNDEF;
3020 }
3021 else
3022 sig = i;
3023 }
3609ea0d
JH
3024#ifdef NSIG
3025 if (sig > NSIG) { /* NSIG - 1 is still okay. */
3026 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
3027 "No such signal: %d", sig);
3028 XSRETURN_UNDEF;
3029 }
3030#endif
1d81eac9
JH
3031 sigsvp = hv_fetch(GvHVn(siggv),
3032 PL_sig_name[sig],
3033 strlen(PL_sig_name[sig]),
3034 TRUE);
2304df62 3035
1dfe7606 3036 /* Check optaction and set action */
3037 if(SvTRUE(optaction)) {
3038 if(sv_isa(optaction, "POSIX::SigAction"))
3039 action = (HV*)SvRV(optaction);
3040 else
3041 croak("action is not of type POSIX::SigAction");
3042 }
3043 else {
3044 action=0;
3045 }
3046
3047 /* sigaction() is supposed to look atomic. In particular, any
3048 * signal handler invoked during a sigaction() call should
3049 * see either the old or the new disposition, and not something
3050 * in between. We use sigprocmask() to make it so.
3051 */
3052 sigfillset(&sset);
3053 RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
3054 if(RETVAL == -1)
15c0d34a 3055 XSRETURN_UNDEF;
1dfe7606 3056 ENTER;
3057 /* Restore signal mask no matter how we exit this block. */
f584eb2d 3058 osset_sv = newSVpvn((char *)(&osset), sizeof(sigset_t));
183bde56 3059 SAVEFREESV( osset_sv );
40b7a5f5 3060 SAVEDESTRUCTOR_X(restore_sigmask, osset_sv);
1dfe7606 3061
3062 RETVAL=-1; /* In case both oldaction and action are 0. */
3063
3064 /* Remember old disposition if desired. */
2304df62 3065 if (oldaction) {
19c9c2ee
DM
3066 int safe;
3067
017a3ce5 3068 svp = hv_fetchs(oldaction, "HANDLER", TRUE);
1dfe7606 3069 if(!svp)
3070 croak("Can't supply an oldaction without a HANDLER");
3071 if(SvTRUE(*sigsvp)) { /* TBD: what if "0"? */
3072 sv_setsv(*svp, *sigsvp);
3073 }
3074 else {
f584eb2d 3075 sv_setpvs(*svp, "DEFAULT");
1dfe7606 3076 }
3077 RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
6ca4bbc9
GG
3078 if(RETVAL == -1) {
3079 LEAVE;
15c0d34a 3080 XSRETURN_UNDEF;
6ca4bbc9 3081 }
1dfe7606 3082 /* Get back the mask. */
017a3ce5 3083 svp = hv_fetchs(oldaction, "MASK", TRUE);
1dfe7606 3084 if (sv_isa(*svp, "POSIX::SigSet")) {
92b39396 3085 sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
1dfe7606 3086 }
3087 else {
92b39396
NC
3088 sigset = (sigset_t *) allocate_struct(aTHX_ *svp,
3089 sizeof(sigset_t),
3090 "POSIX::SigSet");
1dfe7606 3091 }
3092 *sigset = oact.sa_mask;
3093
3094 /* Get back the flags. */
017a3ce5 3095 svp = hv_fetchs(oldaction, "FLAGS", TRUE);
1dfe7606 3096 sv_setiv(*svp, oact.sa_flags);
d36b6582 3097
19c9c2ee
DM
3098 /* Get back whether the old handler used safe signals;
3099 * i.e. it used Perl_csighandler[13] rather than
3100 * Perl_sighandler[13]
3101 */
9c71f2ee
DM
3102 safe =
3103#ifdef SA_SIGINFO
3104 (oact.sa_flags & SA_SIGINFO)
19c9c2ee
DM
3105 ? ( oact.sa_sigaction == PL_csighandler3p
3106#ifdef PERL_USE_3ARG_SIGHANDLER
3107 || oact.sa_sigaction == PL_csighandlerp
3108#endif
3109 )
9c71f2ee
DM
3110 :
3111#endif
3112 ( oact.sa_handler == PL_csighandler1p
19c9c2ee
DM
3113#ifndef PERL_USE_3ARG_SIGHANDLER
3114 || oact.sa_handler == PL_csighandlerp
3115#endif
9c71f2ee 3116 );
19c9c2ee 3117
017a3ce5 3118 svp = hv_fetchs(oldaction, "SAFE", TRUE);
19c9c2ee 3119 sv_setiv(*svp, safe);
2304df62
AD
3120 }
3121
3122 if (action) {
19c9c2ee
DM
3123 int safe;
3124
3125 /* Set up any desired flags. */
3126 svp = hv_fetchs(action, "FLAGS", FALSE);
3127 act.sa_flags = svp ? SvIV(*svp) : 0;
3128
d36b6582
CS
3129 /* Safe signals use "csighandler", which vectors through the
3130 PL_sighandlerp pointer when it's safe to do so.
3131 (BTW, "csighandler" is very different from "sighandler".) */
017a3ce5 3132 svp = hv_fetchs(action, "SAFE", FALSE);
19c9c2ee 3133 safe = *svp && SvTRUE(*svp);
9c71f2ee 3134#ifdef SA_SIGINFO
19c9c2ee
DM
3135 if (act.sa_flags & SA_SIGINFO) {
3136 /* 3-arg handler */
3137 act.sa_sigaction =
3138 safe ? PL_csighandler3p : PL_sighandler3p;
3139 }
9c71f2ee
DM
3140 else
3141#endif
3142 {
19c9c2ee
DM
3143 /* 1-arg handler */
3144 act.sa_handler =
3145 safe ? PL_csighandler1p : PL_sighandler1p;
3146 }
d36b6582
CS
3147
3148 /* Vector new Perl handler through %SIG.
3149 (The core signal handlers read %SIG to dispatch.) */
017a3ce5 3150 svp = hv_fetchs(action, "HANDLER", FALSE);
2304df62
AD
3151 if (!svp)
3152 croak("Can't supply an action without a HANDLER");
1dfe7606 3153 sv_setsv(*sigsvp, *svp);
d36b6582
CS
3154
3155 /* This call actually calls sigaction() with almost the
3156 right settings, including appropriate interpretation
3157 of DEFAULT and IGNORE. However, why are we doing
3158 this when we're about to do it again just below? XXX */
17cffb37 3159 SvSETMAGIC(*sigsvp);
d36b6582
CS
3160
3161 /* And here again we duplicate -- DEFAULT/IGNORE checking. */
1dfe7606 3162 if(SvPOK(*svp)) {
aa07b2f6 3163 const char *s=SvPVX_const(*svp);
1dfe7606 3164 if(strEQ(s,"IGNORE")) {
3165 act.sa_handler = SIG_IGN;
3166 }
3167 else if(strEQ(s,"DEFAULT")) {
3168 act.sa_handler = SIG_DFL;
3169 }
1dfe7606 3170 }
2304df62
AD
3171
3172 /* Set up any desired mask. */
017a3ce5 3173 svp = hv_fetchs(action, "MASK", FALSE);
2304df62 3174 if (svp && sv_isa(*svp, "POSIX::SigSet")) {
92b39396 3175 sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
2304df62
AD
3176 act.sa_mask = *sigset;
3177 }
3178 else
85e6fe83 3179 sigemptyset(& act.sa_mask);
2304df62 3180
1dfe7606 3181 /* Don't worry about cleaning up *sigsvp if this fails,
3182 * because that means we tried to disposition a
3183 * nonblockable signal, in which case *sigsvp is
3184 * essentially meaningless anyway.
3185 */
6c418a22 3186 RETVAL = sigaction(sig, & act, (struct sigaction *)0);
6ca4bbc9
GG
3187 if(RETVAL == -1) {
3188 LEAVE;
a7aad5de 3189 XSRETURN_UNDEF;
6ca4bbc9 3190 }
2304df62 3191 }
1dfe7606 3192
3193 LEAVE;
2304df62 3194 }
6dead956 3195#endif
2304df62
AD
3196 OUTPUT:
3197 RETVAL
3198
3199SysRet
3200sigpending(sigset)
3201 POSIX::SigSet sigset
7a004119
NC
3202 ALIAS:
3203 sigsuspend = 1
3204 CODE:
ea34f6bd 3205#ifdef __amigaos4__
30b42e09
AB
3206 RETVAL = not_here("sigpending");
3207#else
7a004119 3208 RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
32a14dd4 3209#endif
7a004119
NC
3210 OUTPUT:
3211 RETVAL
20120e59
LT
3212 CLEANUP:
3213 PERL_ASYNC_CHECK();
2304df62
AD
3214
3215SysRet
3216sigprocmask(how, sigset, oldsigset = 0)
3217 int how
b13bbac7 3218 POSIX::SigSet sigset = NO_INIT
33c27489
GS
3219 POSIX::SigSet oldsigset = NO_INIT
3220INIT:
a3b811a7 3221 if (! SvOK(ST(1))) {
b13bbac7 3222 sigset = NULL;
a3b811a7 3223 } else if (sv_isa(ST(1), "POSIX::SigSet")) {
92b39396 3224 sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1)));
b13bbac7
AB
3225 } else {
3226 croak("sigset is not of type POSIX::SigSet");
33c27489 3227 }
b13bbac7 3228
194cfca0 3229 if (items < 3 || ! SvOK(ST(2))) {
b13bbac7 3230 oldsigset = NULL;
a3b811a7 3231 } else if (sv_isa(ST(2), "POSIX::SigSet")) {
92b39396 3232 oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2)));
b13bbac7
AB
3233 } else {
3234 croak("oldsigset is not of type POSIX::SigSet");
33c27489 3235 }
2304df62 3236
2304df62
AD
3237void
3238_exit(status)
3239 int status
8990e307 3240
85e6fe83 3241SysRet
8990e307
LW
3242dup2(fd1, fd2)
3243 int fd1
3244 int fd2
ad413e46 3245 CODE:
6e7b1a26 3246 if (fd1 >= 0 && fd2 >= 0) {
ad413e46 3247#ifdef WIN32
6e7b1a26
JH
3248 /* RT #98912 - More Microsoft muppetry - failing to
3249 actually implemented the well known documented POSIX
3250 behaviour for a POSIX API.
3251 http://msdn.microsoft.com/en-us/library/8syseb29.aspx */
3252 RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2;
ad413e46 3253#else
6e7b1a26 3254 RETVAL = dup2(fd1, fd2);
ad413e46 3255#endif
6e7b1a26
JH
3256 } else {
3257 SETERRNO(EBADF,RMS_IFI);
3258 RETVAL = -1;
3259 }
ad413e46
NC
3260 OUTPUT:
3261 RETVAL
8990e307 3262
4a9d6100 3263SV *
a0d0e21e 3264lseek(fd, offset, whence)
ddc7c5c7 3265 POSIX::Fd fd
85e6fe83
LW
3266 Off_t offset
3267 int whence
4a9d6100 3268 CODE:
ddc7c5c7
JH
3269 {
3270 Off_t pos = PerlLIO_lseek(fd, offset, whence);
3271 RETVAL = sizeof(Off_t) > sizeof(IV)
3272 ? newSVnv((NV)pos) : newSViv((IV)pos);
511343a2 3273 }
4a9d6100
GS
3274 OUTPUT:
3275 RETVAL
8990e307 3276
c5661c80 3277void
8990e307
LW
3278nice(incr)
3279 int incr
15f0f28a
AE
3280 PPCODE:
3281 errno = 0;
3282 if ((incr = nice(incr)) != -1 || errno == 0) {
3283 if (incr == 0)
d3d34884 3284 XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP));
15f0f28a
AE
3285 else
3286 XPUSHs(sv_2mortal(newSViv(incr)));
3287 }
8990e307 3288
8063af02 3289void
8990e307 3290pipe()
85e6fe83
LW
3291 PPCODE:
3292 int fds[2];
85e6fe83 3293 if (pipe(fds) != -1) {
924508f0 3294 EXTEND(SP,2);
85e6fe83
LW
3295 PUSHs(sv_2mortal(newSViv(fds[0])));
3296 PUSHs(sv_2mortal(newSViv(fds[1])));
3297 }
8990e307 3298
85e6fe83 3299SysRet
a0d0e21e 3300read(fd, buffer, nbytes)
7747499c
TB
3301 PREINIT:
3302 SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3303 INPUT:
ddc7c5c7 3304 POSIX::Fd fd
7747499c
TB
3305 size_t nbytes
3306 char * buffer = sv_grow( sv_buffer, nbytes+1 );
a0d0e21e 3307 CLEANUP:
7747499c 3308 if (RETVAL >= 0) {
b162af07 3309 SvCUR_set(sv_buffer, RETVAL);
7747499c
TB
3310 SvPOK_only(sv_buffer);
3311 *SvEND(sv_buffer) = '\0';
bbce6d69 3312 SvTAINTED_on(sv_buffer);
7747499c 3313 }
8990e307 3314
85e6fe83 3315SysRet
8990e307 3316setpgid(pid, pgid)
86200d5c
JH
3317 pid_t pid
3318 pid_t pgid
8990e307 3319
86200d5c 3320pid_t
8990e307
LW
3321setsid()
3322
86200d5c 3323pid_t
8990e307 3324tcgetpgrp(fd)
ddc7c5c7 3325 POSIX::Fd fd
8990e307 3326
85e6fe83 3327SysRet
8990e307 3328tcsetpgrp(fd, pgrp_id)
ddc7c5c7 3329 POSIX::Fd fd
86200d5c 3330 pid_t pgrp_id
8990e307 3331
8063af02 3332void
8990e307 3333uname()
2304df62 3334 PPCODE:
a0d0e21e 3335#ifdef HAS_UNAME
85e6fe83 3336 struct utsname buf;
85e6fe83 3337 if (uname(&buf) >= 0) {
924508f0 3338 EXTEND(SP, 5);
d3d34884
NC
3339 PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP));
3340 PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP));
3341 PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP));
3342 PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP));
3343 PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP));
8990e307 3344 }
a0d0e21e
LW
3345#else
3346 uname((char *) 0); /* A stub to call not_here(). */
3347#endif
8990e307 3348
85e6fe83 3349SysRet
a0d0e21e 3350write(fd, buffer, nbytes)
ddc7c5c7 3351 POSIX::Fd fd
a0d0e21e
LW
3352 char * buffer
3353 size_t nbytes
3354
a0d0e21e
LW
3355void
3356abort()
3357
d2c9cb53
KW
3358#if defined(HAS_MBRLEN) && (defined(USE_ITHREADS) || ! defined(HAS_MBLEN))
3359# define USE_MBRLEN
3360#else
3361# undef USE_MBRLEN
6c9ff7e9
KW
3362#endif
3363
a0d0e21e 3364int
63bebc14 3365mblen(s, n = ~0)
d2c9cb53 3366 SV * s
a0d0e21e 3367 size_t n
6c9ff7e9 3368 CODE:
d2c9cb53 3369 errno = 0;
cc4f900e 3370
d2c9cb53
KW
3371 SvGETMAGIC(s);
3372 if (! SvOK(s)) {
3373#ifdef USE_MBRLEN
3374 /* Initialize the shift state in PL_mbrlen_ps. The Standard says
3375 * that should be all zeros. */
3376 memzero(&PL_mbrlen_ps, sizeof(PL_mbrlen_ps));
3377 RETVAL = 0;
3378#else
3379 LOCALE_LOCK;
3380 RETVAL = mblen(NULL, 0);
3381 LOCALE_UNLOCK;
6c9ff7e9 3382#endif
d2c9cb53
KW
3383 }
3384 else { /* Not resetting state */
3385 SV * byte_s = sv_2mortal(newSVsv_nomg(s));
3386 if (! sv_utf8_downgrade_nomg(byte_s, TRUE)) {
3387 SETERRNO(EINVAL, LIB_INVARG);
3388 RETVAL = -1;
3389 }
3390 else {
3391 size_t len;
3392 char * string = SvPV(byte_s, len);
63bebc14 3393 if (n < len) len = n;
d2c9cb53
KW
3394#ifdef USE_MBRLEN
3395 RETVAL = (SSize_t) mbrlen(string, len, &PL_mbrlen_ps);
3396 if (RETVAL < 0) RETVAL = -1; /* Use mblen() ret code for
3397 transparency */
3398#else
3399 /* Locking prevents races, but locales can be switched out
3400 * without locking, so this isn't a cure all */
3401 LOCALE_LOCK;
3402 RETVAL = mblen(string, len);
3403 LOCALE_UNLOCK;
3404#endif
3405 }
3406 }
6c9ff7e9
KW
3407 OUTPUT:
3408 RETVAL
a0d0e21e 3409
5a6637f0
KW
3410#if defined(HAS_MBRTOWC) && (defined(USE_ITHREADS) || ! defined(HAS_MBTOWC))
3411# define USE_MBRTOWC
3412#else
3413# undef USE_MBRTOWC
3414#endif
3415
a0d0e21e 3416int
5a6637f0
KW
3417mbtowc(pwc, s, n = ~0)
3418 SV * pwc
3419 SV * s
a0d0e21e 3420 size_t n
6de6aebd 3421 CODE:
6de6aebd 3422 errno = 0;
5a6637f0
KW
3423 SvGETMAGIC(s);
3424 if (! SvOK(s)) { /* Initialize state */
3425#ifdef USE_MBRTOWC
3426 /* Initialize the shift state to all zeros in PL_mbrtowc_ps. */
3427 memzero(&PL_mbrtowc_ps, sizeof(PL_mbrtowc_ps));
3428 RETVAL = 0;
3429#else
3430 LOCALE_LOCK;
3431 RETVAL = mbtowc(NULL, NULL, 0);
3432 LOCALE_UNLOCK;
3433#endif
3434 }
3435 else { /* Not resetting state */
3436 wchar_t wc;
3437 SV * byte_s = sv_2mortal(newSVsv_nomg(s));
3438 if (! sv_utf8_downgrade_nomg(byte_s, TRUE)) {
3439 SETERRNO(EINVAL, LIB_INVARG);
3440 RETVAL = -1;
3441 }
3442 else {
3443 size_t len;
3444 char * string = SvPV(byte_s, len);
3445 if (n < len) len = n;
3446#ifdef USE_MBRTOWC
3447 RETVAL = (SSize_t) mbrtowc(&wc, string, len, &PL_mbrtowc_ps);
6de6aebd 3448#else
5a6637f0
KW
3449 /* Locking prevents races, but locales can be switched out
3450 * without locking, so this isn't a cure all */
3451 LOCALE_LOCK;
3452 RETVAL = mbtowc(&wc, string, len);
3453 LOCALE_UNLOCK;
6de6aebd 3454#endif
5a6637f0
KW
3455 if (RETVAL >= 0) {
3456 sv_setiv_mg(pwc, wc);
3457 }
3458 else { /* Use mbtowc() ret code for transparency */
3459 RETVAL = -1;
3460 }
3461 }
3462 }
6de6aebd
KW
3463 OUTPUT:
3464 RETVAL
a0d0e21e 3465
5a6637f0
KW
3466#if defined(HAS_WCRTOMB) && (defined(USE_ITHREADS) || ! defined(HAS_WCTOMB))
3467# define USE_WCRTOMB
3468#else
3469# undef USE_WCRTOMB
3470#endif
3471
a0d0e21e 3472int
a0d0e21e 3473wctomb(s, wchar)
5a6637f0 3474 SV * s
a0d0e21e 3475 wchar_t wchar
5a6637f0
KW
3476 CODE:
3477 errno = 0;
3478 SvGETMAGIC(s);
3479 if (s == &PL_sv_undef) {
3480#ifdef USE_WCRTOMB
3481 /* The man pages khw looked at are in agreement that this works.
3482 * But probably memzero would too */
3483 RETVAL = wcrtomb(NULL, L'\0', &PL_wcrtomb_ps);
3484#else
3485 LOCALE_LOCK;
3486 RETVAL = wctomb(NULL, L'\0');
3487 LOCALE_UNLOCK;
3488#endif
3489 }
3490 else { /* Not resetting state */
3491 char buffer[MB_LEN_MAX];
3492#ifdef USE_WCRTOMB
3493 RETVAL = wcrtomb(buffer, wchar, &PL_wcrtomb_ps);
3494#else
3495 /* Locking prevents races, but locales can be switched out without
3496 * locking, so this isn't a cure all */
3497 LOCALE_LOCK;
3498 RETVAL = wctomb(buffer, wchar);
3499 LOCALE_UNLOCK;
3500#endif
3501 if (RETVAL >= 0) {
3502 sv_setpvn_mg(s, buffer, RETVAL);
3503 }
3504 }
3505 OUTPUT:
3506 RETVAL
a0d0e21e
LW
3507
3508int
3509strcoll(s1, s2)
3510 char * s1
3511 char * s2
3512
a89d8a78
DH
3513void
3514strtod(str)
3515 char * str
3516 PREINIT:
3517 double num;
3518 char *unparsed;
3519 PPCODE:
67d796ae
KW
3520 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3521 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
a89d8a78 3522 num = strtod(str, &unparsed);
9efd8fe5 3523 RESTORE_LC_NUMERIC();
a89d8a78 3524 PUSHs(sv_2mortal(newSVnv(num)));
de915ff5 3525 if (GIMME_V == G_ARRAY) {
924508f0 3526 EXTEND(SP, 1);
a89d8a78
DH
3527 if (unparsed)
3528 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3529 else
6b88bc9c 3530 PUSHs(&PL_sv_undef);
a89d8a78
DH
3531 }
3532
0ff7b9da
JH
3533#ifdef HAS_STRTOLD
3534
3535void
3536strtold(str)
3537 char * str
3538 PREINIT:
3539 long double num;
3540 char *unparsed;
3541 PPCODE:
67d796ae
KW
3542 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3543 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
0ff7b9da 3544 num = strtold(str, &unparsed);
9efd8fe5 3545 RESTORE_LC_NUMERIC();
0ff7b9da 3546 PUSHs(sv_2mortal(newSVnv(num)));
de915ff5 3547 if (GIMME_V == G_ARRAY) {
0ff7b9da
JH
3548 EXTEND(SP, 1);
3549 if (unparsed)
3550 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3551 else
3552 PUSHs(&PL_sv_undef);
3553 }
0ff7b9da
JH
3554
3555#endif
3556
a89d8a78
DH
3557void
3558strtol(str, base = 0)
3559 char * str
3560 int base
3561 PREINIT:
3562 long num;
3563 char *unparsed;
3564 PPCODE:
b2b47eff 3565 if (base == 0 || inRANGE(base, 2, 36)) {
e80fee22 3566 num = strtol(str, &unparsed, base);
188f97e0 3567#if IVSIZE < LONGSIZE
e80fee22
JH
3568 if (num < IV_MIN || num > IV_MAX)
3569 PUSHs(sv_2mortal(newSVnv((double)num)));
3570 else
3571#endif
3572 PUSHs(sv_2mortal(newSViv((IV)num)));
3573 if (GIMME_V == G_ARRAY) {
3574 EXTEND(SP, 1);
3575 if (unparsed)
3576 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3577 else
3578 PUSHs(&PL_sv_undef);
3579 }
3580 } else {
3581 SETERRNO(EINVAL, LIB_INVARG);
3582 PUSHs(&PL_sv_undef);
3583 if (GIMME_V == G_ARRAY) {
3584 EXTEND(SP, 1);
3585 PUSHs(&PL_sv_undef);
3586 }
3587 }
a89d8a78
DH
3588
3589void
3590strtoul(str, base = 0)
4b48cf39 3591 const char * str
a89d8a78
DH
3592 int base
3593 PREINIT:
3594 unsigned long num;
1cafb023 3595 char *unparsed = NULL;
a89d8a78 3596 PPCODE:
0f17be83
JH
3597 PERL_UNUSED_VAR(str);
3598 PERL_UNUSED_VAR(base);
b2b47eff 3599 if (base == 0 || inRANGE(base, 2, 36)) {
e80fee22 3600 num = strtoul(str, &unparsed, base);
84c133a0 3601#if IVSIZE <= LONGSIZE
e80fee22
JH
3602 if (num > IV_MAX)
3603 PUSHs(sv_2mortal(newSVnv((double)num)));
3604 else
3605#endif
3606 PUSHs(sv_2mortal(newSViv((IV)num)));
3607 if (GIMME_V == G_ARRAY) {
3608 EXTEND(SP, 1);
3609 if (unparsed)
3610 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3611 else
3612 PUSHs(&PL_sv_undef);
3613 }
3614 } else {
3615 SETERRNO(EINVAL, LIB_INVARG);
3616 PUSHs(&PL_sv_undef);
3617 if (GIMME_V == G_ARRAY) {
3618 EXTEND(SP, 1);