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