This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move bulk of POSIX::setlocale to locale.c
[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
147e3846 1217 Perl_warn(aTHX_ "t1 = %" NVgf " (payload %" NVgf ")\n", t1, payload);
07bb61ac
JH
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++) {
147e3846 1247 Perl_warn(aTHX_ "a[%d] = 0x%" UVxf "\n", i, a[i]);
07bb61ac
JH
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
147e3846
KW
1258 Perl_warn(aTHX_
1259 "set p[%2d] = %02x (i = %d, m = %02x, s = %2d, b = %02x, u = %08"
1260 UVxf ")\n", i, ((U8 *)(nvp))[i], i, m[i], s, b, u);
07bb61ac
JH
1261#endif
1262 a[p[i] / UVSIZE] &= ~u;
1263 }
1264 }
1265 if (signaling) {
1266 NV_NAN_SET_SIGNALING(nvp);
1267 }
1268#ifdef USE_LONG_DOUBLE
1269# if LONG_DOUBLEKIND == 3 || LONG_DOUBLEKIND == 4
2f125fcc 1270# if LONG_DOUBLESIZE > 10
07bb61ac 1271 memset((char *)nvp + 10, '\0', LONG_DOUBLESIZE - 10); /* x86 long double */
2f125fcc 1272# endif
07bb61ac
JH
1273# endif
1274#endif
1275 for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) {
1276 if (a[i]) {
147e3846 1277 Perl_warn(aTHX_ "payload lost bits (%" UVxf ")", a[i]);
07bb61ac
JH
1278 break;
1279 }
1280 }
1281#ifdef NV_PAYLOAD_DEBUG
1282 for (i = 0; i < NVSIZE; i++) {
1283 PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(nvp))[i]);
1284 }
1285 PerlIO_printf(Perl_debug_log, "\n");
1286#endif
1287}
1288
1289static NV_PAYLOAD_TYPE S_getpayload(NV nv)
1290{
1291 dTHX;
1292 static const U8 m[] = { NV_NAN_PAYLOAD_MASK };
1293 static const U8 p[] = { NV_NAN_PAYLOAD_PERM };
1294 UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 };
1295 int i;
1296 NV payload;
1297 NV_PAYLOAD_SIZEOF_ASSERT(m);
1298 NV_PAYLOAD_SIZEOF_ASSERT(p);
1299 payload = 0;
1300 for (i = 0; i < (int)sizeof(p); i++) {
1301 if (m[i] && p[i] < NVSIZE) {
1302 U8 s = (p[i] % UVSIZE) << 3;
1303 a[p[i] / UVSIZE] |= (UV)(((U8 *)(&nv))[i] & m[i]) << s;
1304 }
1305 }
1306 for (i = (int)C_ARRAY_LENGTH(a) - 1; i >= 0; i--) {
1307#ifdef NV_PAYLOAD_DEBUG
147e3846 1308 Perl_warn(aTHX_ "a[%d] = %" UVxf "\n", i, a[i]);
07bb61ac
JH
1309#endif
1310 payload *= UV_MAX;
1311 payload += a[i];
1312 }
1313#ifdef NV_PAYLOAD_DEBUG
1314 for (i = 0; i < NVSIZE; i++) {
1315 PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(&nv))[i]);
1316 }
1317 PerlIO_printf(Perl_debug_log, "\n");
1318#endif
1319 return payload;
1320}
1321
effb4c81
JH
1322#endif /* #ifdef NV_NAN */
1323
3609ea0d 1324/* XXX This comment is just to make I_TERMIO and I_SGTTY visible to
a0d0e21e
LW
1325 metaconfig for future extension writers. We don't use them in POSIX.
1326 (This is really sneaky :-) --AD
1327*/
1328#if defined(I_TERMIOS)
1329#include <termios.h>
1330#endif
a0d0e21e 1331#ifdef I_STDLIB
2304df62 1332#include <stdlib.h>
a0d0e21e 1333#endif
5518ecd4 1334#ifndef __ultrix__
2304df62 1335#include <string.h>
5518ecd4 1336#endif
2304df62 1337#include <sys/stat.h>
2304df62 1338#include <sys/types.h>
2304df62 1339#include <time.h>
6dead956 1340#ifdef I_UNISTD
1d2dff63 1341#include <unistd.h>
6dead956 1342#endif
71be2cbc
PP
1343#include <fcntl.h>
1344
e2465f50 1345#ifdef HAS_TZNAME
fb207d52 1346# if !defined(WIN32) && !defined(__CYGWIN__) && !defined(NETWARE) && !defined(__UWIN__)
e2465f50
JH
1347extern char *tzname[];
1348# endif
1349#else
fb207d52 1350#if !defined(WIN32) && !defined(__UWIN__) || (defined(__MINGW32__) && !defined(tzname))
e2465f50
JH
1351char *tzname[] = { "" , "" };
1352#endif
cb2479a8
JH
1353#endif
1354
6c418a22 1355#if defined(__VMS) && !defined(__POSIX_SOURCE)
294c8bc4
CB
1356
1357# include <utsname.h>
6c418a22 1358
6990d991 1359# undef mkfifo
6c418a22 1360# define mkfifo(a,b) (not_here("mkfifo"),-1)
6c418a22
PP
1361
1362 /* The POSIX notion of ttyname() is better served by getname() under VMS */
1363 static char ttnambuf[64];
1364# define ttyname(fd) (isatty(fd) > 0 ? getname(fd,ttnambuf,0) : NULL)
1365
6c418a22 1366#else
d308986b 1367#if defined (__CYGWIN__)
f89d6eaa
FE
1368# define tzname _tzname
1369#endif
2986a63f 1370#if defined (WIN32) || defined (NETWARE)
6990d991 1371# undef mkfifo
6dead956 1372# define mkfifo(a,b) not_here("mkfifo")
873ef191 1373# define ttyname(a) (char*)not_here("ttyname")
6dead956 1374# define sigset_t long
86200d5c 1375# define pid_t long
6dead956
GS
1376# ifdef _MSC_VER
1377# define mode_t short
1378# endif
62520c91
GS
1379# ifdef __MINGW32__
1380# define mode_t short
f6c6487a
GS
1381# ifndef tzset
1382# define tzset() not_here("tzset")
1383# endif
1384# ifndef _POSIX_OPEN_MAX
1385# define _POSIX_OPEN_MAX FOPEN_MAX /* XXX bogus ? */
1386# endif
62520c91 1387# endif
6dead956
GS
1388# define sigaction(a,b,c) not_here("sigaction")
1389# define sigpending(a) not_here("sigpending")
1390# define sigprocmask(a,b,c) not_here("sigprocmask")
1391# define sigsuspend(a) not_here("sigsuspend")
1392# define sigemptyset(a) not_here("sigemptyset")
1393# define sigaddset(a,b) not_here("sigaddset")
1394# define sigdelset(a,b) not_here("sigdelset")
1395# define sigfillset(a) not_here("sigfillset")
1396# define sigismember(a,b) not_here("sigismember")
2986a63f 1397#ifndef NETWARE
6e22d046
JH
1398# undef setuid
1399# undef setgid
2986a63f
JH
1400# define setuid(a) not_here("setuid")
1401# define setgid(a) not_here("setgid")
1402#endif /* NETWARE */
d172007e 1403#ifndef USE_LONG_DOUBLE
73e21afd 1404# define strtold(s1,s2) not_here("strtold")
d172007e 1405#endif /* USE_LONG_DOUBLE */
6dead956 1406#else
6990d991
JH
1407
1408# ifndef HAS_MKFIFO
b3599c2e 1409# if defined(OS2) || defined(__amigaos4__)
d6a255e6 1410# define mkfifo(a,b) not_here("mkfifo")
3609ea0d 1411# else /* !( defined OS2 ) */
d6a255e6
IZ
1412# ifndef mkfifo
1413# define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0))
1414# endif
6990d991
JH
1415# endif
1416# endif /* !HAS_MKFIFO */
1417
e37778c2
NC
1418# ifdef I_GRP
1419# include <grp.h>
1420# endif
1421# include <sys/times.h>
1422# ifdef HAS_UNAME
1423# include <sys/utsname.h>
6c418a22 1424# endif
ea34f6bd
AB
1425# ifndef __amigaos4__
1426# include <sys/wait.h>
1427# endif
6c418a22
PP
1428# ifdef I_UTIME
1429# include <utime.h>
1430# endif
2986a63f 1431#endif /* WIN32 || NETWARE */
6dead956 1432#endif /* __VMS */
2304df62
AD
1433
1434typedef int SysRet;
a0d0e21e 1435typedef long SysRetLong;
2304df62
AD
1436typedef sigset_t* POSIX__SigSet;
1437typedef HV* POSIX__SigAction;
69b5fd06 1438typedef int POSIX__SigNo;
ddc7c5c7 1439typedef int POSIX__Fd;
a0d0e21e
LW
1440#ifdef I_TERMIOS
1441typedef struct termios* POSIX__Termios;
1442#else /* Define termios types to int, and call not_here for the functions.*/
1443#define POSIX__Termios int
1444#define speed_t int
1445#define tcflag_t int
1446#define cc_t int
1447#define cfgetispeed(x) not_here("cfgetispeed")
1448#define cfgetospeed(x) not_here("cfgetospeed")
1449#define tcdrain(x) not_here("tcdrain")
1450#define tcflush(x,y) not_here("tcflush")
1451#define tcsendbreak(x,y) not_here("tcsendbreak")
1452#define cfsetispeed(x,y) not_here("cfsetispeed")
1453#define cfsetospeed(x,y) not_here("cfsetospeed")
1454#define ctermid(x) (char *) not_here("ctermid")
1455#define tcflow(x,y) not_here("tcflow")
1456#define tcgetattr(x,y) not_here("tcgetattr")
1457#define tcsetattr(x,y,z) not_here("tcsetattr")
1458#endif
1459
1460/* Possibly needed prototypes */
6e22d046 1461#ifndef WIN32
a2e65780 1462START_EXTERN_C
20ce7b12
GS
1463double strtod (const char *, char **);
1464long strtol (const char *, char **, int);
1465unsigned long strtoul (const char *, char **, int);
0ff7b9da
JH
1466#ifdef HAS_STRTOLD
1467long double strtold (const char *, char **);
1468#endif
a2e65780 1469END_EXTERN_C
6e22d046 1470#endif
a0d0e21e 1471
a0d0e21e
LW
1472#ifndef HAS_DIFFTIME
1473#ifndef difftime
1474#define difftime(a,b) not_here("difftime")
1475#endif
1476#endif
1477#ifndef HAS_FPATHCONF
3609ea0d 1478#define fpathconf(f,n) (SysRetLong) not_here("fpathconf")
a0d0e21e
LW
1479#endif
1480#ifndef HAS_MKTIME
1481#define mktime(a) not_here("mktime")
8990e307
LW
1482#endif
1483#ifndef HAS_NICE
1484#define nice(a) not_here("nice")
1485#endif
a0d0e21e 1486#ifndef HAS_PATHCONF
3609ea0d 1487#define pathconf(f,n) (SysRetLong) not_here("pathconf")
a0d0e21e
LW
1488#endif
1489#ifndef HAS_SYSCONF
3609ea0d 1490#define sysconf(n) (SysRetLong) not_here("sysconf")
a0d0e21e 1491#endif
8990e307
LW
1492#ifndef HAS_READLINK
1493#define readlink(a,b,c) not_here("readlink")
1494#endif
1495#ifndef HAS_SETPGID
1496#define setpgid(a,b) not_here("setpgid")
1497#endif
8990e307
LW
1498#ifndef HAS_SETSID
1499#define setsid() not_here("setsid")
1500#endif
a0d0e21e
LW
1501#ifndef HAS_STRCOLL
1502#define strcoll(s1,s2) not_here("strcoll")
1503#endif
a89d8a78
DH
1504#ifndef HAS_STRTOD
1505#define strtod(s1,s2) not_here("strtod")
1506#endif
0ff7b9da
JH
1507#ifndef HAS_STRTOLD
1508#define strtold(s1,s2) not_here("strtold")
1509#endif
a89d8a78
DH
1510#ifndef HAS_STRTOL
1511#define strtol(s1,s2,b) not_here("strtol")
1512#endif
1513#ifndef HAS_STRTOUL
1514#define strtoul(s1,s2,b) not_here("strtoul")
1515#endif
a0d0e21e
LW
1516#ifndef HAS_STRXFRM
1517#define strxfrm(s1,s2,n) not_here("strxfrm")
8990e307
LW
1518#endif
1519#ifndef HAS_TCGETPGRP
1520#define tcgetpgrp(a) not_here("tcgetpgrp")
1521#endif
1522#ifndef HAS_TCSETPGRP
1523#define tcsetpgrp(a,b) not_here("tcsetpgrp")
1524#endif
1525#ifndef HAS_TIMES
2986a63f 1526#ifndef NETWARE
8990e307 1527#define times(a) not_here("times")
2986a63f 1528#endif /* NETWARE */
8990e307
LW
1529#endif
1530#ifndef HAS_UNAME
1531#define uname(a) not_here("uname")
1532#endif
1533#ifndef HAS_WAITPID
1534#define waitpid(a,b,c) not_here("waitpid")
1535#endif
1536
a0d0e21e
LW
1537#ifndef HAS_MBLEN
1538#ifndef mblen
1539#define mblen(a,b) not_here("mblen")
1540#endif
1541#endif
1542#ifndef HAS_MBSTOWCS
1543#define mbstowcs(s, pwcs, n) not_here("mbstowcs")
1544#endif
1545#ifndef HAS_MBTOWC
1546#define mbtowc(pwc, s, n) not_here("mbtowc")
1547#endif
1548#ifndef HAS_WCSTOMBS
1549#define wcstombs(s, pwcs, n) not_here("wcstombs")
1550#endif
1551#ifndef HAS_WCTOMB
1552#define wctomb(s, wchar) not_here("wcstombs")
1553#endif
1554#if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB)
1555/* If we don't have these functions, then we wouldn't have gotten a typedef
1556 for wchar_t, the wide character type. Defining wchar_t allows the
1557 functions referencing it to compile. Its actual type is then meaningless,
1558 since without the above functions, all sections using it end up calling
1559 not_here() and croak. --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */
1560#ifndef wchar_t
1561#define wchar_t char
1562#endif
1563#endif
1564
3f3bcbfc
KW
1565#ifndef HAS_LOCALECONV
1566# define localeconv() not_here("localeconv")
1567#else
2f0945cb
NC
1568struct lconv_offset {
1569 const char *name;
1570 size_t offset;
1571};
1572
0b057af7 1573static const struct lconv_offset lconv_strings[] = {
03ceeedf 1574#ifdef USE_LOCALE_NUMERIC
3800c318
JH
1575 {"decimal_point", STRUCT_OFFSET(struct lconv, decimal_point)},
1576 {"thousands_sep", STRUCT_OFFSET(struct lconv, thousands_sep)},
03ceeedf 1577# ifndef NO_LOCALECONV_GROUPING
3800c318 1578 {"grouping", STRUCT_OFFSET(struct lconv, grouping)},
03ceeedf 1579# endif
2f0945cb 1580#endif
03ceeedf 1581#ifdef USE_LOCALE_MONETARY
3800c318
JH
1582 {"int_curr_symbol", STRUCT_OFFSET(struct lconv, int_curr_symbol)},
1583 {"currency_symbol", STRUCT_OFFSET(struct lconv, currency_symbol)},
1584 {"mon_decimal_point", STRUCT_OFFSET(struct lconv, mon_decimal_point)},
03ceeedf 1585# ifndef NO_LOCALECONV_MON_THOUSANDS_SEP
3800c318 1586 {"mon_thousands_sep", STRUCT_OFFSET(struct lconv, mon_thousands_sep)},
03ceeedf
KW
1587# endif
1588# ifndef NO_LOCALECONV_MON_GROUPING
3800c318 1589 {"mon_grouping", STRUCT_OFFSET(struct lconv, mon_grouping)},
03ceeedf 1590# endif
3800c318
JH
1591 {"positive_sign", STRUCT_OFFSET(struct lconv, positive_sign)},
1592 {"negative_sign", STRUCT_OFFSET(struct lconv, negative_sign)},
03ceeedf 1593#endif
2f0945cb
NC
1594 {NULL, 0}
1595};
1596
c1284011
KW
1597#ifdef USE_LOCALE_NUMERIC
1598
1599/* The Linux man pages say these are the field names for the structure
1600 * components that are LC_NUMERIC; the rest being LC_MONETARY */
f33b12f3
JH
1601# define isLC_NUMERIC_STRING(name) (strEQ(name, "decimal_point") \
1602 || strEQ(name, "thousands_sep") \
c1284011
KW
1603 \
1604 /* There should be no harm done \
1605 * checking for this, even if \
1606 * NO_LOCALECONV_GROUPING */ \
f33b12f3 1607 || strEQ(name, "grouping"))
c1284011
KW
1608#else
1609# define isLC_NUMERIC_STRING(name) (0)
1610#endif
1611
0b057af7 1612static const struct lconv_offset lconv_integers[] = {
03ceeedf 1613#ifdef USE_LOCALE_MONETARY
3800c318
JH
1614 {"int_frac_digits", STRUCT_OFFSET(struct lconv, int_frac_digits)},
1615 {"frac_digits", STRUCT_OFFSET(struct lconv, frac_digits)},
1616 {"p_cs_precedes", STRUCT_OFFSET(struct lconv, p_cs_precedes)},
1617 {"p_sep_by_space", STRUCT_OFFSET(struct lconv, p_sep_by_space)},
1618 {"n_cs_precedes", STRUCT_OFFSET(struct lconv, n_cs_precedes)},
1619 {"n_sep_by_space", STRUCT_OFFSET(struct lconv, n_sep_by_space)},
1620 {"p_sign_posn", STRUCT_OFFSET(struct lconv, p_sign_posn)},
1621 {"n_sign_posn", STRUCT_OFFSET(struct lconv, n_sign_posn)},
b15c1b56
AF
1622#ifdef HAS_LC_MONETARY_2008
1623 {"int_p_cs_precedes", STRUCT_OFFSET(struct lconv, int_p_cs_precedes)},
1624 {"int_p_sep_by_space", STRUCT_OFFSET(struct lconv, int_p_sep_by_space)},
1625 {"int_n_cs_precedes", STRUCT_OFFSET(struct lconv, int_n_cs_precedes)},
1626 {"int_n_sep_by_space", STRUCT_OFFSET(struct lconv, int_n_sep_by_space)},
1627 {"int_p_sign_posn", STRUCT_OFFSET(struct lconv, int_p_sign_posn)},
1628 {"int_n_sign_posn", STRUCT_OFFSET(struct lconv, int_n_sign_posn)},
1629#endif
03ceeedf 1630#endif
2f0945cb
NC
1631 {NULL, 0}
1632};
1633
3f3bcbfc 1634#endif /* HAS_LOCALECONV */
a0d0e21e 1635
172ea7c8 1636#ifdef HAS_LONG_DOUBLE
53796371 1637# if LONG_DOUBLESIZE > NVSIZE
172ea7c8
JH
1638# undef HAS_LONG_DOUBLE /* XXX until we figure out how to use them */
1639# endif
1640#endif
1641
1642#ifndef HAS_LONG_DOUBLE
1643#ifdef LDBL_MAX
1644#undef LDBL_MAX
1645#endif
1646#ifdef LDBL_MIN
1647#undef LDBL_MIN
1648#endif
1649#ifdef LDBL_EPSILON
1650#undef LDBL_EPSILON
1651#endif
1652#endif
1653
ec193bec
JH
1654/* Background: in most systems the low byte of the wait status
1655 * is the signal (the lowest 7 bits) and the coredump flag is
1656 * the eight bit, and the second lowest byte is the exit status.
1657 * BeOS bucks the trend and has the bytes in different order.
1658 * See beos/beos.c for how the reality is bent even in BeOS
1659 * to follow the traditional. However, to make the POSIX
1660 * wait W*() macros to work in BeOS, we need to unbend the
1661 * reality back in place. --jhi */
17028706
IW
1662/* In actual fact the code below is to blame here. Perl has an internal
1663 * representation of the exit status ($?), which it re-composes from the
1664 * OS's representation using the W*() POSIX macros. The code below
1665 * incorrectly uses the W*() macros on the internal representation,
1666 * which fails for OSs that have a different representation (namely BeOS
1667 * and Haiku). WMUNGE() is a hack that converts the internal
1668 * representation into the OS specific one, so that the W*() macros work
1669 * as expected. The better solution would be not to use the W*() macros
1670 * in the first place, though. -- Ingo Weinhold
1671 */
b6c36746 1672#if defined(__HAIKU__)
ec193bec
JH
1673# define WMUNGE(x) (((x) & 0xFF00) >> 8 | ((x) & 0x00FF) << 8)
1674#else
1675# define WMUNGE(x) (x)
1676#endif
1677
8990e307 1678static int
4b48cf39 1679not_here(const char *s)
8990e307
LW
1680{
1681 croak("POSIX::%s not implemented on this architecture", s);
1682 return -1;
1683}
463ee0b2 1684
1cb0fb50 1685#include "const-c.inc"
a290f238 1686
1dfe7606 1687static void
40b7a5f5 1688restore_sigmask(pTHX_ SV *osset_sv)
1dfe7606 1689{
7feb700b
JH
1690 /* Fortunately, restoring the signal mask can't fail, because
1691 * there's nothing we can do about it if it does -- we're not
1692 * supposed to return -1 from sigaction unless the disposition
1693 * was unaffected.
1694 */
30b42e09 1695#if !(defined(__amigaos4__) && defined(__NEWLIB__))
7feb700b
JH
1696 sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv );
1697 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
30b42e09 1698#endif
1dfe7606 1699}
1700
a2261f90
NC
1701static void *
1702allocate_struct(pTHX_ SV *rv, const STRLEN size, const char *packname) {
1703 SV *const t = newSVrv(rv, packname);
1704 void *const p = sv_grow(t, size + 1);
1705
706d6f2a
DM
1706 /* Ensure at least one use of not_here() to avoid "defined but not
1707 * used" warning. This is not at all related to allocate_struct(); I
1708 * just needed somewhere to dump it - DAPM */
1709 if (0) { not_here(""); }
1710
a2261f90
NC
1711 SvCUR_set(t, size);
1712 SvPOK_on(t);
1713 return p;
1714}
1715
81ab4c44
SH
1716#ifdef WIN32
1717
1718/*
1719 * (1) The CRT maintains its own copy of the environment, separate from
1720 * the Win32API copy.
1721 *
1722 * (2) CRT getenv() retrieves from this copy. CRT putenv() updates this
1723 * copy, and then calls SetEnvironmentVariableA() to update the Win32API
1724 * copy.
1725 *
1726 * (3) win32_getenv() and win32_putenv() call GetEnvironmentVariableA() and
1727 * SetEnvironmentVariableA() directly, bypassing the CRT copy of the
1728 * environment.
1729 *
1730 * (4) The CRT strftime() "%Z" implementation calls __tzset(). That
1731 * calls CRT tzset(), but only the first time it is called, and in turn
1732 * that uses CRT getenv("TZ") to retrieve the timezone info from the CRT
1733 * local copy of the environment and hence gets the original setting as
1734 * perl never updates the CRT copy when assigning to $ENV{TZ}.
1735 *
1736 * Therefore, we need to retrieve the value of $ENV{TZ} and call CRT
1737 * putenv() to update the CRT copy of the environment (if it is different)
1738 * whenever we're about to call tzset().
1739 *
1740 * In addition to all that, when perl is built with PERL_IMPLICIT_SYS
1741 * defined:
1742 *
1743 * (a) Each interpreter has its own copy of the environment inside the
1744 * perlhost structure. That allows applications that host multiple
1745 * independent Perl interpreters to isolate environment changes from
1746 * each other. (This is similar to how the perlhost mechanism keeps a
1747 * separate working directory for each Perl interpreter, so that calling
1748 * chdir() will not affect other interpreters.)
1749 *
1750 * (b) Only the first Perl interpreter instantiated within a process will
1751 * "write through" environment changes to the process environment.
1752 *
1753 * (c) Even the primary Perl interpreter won't update the CRT copy of the
1754 * the environment, only the Win32API copy (it calls win32_putenv()).
1755 *
1756 * As with CPerlHost::Getenv() and CPerlHost::Putenv() themselves, it makes
1757 * sense to only update the process environment when inside the main
1758 * interpreter, but we don't have access to CPerlHost's m_bTopLevel member
1759 * from here so we'll just have to check PL_curinterp instead.
1760 *
1761 * Therefore, we can simply #undef getenv() and putenv() so that those names
1762 * always refer to the CRT functions, and explicitly call win32_getenv() to
1763 * access perl's %ENV.
1764 *
1765 * We also #undef malloc() and free() to be sure we are using the CRT
1766 * functions otherwise under PERL_IMPLICIT_SYS they are redefined to calls
1767 * into VMem::Malloc() and VMem::Free() and all allocations will be freed
1768 * when the Perl interpreter is being destroyed so we'd end up with a pointer
1769 * into deallocated memory in environ[] if a program embedding a Perl
1770 * interpreter continues to operate even after the main Perl interpreter has
1771 * been destroyed.
1772 *
1773 * Note that we don't free() the malloc()ed memory unless and until we call
1774 * malloc() again ourselves because the CRT putenv() function simply puts its
b7b1e41b 1775 * pointer argument into the environ[] array (it doesn't make a copy of it)
81ab4c44
SH
1776 * so this memory must otherwise be leaked.
1777 */
1778
1779#undef getenv
1780#undef putenv
1781#undef malloc
1782#undef free
1783
1784static void
1785fix_win32_tzenv(void)
1786{
1787 static char* oldenv = NULL;
1788 char* newenv;
1789 const char* perl_tz_env = win32_getenv("TZ");
1790 const char* crt_tz_env = getenv("TZ");
1791 if (perl_tz_env == NULL)
1792 perl_tz_env = "";
1793 if (crt_tz_env == NULL)
1794 crt_tz_env = "";
1795 if (strcmp(perl_tz_env, crt_tz_env) != 0) {
1796 newenv = (char*)malloc((strlen(perl_tz_env) + 4) * sizeof(char));
1797 if (newenv != NULL) {
1798 sprintf(newenv, "TZ=%s", perl_tz_env);
1799 putenv(newenv);
1800 if (oldenv != NULL)
1801 free(oldenv);
1802 oldenv = newenv;
1803 }
1804 }
1805}
1806
1807#endif
1808
1809/*
1810 * my_tzset - wrapper to tzset() with a fix to make it work (better) on Win32.
1811 * This code is duplicated in the Time-Piece module, so any changes made here
1812 * should be made there too.
1813 */
1814static void
1815my_tzset(pTHX)
1816{
1817#ifdef WIN32
1818#if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
1819 if (PL_curinterp == aTHX)
1820#endif
1821 fix_win32_tzenv();
1822#endif
1823 tzset();
1824}
1825
2304df62
AD
1826MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig
1827
92b39396 1828void
2304df62 1829new(packname = "POSIX::SigSet", ...)
d3f5e399 1830 const char * packname
2304df62
AD
1831 CODE:
1832 {
1833 int i;
92b39396
NC
1834 sigset_t *const s
1835 = (sigset_t *) allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
1836 sizeof(sigset_t),
1837 packname);
1838 sigemptyset(s);
a0d0e21e 1839 for (i = 1; i < items; i++)
92b39396
NC
1840 sigaddset(s, SvIV(ST(i)));
1841 XSRETURN(1);
2304df62 1842 }
2304df62
AD
1843
1844SysRet
df6c2df2 1845addset(sigset, sig)
2304df62 1846 POSIX::SigSet sigset
69b5fd06 1847 POSIX::SigNo sig
df6c2df2
NC
1848 ALIAS:
1849 delset = 1
1850 CODE:
1851 RETVAL = ix ? sigdelset(sigset, sig) : sigaddset(sigset, sig);
1852 OUTPUT:
1853 RETVAL
2304df62
AD
1854
1855SysRet
df6c2df2 1856emptyset(sigset)
2304df62 1857 POSIX::SigSet sigset
df6c2df2
NC
1858 ALIAS:
1859 fillset = 1
1860 CODE:
1861 RETVAL = ix ? sigfillset(sigset) : sigemptyset(sigset);
1862 OUTPUT:
1863 RETVAL
2304df62
AD
1864
1865int
1866sigismember(sigset, sig)
1867 POSIX::SigSet sigset
69b5fd06 1868 POSIX::SigNo sig
2304df62 1869
a0d0e21e
LW
1870MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf
1871
11a39fe4 1872void
a0d0e21e 1873new(packname = "POSIX::Termios", ...)
d3f5e399 1874 const char * packname
a0d0e21e
LW
1875 CODE:
1876 {
1877#ifdef I_TERMIOS
a2261f90
NC
1878 void *const p = allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
1879 sizeof(struct termios), packname);
11a39fe4
NC
1880 /* The previous implementation stored a pointer to an uninitialised
1881 struct termios. Seems safer to initialise it, particularly as
1882 this implementation exposes the struct to prying from perl-space.
1883 */
a2261f90 1884 memset(p, 0, 1 + sizeof(struct termios));
11a39fe4 1885 XSRETURN(1);
a0d0e21e
LW
1886#else
1887 not_here("termios");
1888#endif
1889 }
a0d0e21e
LW
1890
1891SysRet
1892getattr(termios_ref, fd = 0)
1893 POSIX::Termios termios_ref
ddc7c5c7 1894 POSIX::Fd fd
a0d0e21e
LW
1895 CODE:
1896 RETVAL = tcgetattr(fd, termios_ref);
1897 OUTPUT:
1898 RETVAL
1899
e08f19f5
TC
1900# If we define TCSANOW here then both a found and not found constant sub
1901# are created causing a Constant subroutine TCSANOW redefined warning
518487b2 1902#ifndef TCSANOW
e08f19f5
TC
1903# define DEF_SETATTR_ACTION 0
1904#else
1905# define DEF_SETATTR_ACTION TCSANOW
518487b2 1906#endif
a0d0e21e 1907SysRet
e08f19f5 1908setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION)
a0d0e21e 1909 POSIX::Termios termios_ref
ddc7c5c7 1910 POSIX::Fd fd
a0d0e21e
LW
1911 int optional_actions
1912 CODE:
ddc7c5c7
JH
1913 /* The second argument to the call is mandatory, but we'd like to give
1914 it a useful default. 0 isn't valid on all operating systems - on
1915 Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same
1916 values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF. */
1917 if (optional_actions < 0) {
1918 SETERRNO(EINVAL, LIB_INVARG);
8481e3d3 1919 RETVAL = -1;
ddc7c5c7
JH
1920 } else {
1921 RETVAL = tcsetattr(fd, optional_actions, termios_ref);
8481e3d3 1922 }
a0d0e21e
LW
1923 OUTPUT:
1924 RETVAL
1925
1926speed_t
2a59a32c 1927getispeed(termios_ref)
a0d0e21e 1928 POSIX::Termios termios_ref
2a59a32c
NC
1929 ALIAS:
1930 getospeed = 1
a0d0e21e 1931 CODE:
2a59a32c 1932 RETVAL = ix ? cfgetospeed(termios_ref) : cfgetispeed(termios_ref);
a0d0e21e
LW
1933 OUTPUT:
1934 RETVAL
1935
1936tcflag_t
2a59a32c 1937getiflag(termios_ref)
a0d0e21e 1938 POSIX::Termios termios_ref
2a59a32c
NC
1939 ALIAS:
1940 getoflag = 1
1941 getcflag = 2
1942 getlflag = 3
a0d0e21e
LW
1943 CODE:
1944#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2a59a32c
NC
1945 switch(ix) {
1946 case 0:
1947 RETVAL = termios_ref->c_iflag;
1948 break;
1949 case 1:
1950 RETVAL = termios_ref->c_oflag;
1951 break;
1952 case 2:
1953 RETVAL = termios_ref->c_cflag;
1954 break;
1955 case 3:
1956 RETVAL = termios_ref->c_lflag;
1957 break;
df164f52
DM
1958 default:
1959 RETVAL = 0; /* silence compiler warning */
2a59a32c 1960 }
a0d0e21e 1961#else
2a59a32c
NC
1962 not_here(GvNAME(CvGV(cv)));
1963 RETVAL = 0;
a0d0e21e
LW
1964#endif
1965 OUTPUT:
1966 RETVAL
1967
1968cc_t
1969getcc(termios_ref, ccix)
1970 POSIX::Termios termios_ref
b56fc9ec 1971 unsigned int ccix
a0d0e21e
LW
1972 CODE:
1973#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
1974 if (ccix >= NCCS)
1975 croak("Bad getcc subscript");
1976 RETVAL = termios_ref->c_cc[ccix];
1977#else
640cc986
HM
1978 not_here("getcc");
1979 RETVAL = 0;
a0d0e21e
LW
1980#endif
1981 OUTPUT:
1982 RETVAL
1983
1984SysRet
2a59a32c 1985setispeed(termios_ref, speed)
a0d0e21e
LW
1986 POSIX::Termios termios_ref
1987 speed_t speed
2a59a32c
NC
1988 ALIAS:
1989 setospeed = 1
a0d0e21e 1990 CODE:
2a59a32c
NC
1991 RETVAL = ix
1992 ? cfsetospeed(termios_ref, speed) : cfsetispeed(termios_ref, speed);
1993 OUTPUT:
1994 RETVAL
a0d0e21e
LW
1995
1996void
2a59a32c 1997setiflag(termios_ref, flag)
a0d0e21e 1998 POSIX::Termios termios_ref
2a59a32c
NC
1999 tcflag_t flag
2000 ALIAS:
2001 setoflag = 1
2002 setcflag = 2
2003 setlflag = 3
a0d0e21e
LW
2004 CODE:
2005#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2a59a32c
NC
2006 switch(ix) {
2007 case 0:
2008 termios_ref->c_iflag = flag;
2009 break;
2010 case 1:
2011 termios_ref->c_oflag = flag;
2012 break;
2013 case 2:
2014 termios_ref->c_cflag = flag;
2015 break;
2016 case 3:
2017 termios_ref->c_lflag = flag;
2018 break;
2019 }
a0d0e21e 2020#else
2a59a32c 2021 not_here(GvNAME(CvGV(cv)));
a0d0e21e
LW
2022#endif
2023
2024void
2025setcc(termios_ref, ccix, cc)
2026 POSIX::Termios termios_ref
b56fc9ec 2027 unsigned int ccix
a0d0e21e
LW
2028 cc_t cc
2029 CODE:
2030#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2031 if (ccix >= NCCS)
2032 croak("Bad setcc subscript");
2033 termios_ref->c_cc[ccix] = cc;
2034#else
2035 not_here("setcc");
2036#endif
2037
2038
a0d0e21e
LW
2039MODULE = POSIX PACKAGE = POSIX
2040
1cb0fb50 2041INCLUDE: const-xs.inc
a290f238 2042
e99d581a
NC
2043int
2044WEXITSTATUS(status)
2045 int status
72bfe1b2
NC
2046 ALIAS:
2047 POSIX::WIFEXITED = 1
2048 POSIX::WIFSIGNALED = 2
2049 POSIX::WIFSTOPPED = 3
2050 POSIX::WSTOPSIG = 4
2051 POSIX::WTERMSIG = 5
2052 CODE:
fabb67aa
SK
2053#if !defined(WEXITSTATUS) || !defined(WIFEXITED) || !defined(WIFSIGNALED) \
2054 || !defined(WIFSTOPPED) || !defined(WSTOPSIG) || !defined(WTERMSIG)
19c4478c
NC
2055 RETVAL = 0; /* Silence compilers that notice this, but don't realise
2056 that not_here() can't return. */
2057#endif
72bfe1b2
NC
2058 switch(ix) {
2059 case 0:
d49025b7 2060#ifdef WEXITSTATUS
17028706 2061 RETVAL = WEXITSTATUS(WMUNGE(status));
d49025b7
NC
2062#else
2063 not_here("WEXITSTATUS");
2064#endif
72bfe1b2
NC
2065 break;
2066 case 1:
d49025b7 2067#ifdef WIFEXITED
17028706 2068 RETVAL = WIFEXITED(WMUNGE(status));
d49025b7
NC
2069#else
2070 not_here("WIFEXITED");
2071#endif
72bfe1b2
NC
2072 break;
2073 case 2:
d49025b7 2074#ifdef WIFSIGNALED
17028706 2075 RETVAL = WIFSIGNALED(WMUNGE(status));
d49025b7
NC
2076#else
2077 not_here("WIFSIGNALED");
2078#endif
72bfe1b2
NC
2079 break;
2080 case 3:
d49025b7 2081#ifdef WIFSTOPPED
17028706 2082 RETVAL = WIFSTOPPED(WMUNGE(status));
d49025b7
NC
2083#else
2084 not_here("WIFSTOPPED");
2085#endif
72bfe1b2
NC
2086 break;
2087 case 4:
d49025b7 2088#ifdef WSTOPSIG
17028706 2089 RETVAL = WSTOPSIG(WMUNGE(status));
d49025b7
NC
2090#else
2091 not_here("WSTOPSIG");
2092#endif
72bfe1b2
NC
2093 break;
2094 case 5:
d49025b7 2095#ifdef WTERMSIG
17028706 2096 RETVAL = WTERMSIG(WMUNGE(status));
d49025b7
NC
2097#else
2098 not_here("WTERMSIG");
2099#endif
72bfe1b2
NC
2100 break;
2101 default:
42c07143 2102 croak("Illegal alias %d for POSIX::W*", (int)ix);
72bfe1b2
NC
2103 }
2104 OUTPUT:
2105 RETVAL
2304df62 2106
2304df62
AD
2107SysRet
2108open(filename, flags = O_RDONLY, mode = 0666)
2109 char * filename
2110 int flags
a0d0e21e 2111 Mode_t mode
748a9306
LW
2112 CODE:
2113 if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL))
2114 TAINT_PROPER("open");
2115 RETVAL = open(filename, flags, mode);
2116 OUTPUT:
2117 RETVAL
2118
2304df62
AD
2119
2120HV *
2121localeconv()
2122 CODE:
3f3bcbfc
KW
2123#ifndef HAS_LOCALECONV
2124 localeconv(); /* A stub to call not_here(). */
2125#else
2304df62 2126 struct lconv *lcbuf;
a835cd47
KW
2127
2128 /* localeconv() deals with both LC_NUMERIC and LC_MONETARY, but
2129 * LC_MONETARY is already in the correct locale */
67d796ae
KW
2130 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2131 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
a835cd47 2132
2304df62 2133 RETVAL = newHV();
c4e79b56 2134 sv_2mortal((SV*)RETVAL);
8063af02 2135 if ((lcbuf = localeconv())) {
2f0945cb
NC
2136 const struct lconv_offset *strings = lconv_strings;
2137 const struct lconv_offset *integers = lconv_integers;
2138 const char *ptr = (const char *) lcbuf;
2139
e3bf3304 2140 while (strings->name) {
c1284011
KW
2141 /* This string may be controlled by either LC_NUMERIC, or
2142 * LC_MONETARY */
2143 bool is_utf8_locale
2144#if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY)
2145 = _is_cur_LC_category_utf8((isLC_NUMERIC_STRING(strings->name))
2146 ? LC_NUMERIC
2147 : LC_MONETARY);
2148#elif defined(USE_LOCALE_NUMERIC)
2149 = _is_cur_LC_category_utf8(LC_NUMERIC);
2150#elif defined(USE_LOCALE_MONETARY)
2151 = _is_cur_LC_category_utf8(LC_MONETARY);
2152#else
2153 = FALSE;
2154#endif
2155
2f0945cb
NC
2156 const char *value = *((const char **)(ptr + strings->offset));
2157
c1284011
KW
2158 if (value && *value) {
2159 (void) hv_store(RETVAL,
2160 strings->name,
2161 strlen(strings->name),
c5f058df
KW
2162 newSVpvn_utf8(
2163 value,
2164 strlen(value),
2165
2166 /* We mark it as UTF-8 if a utf8 locale and is
2167 * valid and variant under UTF-8 */
2168 is_utf8_locale
2169 && ! is_utf8_invariant_string((U8 *) value, 0)
2170 && is_utf8_string((U8 *) value, 0)),
2171 0);
2172 }
e3bf3304
KW
2173 strings++;
2174 }
2f0945cb 2175
e3bf3304 2176 while (integers->name) {
2f0945cb
NC
2177 const char value = *((const char *)(ptr + integers->offset));
2178
2179 if (value != CHAR_MAX)
2180 (void) hv_store(RETVAL, integers->name,
2181 strlen(integers->name), newSViv(value), 0);
e3bf3304
KW
2182 integers++;
2183 }
2304df62 2184 }
67d796ae 2185 RESTORE_LC_NUMERIC_STANDARD();
3f3bcbfc 2186#endif /* HAS_LOCALECONV */
2304df62
AD
2187 OUTPUT:
2188 RETVAL
2189
2190char *
c28ee57b 2191setlocale(category, locale = 0)
2304df62 2192 int category
8e70cf7a 2193 const char * locale
1ba01ae3
SH
2194 PREINIT:
2195 char * retval;
c28ee57b 2196 CODE:
a4f00dcc
KW
2197 retval = Perl_setlocale(category, locale);
2198 if (! retval) { /* Should never happen that a query would return an
2199 * error, but be sure */
fbd840df
KW
2200 XSRETURN_UNDEF;
2201 }
49efabc8 2202
a4f00dcc 2203 /* Make sure the returned copy gets cleaned up */
54bc7615 2204 SAVEFREEPV(retval);
49efabc8 2205
a4f00dcc 2206 RETVAL = retval;
c28ee57b
JH
2207 OUTPUT:
2208 RETVAL
2304df62 2209
e1ca407b 2210NV
2304df62 2211acos(x)
e1ca407b 2212 NV x
b256643b 2213 ALIAS:
7965edec
JH
2214 acosh = 1
2215 asin = 2
2216 asinh = 3
2217 atan = 4
2218 atanh = 5
2219 cbrt = 6
2220 ceil = 7
2221 cosh = 8
2222 erf = 9
2223 erfc = 10
2224 exp2 = 11
2225 expm1 = 12
2226 floor = 13
2227 j0 = 14
2228 j1 = 15
2229 lgamma = 16
2230 log10 = 17
2231 log1p = 18
2232 log2 = 19
2233 logb = 20
2234 nearbyint = 21
2235 rint = 22
2236 round = 23
2237 sinh = 24
2238 tan = 25
2239 tanh = 26
2240 tgamma = 27
2241 trunc = 28
2242 y0 = 29
2243 y1 = 30
b256643b 2244 CODE:
7f4bfd0b 2245 PERL_UNUSED_VAR(x);
effb4c81 2246#ifdef NV_NAN
78a0541a 2247 RETVAL = NV_NAN;
effb4c81
JH
2248#else
2249 RETVAL = 0;
2250#endif
b256643b
NC
2251 switch (ix) {
2252 case 0:
8a00eddc 2253 RETVAL = Perl_acos(x); /* C89 math */
b256643b
NC
2254 break;
2255 case 1:
5716d070 2256#ifdef c99_acosh
7965edec 2257 RETVAL = c99_acosh(x);
5716d070
JH
2258#else
2259 not_here("acosh");
2260#endif
b256643b
NC
2261 break;
2262 case 2:
8a00eddc 2263 RETVAL = Perl_asin(x); /* C89 math */
b256643b
NC
2264 break;
2265 case 3:
5716d070 2266#ifdef c99_asinh
7965edec 2267 RETVAL = c99_asinh(x);
5716d070
JH
2268#else
2269 not_here("asinh");
2270#endif
b256643b
NC
2271 break;
2272 case 4:
8a00eddc 2273 RETVAL = Perl_atan(x); /* C89 math */
b256643b
NC
2274 break;
2275 case 5:
5716d070 2276#ifdef c99_atanh
7965edec 2277 RETVAL = c99_atanh(x);
5716d070
JH
2278#else
2279 not_here("atanh");
2280#endif
b256643b
NC
2281 break;
2282 case 6:
5716d070 2283#ifdef c99_cbrt
7965edec 2284 RETVAL = c99_cbrt(x);
5716d070
JH
2285#else
2286 not_here("cbrt");
2287#endif
b256643b
NC
2288 break;
2289 case 7:
8a00eddc 2290 RETVAL = Perl_ceil(x); /* C89 math */
b256643b
NC
2291 break;
2292 case 8:
8a00eddc 2293 RETVAL = Perl_cosh(x); /* C89 math */
7965edec
JH
2294 break;
2295 case 9:
5716d070 2296#ifdef c99_erf
7965edec 2297 RETVAL = c99_erf(x);
5716d070
JH
2298#else
2299 not_here("erf");
2300#endif
7965edec
JH
2301 break;
2302 case 10:
5716d070 2303#ifdef c99_erfc
d5799f37 2304 RETVAL = c99_erfc(x);
5716d070
JH
2305#else
2306 not_here("erfc");
2307#endif
7965edec
JH
2308 break;
2309 case 11:
5716d070 2310#ifdef c99_exp2
7965edec 2311 RETVAL = c99_exp2(x);
5716d070
JH
2312#else
2313 not_here("exp2");
2314#endif
7965edec
JH
2315 break;
2316 case 12:
5716d070 2317#ifdef c99_expm1
7965edec 2318 RETVAL = c99_expm1(x);
5716d070
JH
2319#else
2320 not_here("expm1");
2321#endif
7965edec
JH
2322 break;
2323 case 13:
8a00eddc 2324 RETVAL = Perl_floor(x); /* C89 math */
7965edec
JH
2325 break;
2326 case 14:
5716d070 2327#ifdef bessel_j0
7965edec 2328 RETVAL = bessel_j0(x);
5716d070 2329#else
85c93440 2330 not_here("j0");
5716d070 2331#endif
7965edec
JH
2332 break;
2333 case 15:
5716d070 2334#ifdef bessel_j1
7965edec 2335 RETVAL = bessel_j1(x);
5716d070 2336#else
85c93440 2337 not_here("j1");
5716d070 2338#endif
7965edec
JH
2339 break;
2340 case 16:
2e9cdb62 2341 /* XXX Note: the lgamma modifies a global variable (signgam),
d334ccbe 2342 * which is evil. Some platforms have lgamma_r, which has
2e9cdb62 2343 * extra output parameter instead of the global variable. */
5716d070 2344#ifdef c99_lgamma
7965edec 2345 RETVAL = c99_lgamma(x);
5716d070
JH
2346#else
2347 not_here("lgamma");
2348#endif
7965edec
JH
2349 break;
2350 case 17:
5716d070 2351 RETVAL = log10(x); /* C89 math */
7965edec
JH
2352 break;
2353 case 18:
5716d070 2354#ifdef c99_log1p
7965edec 2355 RETVAL = c99_log1p(x);
5716d070
JH
2356#else
2357 not_here("log1p");
2358#endif
7965edec
JH
2359 break;
2360 case 19:
5716d070 2361#ifdef c99_log2
7965edec 2362 RETVAL = c99_log2(x);
5716d070
JH
2363#else
2364 not_here("log2");
2365#endif
7965edec
JH
2366 break;
2367 case 20:
5716d070 2368#ifdef c99_logb
7965edec 2369 RETVAL = c99_logb(x);
eec978e5
JH
2370#elif defined(c99_log2) && FLT_RADIX == 2
2371 RETVAL = Perl_floor(c99_log2(PERL_ABS(x)));
5716d070
JH
2372#else
2373 not_here("logb");
2374#endif
7965edec
JH
2375 break;
2376 case 21:
5716d070 2377#ifdef c99_nearbyint
7965edec 2378 RETVAL = c99_nearbyint(x);
5716d070
JH
2379#else
2380 not_here("nearbyint");
2381#endif
7965edec
JH
2382 break;
2383 case 22:
5716d070 2384#ifdef c99_rint
7965edec 2385 RETVAL = c99_rint(x);
5716d070
JH
2386#else
2387 not_here("rint");
2388#endif
7965edec
JH
2389 break;
2390 case 23:
5716d070 2391#ifdef c99_round
7965edec 2392 RETVAL = c99_round(x);
5716d070
JH
2393#else
2394 not_here("round");
2395#endif
7965edec
JH
2396 break;
2397 case 24:
8a00eddc 2398 RETVAL = Perl_sinh(x); /* C89 math */
7965edec
JH
2399 break;
2400 case 25:
8a00eddc 2401 RETVAL = Perl_tan(x); /* C89 math */
b256643b 2402 break;
7965edec 2403 case 26:
8a00eddc 2404 RETVAL = Perl_tanh(x); /* C89 math */
7965edec
JH
2405 break;
2406 case 27:
5716d070 2407#ifdef c99_tgamma
7965edec 2408 RETVAL = c99_tgamma(x);
5716d070
JH
2409#else
2410 not_here("tgamma");
2411#endif
7965edec
JH
2412 break;
2413 case 28:
5716d070 2414#ifdef c99_trunc
7965edec 2415 RETVAL = c99_trunc(x);
5716d070
JH
2416#else
2417 not_here("trunc");
2418#endif
7965edec
JH
2419 break;
2420 case 29:
5716d070 2421#ifdef bessel_y0
7965edec 2422 RETVAL = bessel_y0(x);
5716d070 2423#else
85c93440 2424 not_here("y0");
5716d070 2425#endif
7965edec
JH
2426 break;
2427 case 30:
2428 default:
5716d070 2429#ifdef bessel_y1
7965edec 2430 RETVAL = bessel_y1(x);
5716d070 2431#else
85c93440 2432 not_here("y1");
5716d070 2433#endif
7965edec
JH
2434 }
2435 OUTPUT:
2436 RETVAL
2437
2438IV
a5713e21
JH
2439fegetround()
2440 CODE:
78a0541a 2441#ifdef HAS_FEGETROUND
d5f4f26a 2442 RETVAL = my_fegetround();
78a0541a
JH
2443#else
2444 RETVAL = -1;
a5713e21
JH
2445 not_here("fegetround");
2446#endif
2447 OUTPUT:
2448 RETVAL
2449
2450IV
2451fesetround(x)
2452 IV x
2453 CODE:
2454#ifdef HAS_FEGETROUND /* canary for fesetround */
2455 RETVAL = fesetround(x);
879d23d2 2456#elif defined(HAS_FPGETROUND) /* canary for fpsetround */
e0939537 2457 switch (x) {
e0939537
JH
2458 case FE_TONEAREST: RETVAL = fpsetround(FP_RN); break;
2459 case FE_TOWARDZERO: RETVAL = fpsetround(FP_RZ); break;
2460 case FE_DOWNWARD: RETVAL = fpsetround(FP_RM); break;
2461 case FE_UPWARD: RETVAL = fpsetround(FP_RP); break;
ebac59ac 2462 default: RETVAL = -1; break;
e0939537 2463 }
877206df
JH
2464#elif defined(__osf__) /* Tru64 */
2465 switch (x) {
2466 case FE_TONEAREST: RETVAL = write_rnd(FP_RND_RN); break;
2467 case FE_TOWARDZERO: RETVAL = write_rnd(FP_RND_RZ); break;
2468 case FE_DOWNWARD: RETVAL = write_rnd(FP_RND_RM); break;
2469 case FE_UPWARD: RETVAL = write_rnd(FP_RND_RP); break;
2470 default: RETVAL = -1; break;
2471 }
a5713e21 2472#else
7f4bfd0b 2473 PERL_UNUSED_VAR(x);
78a0541a 2474 RETVAL = -1;
a5713e21
JH
2475 not_here("fesetround");
2476#endif
2477 OUTPUT:
2478 RETVAL
2479
2480IV
7965edec
JH
2481fpclassify(x)
2482 NV x
2483 ALIAS:
2484 ilogb = 1
2485 isfinite = 2
2486 isinf = 3
2487 isnan = 4
2488 isnormal = 5
3823048b
JH
2489 lrint = 6
2490 lround = 7
2491 signbit = 8
7965edec 2492 CODE:
7f4bfd0b 2493 PERL_UNUSED_VAR(x);
78a0541a 2494 RETVAL = -1;
7965edec
JH
2495 switch (ix) {
2496 case 0:
5716d070 2497#ifdef c99_fpclassify
7965edec 2498 RETVAL = c99_fpclassify(x);
5716d070
JH
2499#else
2500 not_here("fpclassify");
2501#endif
7965edec
JH
2502 break;
2503 case 1:
5716d070 2504#ifdef c99_ilogb
7965edec 2505 RETVAL = c99_ilogb(x);
5716d070
JH
2506#else
2507 not_here("ilogb");
2508#endif
7965edec
JH
2509 break;
2510 case 2:
2511 RETVAL = Perl_isfinite(x);
2512 break;
2513 case 3:
2514 RETVAL = Perl_isinf(x);
2515 break;
2516 case 4:
2517 RETVAL = Perl_isnan(x);
2518 break;
2519 case 5:
5716d070 2520#ifdef c99_isnormal
7965edec 2521 RETVAL = c99_isnormal(x);
5716d070
JH
2522#else
2523 not_here("isnormal");
2524#endif
7965edec
JH
2525 break;
2526 case 6:
d5f4f26a
JH
2527#ifdef c99_lrint
2528 RETVAL = c99_lrint(x);
2529#else
2530 not_here("lrint");
2531#endif
2532 break;
3823048b 2533 case 7:
9e010b89
JH
2534#ifdef c99_lround
2535 RETVAL = c99_lround(x);
2536#else
2537 not_here("lround");
2538#endif
2539 break;
3823048b 2540 case 8:
7965edec 2541 default:
5716d070
JH
2542#ifdef Perl_signbit
2543 RETVAL = Perl_signbit(x);
2a7bb164 2544#else
0c61ae02
JH
2545 RETVAL = (x < 0);
2546#ifdef DOUBLE_IS_IEEE_FORMAT
2547 if (x == -0.0) {
2548 RETVAL = TRUE;
2549 }
2550#endif
5716d070 2551#endif
7965edec 2552 break;
b256643b
NC
2553 }
2554 OUTPUT:
2555 RETVAL
2304df62 2556
e1ca407b 2557NV
07bb61ac
JH
2558getpayload(nv)
2559 NV nv
2560 CODE:
effb4c81 2561#ifdef DOUBLE_HAS_NAN
07bb61ac 2562 RETVAL = S_getpayload(nv);
effb4c81
JH
2563#else
2564 PERL_UNUSED_VAR(nv);
9ec60511 2565 RETVAL = 0.0;
effb4c81
JH
2566 not_here("getpayload");
2567#endif
07bb61ac
JH
2568 OUTPUT:
2569 RETVAL
2570
2571void
2572setpayload(nv, payload)
2573 NV nv
2574 NV payload
2575 CODE:
effb4c81 2576#ifdef DOUBLE_HAS_NAN
07bb61ac 2577 S_setpayload(&nv, payload, FALSE);
effb4c81
JH
2578#else
2579 PERL_UNUSED_VAR(nv);
2580 PERL_UNUSED_VAR(payload);
2581 not_here("setpayload");
2582#endif
07bb61ac
JH
2583 OUTPUT:
2584 nv
2585
2586void
2587setpayloadsig(nv, payload)
2588 NV nv
2589 NV payload
2590 CODE:
effb4c81 2591#ifdef DOUBLE_HAS_NAN
07bb61ac
JH
2592 nv = NV_NAN;
2593 S_setpayload(&nv, payload, TRUE);
effb4c81
JH
2594#else
2595 PERL_UNUSED_VAR(nv);
2596 PERL_UNUSED_VAR(payload);
2597 not_here("setpayloadsig");
2598#endif
07bb61ac
JH
2599 OUTPUT:
2600 nv
2601
2602int
2603issignaling(nv)
2604 NV nv
2605 CODE:
effb4c81 2606#ifdef DOUBLE_HAS_NAN
07bb61ac 2607 RETVAL = Perl_isnan(nv) && NV_NAN_IS_SIGNALING(&nv);
effb4c81
JH
2608#else
2609 PERL_UNUSED_VAR(nv);
9ec60511 2610 RETVAL = 0.0;
effb4c81
JH
2611 not_here("issignaling");
2612#endif
07bb61ac
JH
2613 OUTPUT:
2614 RETVAL
2615
2616NV
7965edec 2617copysign(x,y)
e1ca407b
A
2618 NV x
2619 NV y
7965edec
JH
2620 ALIAS:
2621 fdim = 1
2622 fmax = 2
2623 fmin = 3
2624 fmod = 4
2625 hypot = 5
2626 isgreater = 6
2627 isgreaterequal = 7
2628 isless = 8
2629 islessequal = 9
2630 islessgreater = 10
2631 isunordered = 11
2632 nextafter = 12
2633 nexttoward = 13
2634 remainder = 14
2635 CODE:
7f4bfd0b
JH
2636 PERL_UNUSED_VAR(x);
2637 PERL_UNUSED_VAR(y);
effb4c81 2638#ifdef NV_NAN
78a0541a 2639 RETVAL = NV_NAN;
effb4c81
JH
2640#else
2641 RETVAL = 0;
2642#endif
7965edec
JH
2643 switch (ix) {
2644 case 0:
5716d070 2645#ifdef c99_copysign
7965edec 2646 RETVAL = c99_copysign(x, y);
5716d070
JH
2647#else
2648 not_here("copysign");
2649#endif
7965edec
JH
2650 break;
2651 case 1:
5716d070 2652#ifdef c99_fdim
7965edec 2653 RETVAL = c99_fdim(x, y);
5716d070
JH
2654#else
2655 not_here("fdim");
2656#endif
7965edec
JH
2657 break;
2658 case 2:
5716d070 2659#ifdef c99_fmax
7965edec 2660 RETVAL = c99_fmax(x, y);
5716d070
JH
2661#else
2662 not_here("fmax");
2663#endif
7965edec
JH
2664 break;
2665 case 3:
5716d070 2666#ifdef c99_fmin
7965edec 2667 RETVAL = c99_fmin(x, y);
5716d070
JH
2668#else
2669 not_here("fmin");
2670#endif
7965edec
JH
2671 break;
2672 case 4:
8a00eddc 2673 RETVAL = Perl_fmod(x, y); /* C89 math */
7965edec
JH
2674 break;
2675 case 5:
5716d070 2676#ifdef c99_hypot
7965edec 2677 RETVAL = c99_hypot(x, y);
5716d070
JH
2678#else
2679 not_here("hypot");
2680#endif
7965edec
JH
2681 break;
2682 case 6:
5716d070 2683#ifdef c99_isgreater
7965edec 2684 RETVAL = c99_isgreater(x, y);
5716d070
JH
2685#else
2686 not_here("isgreater");
2687#endif
7965edec
JH
2688 break;
2689 case 7:
5716d070 2690#ifdef c99_isgreaterequal
7965edec 2691 RETVAL = c99_isgreaterequal(x, y);
5716d070
JH
2692#else
2693 not_here("isgreaterequal");
2694#endif
7965edec
JH
2695 break;
2696 case 8:
5716d070 2697#ifdef c99_isless
7965edec 2698 RETVAL = c99_isless(x, y);
5716d070
JH
2699#else
2700 not_here("isless");
2701#endif
7965edec
JH
2702 break;
2703 case 9:
5716d070 2704#ifdef c99_islessequal
7965edec 2705 RETVAL = c99_islessequal(x, y);
5716d070
JH
2706#else
2707 not_here("islessequal");
2708#endif
7965edec
JH
2709 break;
2710 case 10:
5716d070 2711#ifdef c99_islessgreater
7965edec 2712 RETVAL = c99_islessgreater(x, y);
5716d070
JH
2713#else
2714 not_here("islessgreater");
2715#endif
7965edec
JH
2716 break;
2717 case 11:
5716d070 2718#ifdef c99_isunordered
7965edec 2719 RETVAL = c99_isunordered(x, y);
5716d070
JH
2720#else
2721 not_here("isunordered");
2722#endif
7965edec
JH
2723 break;
2724 case 12:
5716d070 2725#ifdef c99_nextafter
7965edec 2726 RETVAL = c99_nextafter(x, y);
5716d070
JH
2727#else
2728 not_here("nextafter");
2729#endif
7965edec
JH
2730 break;
2731 case 13:
5716d070 2732#ifdef c99_nexttoward
7965edec 2733 RETVAL = c99_nexttoward(x, y);
5716d070
JH
2734#else
2735 not_here("nexttoward");
2736#endif
7965edec
JH
2737 break;
2738 case 14:
2739 default:
5716d070 2740#ifdef c99_remainder
7f4bfd0b 2741 RETVAL = c99_remainder(x, y);
5716d070 2742#else
7f4bfd0b 2743 not_here("remainder");
5716d070 2744#endif
7965edec
JH
2745 break;
2746 }
2747 OUTPUT:
2748 RETVAL
2304df62
AD
2749
2750void
2751frexp(x)
e1ca407b 2752 NV x
2304df62
AD
2753 PPCODE:
2754 int expvar;
2304df62 2755 /* (We already know stack is long enough.) */
5716d070 2756 PUSHs(sv_2mortal(newSVnv(Perl_frexp(x,&expvar)))); /* C89 math */
2304df62
AD
2757 PUSHs(sv_2mortal(newSViv(expvar)));
2758
e1ca407b 2759NV
2304df62 2760ldexp(x,exp)
e1ca407b 2761 NV x
2304df62
AD
2762 int exp
2763
2304df62
AD
2764void
2765modf(x)
e1ca407b 2766 NV x
2304df62 2767 PPCODE:
e1ca407b 2768 NV intvar;
2304df62 2769 /* (We already know stack is long enough.) */
5716d070 2770 PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); /* C89 math */
2304df62
AD
2771 PUSHs(sv_2mortal(newSVnv(intvar)));
2772
7965edec
JH
2773void
2774remquo(x,y)
2775 NV x
2776 NV y
2777 PPCODE:
5716d070 2778#ifdef c99_remquo
7965edec
JH
2779 int intvar;
2780 PUSHs(sv_2mortal(newSVnv(c99_remquo(x,y,&intvar))));
2781 PUSHs(sv_2mortal(newSVnv(intvar)));
5716d070 2782#else
7f4bfd0b
JH
2783 PERL_UNUSED_VAR(x);
2784 PERL_UNUSED_VAR(y);
5716d070
JH
2785 not_here("remquo");
2786#endif
7965edec
JH
2787
2788NV
2789scalbn(x,y)
2790 NV x
2791 IV y
2792 CODE:
5716d070 2793#ifdef c99_scalbn
7965edec 2794 RETVAL = c99_scalbn(x, y);
5716d070 2795#else
7f4bfd0b
JH
2796 PERL_UNUSED_VAR(x);
2797 PERL_UNUSED_VAR(y);
78a0541a 2798 RETVAL = NV_NAN;
5716d070
JH
2799 not_here("scalbn");
2800#endif
7965edec
JH
2801 OUTPUT:
2802 RETVAL
2803
2804NV
2805fma(x,y,z)
2806 NV x
2807 NV y
2808 NV z
2809 CODE:
5716d070 2810#ifdef c99_fma
6b13befe
JH
2811 RETVAL = c99_fma(x, y, z);
2812#else
7f4bfd0b
JH
2813 PERL_UNUSED_VAR(x);
2814 PERL_UNUSED_VAR(y);
2815 PERL_UNUSED_VAR(z);
6b13befe 2816 not_here("fma");
5716d070 2817#endif
7965edec
JH
2818 OUTPUT:
2819 RETVAL
2820
2821NV
07bb61ac
JH
2822nan(payload = 0)
2823 NV payload
7965edec 2824 CODE:
07bb61ac
JH
2825#ifdef NV_NAN
2826 /* If no payload given, just return the default NaN.
2827 * This makes a difference in platforms where the default
2828 * NaN is not all zeros. */
2829 if (items == 0) {
2830 RETVAL = NV_NAN;
2831 } else {
2832 S_setpayload(&RETVAL, payload, FALSE);
2833 }
2834#elif defined(c99_nan)
2835 {
effb4c81 2836 STRLEN elen = my_snprintf(PL_efloatbuf, PL_efloatsize, "%g", payload);
07bb61ac 2837 if ((IV)elen == -1) {
effb4c81 2838#ifdef NV_NAN
07bb61ac 2839 RETVAL = NV_NAN;
effb4c81 2840#else
9ec60511 2841 RETVAL = 0.0;
effb4c81
JH
2842 not_here("nan");
2843#endif
07bb61ac
JH
2844 } else {
2845 RETVAL = c99_nan(PL_efloatbuf);
2846 }
2847 }
7c7d45f1 2848#else
5716d070
JH
2849 not_here("nan");
2850#endif
7965edec
JH
2851 OUTPUT:
2852 RETVAL
2853
2854NV
2855jn(x,y)
2856 IV x
2857 NV y
2858 ALIAS:
2859 yn = 1
2860 CODE:
effb4c81 2861#ifdef NV_NAN
78a0541a 2862 RETVAL = NV_NAN;
effb4c81
JH
2863#else
2864 RETVAL = 0;
2865#endif
7965edec
JH
2866 switch (ix) {
2867 case 0:
5716d070 2868#ifdef bessel_jn
7f4bfd0b 2869 RETVAL = bessel_jn(x, y);
5716d070 2870#else
6b13befe
JH
2871 PERL_UNUSED_VAR(x);
2872 PERL_UNUSED_VAR(y);
7f4bfd0b 2873 not_here("jn");
5716d070 2874#endif
7965edec
JH
2875 break;
2876 case 1:
2877 default:
5716d070 2878#ifdef bessel_yn
7f4bfd0b 2879 RETVAL = bessel_yn(x, y);
5716d070 2880#else
6b13befe
JH
2881 PERL_UNUSED_VAR(x);
2882 PERL_UNUSED_VAR(y);
7f4bfd0b 2883 not_here("yn");
5716d070 2884#endif
7965edec
JH
2885 break;
2886 }
2887 OUTPUT:
2888 RETVAL
2889
2304df62 2890SysRet
1dfe7606 2891sigaction(sig, optaction, oldaction = 0)
2304df62 2892 int sig
1dfe7606 2893 SV * optaction
2304df62
AD
2894 POSIX::SigAction oldaction
2895 CODE:
30b42e09 2896#if defined(WIN32) || defined(NETWARE) || (defined(__amigaos4__) && defined(__NEWLIB__))
6dead956
GS
2897 RETVAL = not_here("sigaction");
2898#else
3a8a1642 2899# This code is really grody because we are trying to make the signal
2304df62
AD
2900# interface look beautiful, which is hard.
2901
2304df62 2902 {
27da23d5 2903 dVAR;
1dfe7606 2904 POSIX__SigAction action;
f584eb2d 2905 GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV);
2304df62
AD
2906 struct sigaction act;
2907 struct sigaction oact;
1dfe7606 2908 sigset_t sset;
183bde56 2909 SV *osset_sv;
27c1a449 2910 sigset_t osset;
2304df62
AD
2911 POSIX__SigSet sigset;
2912 SV** svp;
1d81eac9 2913 SV** sigsvp;
3609ea0d 2914
516d25e8
SP
2915 if (sig < 0) {
2916 croak("Negative signals are not allowed");
2917 }
2918
1d81eac9 2919 if (sig == 0 && SvPOK(ST(0))) {
aa07b2f6 2920 const char *s = SvPVX_const(ST(0));
1d81eac9
JH
2921 int i = whichsig(s);
2922
f7806eea 2923 if (i < 0 && _memEQs(s, "SIG"))
1d81eac9
JH
2924 i = whichsig(s + 3);
2925 if (i < 0) {
2926 if (ckWARN(WARN_SIGNAL))
2927 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2928 "No such signal: SIG%s", s);
2929 XSRETURN_UNDEF;
2930 }
2931 else
2932 sig = i;
2933 }
3609ea0d
JH
2934#ifdef NSIG
2935 if (sig > NSIG) { /* NSIG - 1 is still okay. */
2936 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2937 "No such signal: %d", sig);
2938 XSRETURN_UNDEF;
2939 }
2940#endif
1d81eac9
JH
2941 sigsvp = hv_fetch(GvHVn(siggv),
2942 PL_sig_name[sig],
2943 strlen(PL_sig_name[sig]),
2944 TRUE);
2304df62 2945
1dfe7606 2946 /* Check optaction and set action */
2947 if(SvTRUE(optaction)) {
2948 if(sv_isa(optaction, "POSIX::SigAction"))
2949 action = (HV*)SvRV(optaction);
2950 else
2951 croak("action is not of type POSIX::SigAction");
2952 }
2953 else {
2954 action=0;
2955 }
2956
2957 /* sigaction() is supposed to look atomic. In particular, any
2958 * signal handler invoked during a sigaction() call should
2959 * see either the old or the new disposition, and not something
2960 * in between. We use sigprocmask() to make it so.
2961 */
2962 sigfillset(&sset);
2963 RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
2964 if(RETVAL == -1)
15c0d34a 2965 XSRETURN_UNDEF;
1dfe7606 2966 ENTER;
2967 /* Restore signal mask no matter how we exit this block. */
f584eb2d 2968 osset_sv = newSVpvn((char *)(&osset), sizeof(sigset_t));
183bde56 2969 SAVEFREESV( osset_sv );
40b7a5f5 2970 SAVEDESTRUCTOR_X(restore_sigmask, osset_sv);
1dfe7606 2971
2972 RETVAL=-1; /* In case both oldaction and action are 0. */
2973
2974 /* Remember old disposition if desired. */
2304df62 2975 if (oldaction) {
017a3ce5 2976 svp = hv_fetchs(oldaction, "HANDLER", TRUE);
1dfe7606 2977 if(!svp)
2978 croak("Can't supply an oldaction without a HANDLER");
2979 if(SvTRUE(*sigsvp)) { /* TBD: what if "0"? */
2980 sv_setsv(*svp, *sigsvp);
2981 }
2982 else {
f584eb2d 2983 sv_setpvs(*svp, "DEFAULT");
1dfe7606 2984 }
2985 RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
6ca4bbc9
GG
2986 if(RETVAL == -1) {
2987 LEAVE;
15c0d34a 2988 XSRETURN_UNDEF;
6ca4bbc9 2989 }
1dfe7606 2990 /* Get back the mask. */
017a3ce5 2991 svp = hv_fetchs(oldaction, "MASK", TRUE);
1dfe7606 2992 if (sv_isa(*svp, "POSIX::SigSet")) {
92b39396 2993 sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
1dfe7606 2994 }
2995 else {
92b39396
NC
2996 sigset = (sigset_t *) allocate_struct(aTHX_ *svp,
2997 sizeof(sigset_t),
2998 "POSIX::SigSet");
1dfe7606 2999 }
3000 *sigset = oact.sa_mask;
3001
3002 /* Get back the flags. */
017a3ce5 3003 svp = hv_fetchs(oldaction, "FLAGS", TRUE);
1dfe7606 3004 sv_setiv(*svp, oact.sa_flags);
d36b6582
CS
3005
3006 /* Get back whether the old handler used safe signals. */
017a3ce5 3007 svp = hv_fetchs(oldaction, "SAFE", TRUE);
e91e3b10
RB
3008 sv_setiv(*svp,
3009 /* compare incompatible pointers by casting to integer */
3010 PTR2nat(oact.sa_handler) == PTR2nat(PL_csighandlerp));
2304df62
AD
3011 }
3012
3013 if (action) {
d36b6582
CS
3014 /* Safe signals use "csighandler", which vectors through the
3015 PL_sighandlerp pointer when it's safe to do so.
3016 (BTW, "csighandler" is very different from "sighandler".) */
017a3ce5 3017 svp = hv_fetchs(action, "SAFE", FALSE);
e91e3b10
RB
3018 act.sa_handler =
3019 DPTR2FPTR(
87d46f97 3020 void (*)(int),
e91e3b10
RB
3021 (*svp && SvTRUE(*svp))
3022 ? PL_csighandlerp : PL_sighandlerp
3023 );
d36b6582
CS
3024
3025 /* Vector new Perl handler through %SIG.
3026 (The core signal handlers read %SIG to dispatch.) */
017a3ce5 3027 svp = hv_fetchs(action, "HANDLER", FALSE);
2304df62
AD
3028 if (!svp)
3029 croak("Can't supply an action without a HANDLER");
1dfe7606 3030 sv_setsv(*sigsvp, *svp);
d36b6582
CS
3031
3032 /* This call actually calls sigaction() with almost the
3033 right settings, including appropriate interpretation
3034 of DEFAULT and IGNORE. However, why are we doing
3035 this when we're about to do it again just below? XXX */
17cffb37 3036 SvSETMAGIC(*sigsvp);
d36b6582
CS
3037
3038 /* And here again we duplicate -- DEFAULT/IGNORE checking. */
1dfe7606 3039 if(SvPOK(*svp)) {
aa07b2f6 3040 const char *s=SvPVX_const(*svp);
1dfe7606 3041 if(strEQ(s,"IGNORE")) {
3042 act.sa_handler = SIG_IGN;
3043 }
3044 else if(strEQ(s,"DEFAULT")) {
3045 act.sa_handler = SIG_DFL;
3046 }
1dfe7606 3047 }
2304df62
AD
3048
3049 /* Set up any desired mask. */
017a3ce5 3050 svp = hv_fetchs(action, "MASK", FALSE);
2304df62 3051 if (svp && sv_isa(*svp, "POSIX::SigSet")) {
92b39396 3052 sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
2304df62
AD
3053 act.sa_mask = *sigset;
3054 }
3055 else
85e6fe83 3056 sigemptyset(& act.sa_mask);
2304df62
AD
3057
3058 /* Set up any desired flags. */
017a3ce5 3059 svp = hv_fetchs(action, "FLAGS", FALSE);
2304df62 3060 act.sa_flags = svp ? SvIV(*svp) : 0;
2304df62 3061
1dfe7606 3062 /* Don't worry about cleaning up *sigsvp if this fails,
3063 * because that means we tried to disposition a
3064 * nonblockable signal, in which case *sigsvp is
3065 * essentially meaningless anyway.
3066 */
6c418a22 3067 RETVAL = sigaction(sig, & act, (struct sigaction *)0);
6ca4bbc9
GG
3068 if(RETVAL == -1) {
3069 LEAVE;
a7aad5de 3070 XSRETURN_UNDEF;
6ca4bbc9 3071 }
2304df62 3072 }
1dfe7606 3073
3074 LEAVE;
2304df62 3075 }
6dead956 3076#endif
2304df62
AD
3077 OUTPUT:
3078 RETVAL
3079
3080SysRet
3081sigpending(sigset)
3082 POSIX::SigSet sigset
7a004119
NC
3083 ALIAS:
3084 sigsuspend = 1
3085 CODE:
ea34f6bd 3086#ifdef __amigaos4__
30b42e09
AB
3087 RETVAL = not_here("sigpending");
3088#else
7a004119 3089 RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
32a14dd4 3090#endif
7a004119
NC
3091 OUTPUT:
3092 RETVAL
20120e59
LT
3093 CLEANUP:
3094 PERL_ASYNC_CHECK();
2304df62
AD
3095
3096SysRet
3097sigprocmask(how, sigset, oldsigset = 0)
3098 int how
b13bbac7 3099 POSIX::SigSet sigset = NO_INIT
33c27489
GS
3100 POSIX::SigSet oldsigset = NO_INIT
3101INIT:
a3b811a7 3102 if (! SvOK(ST(1))) {
b13bbac7 3103 sigset = NULL;
a3b811a7 3104 } else if (sv_isa(ST(1), "POSIX::SigSet")) {
92b39396 3105 sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1)));
b13bbac7
AB
3106 } else {
3107 croak("sigset is not of type POSIX::SigSet");
33c27489 3108 }
b13bbac7 3109
194cfca0 3110 if (items < 3 || ! SvOK(ST(2))) {
b13bbac7 3111 oldsigset = NULL;
a3b811a7 3112 } else if (sv_isa(ST(2), "POSIX::SigSet")) {
92b39396 3113 oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2)));
b13bbac7
AB
3114 } else {
3115 croak("oldsigset is not of type POSIX::SigSet");
33c27489 3116 }
2304df62 3117
2304df62
AD
3118void
3119_exit(status)
3120 int status
8990e307 3121
85e6fe83 3122SysRet
8990e307
LW
3123dup2(fd1, fd2)
3124 int fd1
3125 int fd2
ad413e46 3126 CODE:
6e7b1a26 3127 if (fd1 >= 0 && fd2 >= 0) {
ad413e46 3128#ifdef WIN32
6e7b1a26
JH
3129 /* RT #98912 - More Microsoft muppetry - failing to
3130 actually implemented the well known documented POSIX
3131 behaviour for a POSIX API.
3132 http://msdn.microsoft.com/en-us/library/8syseb29.aspx */
3133 RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2;
ad413e46 3134#else
6e7b1a26 3135 RETVAL = dup2(fd1, fd2);
ad413e46 3136#endif
6e7b1a26
JH
3137 } else {
3138 SETERRNO(EBADF,RMS_IFI);
3139 RETVAL = -1;
3140 }
ad413e46
NC
3141 OUTPUT:
3142 RETVAL
8990e307 3143
4a9d6100 3144SV *
a0d0e21e 3145lseek(fd, offset, whence)
ddc7c5c7 3146 POSIX::Fd fd
85e6fe83
LW
3147 Off_t offset
3148 int whence
4a9d6100 3149 CODE:
ddc7c5c7
JH
3150 {
3151 Off_t pos = PerlLIO_lseek(fd, offset, whence);
3152 RETVAL = sizeof(Off_t) > sizeof(IV)
3153 ? newSVnv((NV)pos) : newSViv((IV)pos);
511343a2 3154 }
4a9d6100
GS
3155 OUTPUT:
3156 RETVAL
8990e307 3157
c5661c80 3158void
8990e307
LW
3159nice(incr)
3160 int incr
15f0f28a
AE
3161 PPCODE:
3162 errno = 0;
3163 if ((incr = nice(incr)) != -1 || errno == 0) {
3164 if (incr == 0)
d3d34884 3165 XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP));
15f0f28a
AE
3166 else
3167 XPUSHs(sv_2mortal(newSViv(incr)));
3168 }
8990e307 3169
8063af02 3170void
8990e307 3171pipe()
85e6fe83
LW
3172 PPCODE:
3173 int fds[2];
85e6fe83 3174 if (pipe(fds) != -1) {
924508f0 3175 EXTEND(SP,2);
85e6fe83
LW
3176 PUSHs(sv_2mortal(newSViv(fds[0])));
3177 PUSHs(sv_2mortal(newSViv(fds[1])));
3178 }
8990e307 3179
85e6fe83 3180SysRet
a0d0e21e 3181read(fd, buffer, nbytes)
7747499c
TB
3182 PREINIT:
3183 SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3184 INPUT:
ddc7c5c7 3185 POSIX::Fd fd
7747499c
TB
3186 size_t nbytes
3187 char * buffer = sv_grow( sv_buffer, nbytes+1 );
a0d0e21e 3188 CLEANUP:
7747499c 3189 if (RETVAL >= 0) {
b162af07 3190 SvCUR_set(sv_buffer, RETVAL);
7747499c
TB
3191 SvPOK_only(sv_buffer);
3192 *SvEND(sv_buffer) = '\0';
bbce6d69 3193 SvTAINTED_on(sv_buffer);
7747499c 3194 }
8990e307 3195
85e6fe83 3196SysRet
8990e307 3197setpgid(pid, pgid)
86200d5c
JH
3198 pid_t pid
3199 pid_t pgid
8990e307 3200
86200d5c 3201pid_t
8990e307
LW
3202setsid()
3203
86200d5c 3204pid_t
8990e307 3205tcgetpgrp(fd)
ddc7c5c7 3206 POSIX::Fd fd
8990e307 3207
85e6fe83 3208SysRet
8990e307 3209tcsetpgrp(fd, pgrp_id)
ddc7c5c7 3210 POSIX::Fd fd
86200d5c 3211 pid_t pgrp_id
8990e307 3212
8063af02 3213void
8990e307 3214uname()
2304df62 3215 PPCODE:
a0d0e21e 3216#ifdef HAS_UNAME
85e6fe83 3217 struct utsname buf;
85e6fe83 3218 if (uname(&buf) >= 0) {
924508f0 3219 EXTEND(SP, 5);
d3d34884
NC
3220 PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP));
3221 PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP));
3222 PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP));
3223 PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP));
3224 PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP));
8990e307 3225 }
a0d0e21e
LW
3226#else
3227 uname((char *) 0); /* A stub to call not_here(). */
3228#endif
8990e307 3229
85e6fe83 3230SysRet
a0d0e21e 3231write(fd, buffer, nbytes)
ddc7c5c7 3232 POSIX::Fd fd
a0d0e21e
LW
3233 char * buffer
3234 size_t nbytes
3235
a0d0e21e
LW
3236void
3237abort()
3238
3239int
3240mblen(s, n)
3241 char * s
3242 size_t n
3243
3244size_t
3245mbstowcs(s, pwcs, n)
3246 wchar_t * s
3247 char * pwcs
3248 size_t n
3249
3250int
3251mbtowc(pwc, s, n)
3252 wchar_t * pwc
3253 char * s
3254 size_t n
3255
3256int
3257wcstombs(s, pwcs, n)
3258 char * s
3259 wchar_t * pwcs
3260 size_t n
3261
3262int
3263wctomb(s, wchar)
3264 char * s
3265 wchar_t wchar
3266
3267int
3268strcoll(s1, s2)
3269 char * s1
3270 char * s2
3271
a89d8a78
DH
3272void
3273strtod(str)
3274 char * str
3275 PREINIT:
3276 double num;
3277 char *unparsed;
3278 PPCODE:
67d796ae
KW
3279 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3280 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
a89d8a78
DH
3281 num = strtod(str, &unparsed);
3282 PUSHs(sv_2mortal(newSVnv(num)));
de915ff5 3283 if (GIMME_V == G_ARRAY) {
924508f0 3284 EXTEND(SP, 1);
a89d8a78
DH
3285 if (unparsed)
3286 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3287 else
6b88bc9c 3288 PUSHs(&PL_sv_undef);
a89d8a78 3289 }
67d796ae 3290 RESTORE_LC_NUMERIC_STANDARD();
a89d8a78 3291
0ff7b9da
JH
3292#ifdef HAS_STRTOLD
3293
3294void
3295strtold(str)
3296 char * str
3297 PREINIT:
3298 long double num;
3299 char *unparsed;
3300 PPCODE:
67d796ae
KW
3301 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3302 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
0ff7b9da
JH
3303 num = strtold(str, &unparsed);
3304 PUSHs(sv_2mortal(newSVnv(num)));
de915ff5 3305 if (GIMME_V == G_ARRAY) {
0ff7b9da
JH
3306 EXTEND(SP, 1);
3307 if (unparsed)
3308 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3309 else
3310 PUSHs(&PL_sv_undef);
3311 }
67d796ae 3312 RESTORE_LC_NUMERIC_STANDARD();
0ff7b9da
JH
3313
3314#endif
3315
a89d8a78
DH
3316void
3317strtol(str, base = 0)
3318 char * str
3319 int base
3320 PREINIT:
3321 long num;
3322 char *unparsed;
3323 PPCODE:
e80fee22
JH
3324 if (base == 0 || (base >= 2 && base <= 36)) {
3325 num = strtol(str, &unparsed, base);
188f97e0 3326#if IVSIZE < LONGSIZE
e80fee22
JH
3327 if (num < IV_MIN || num > IV_MAX)
3328 PUSHs(sv_2mortal(newSVnv((double)num)));
3329 else
3330#endif
3331 PUSHs(sv_2mortal(newSViv((IV)num)));
3332 if (GIMME_V == G_ARRAY) {
3333 EXTEND(SP, 1);
3334 if (unparsed)
3335 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3336 else
3337 PUSHs(&PL_sv_undef);
3338 }
3339 } else {
3340 SETERRNO(EINVAL, LIB_INVARG);
3341 PUSHs(&PL_sv_undef);
3342 if (GIMME_V == G_ARRAY) {
3343 EXTEND(SP, 1);
3344 PUSHs(&PL_sv_undef);
3345 }
3346 }
a89d8a78
DH
3347
3348void
3349strtoul(str, base = 0)
4b48cf39 3350 const char * str
a89d8a78
DH
3351 int base
3352 PREINIT:
3353 unsigned long num;
1cafb023 3354 char *unparsed = NULL;
a89d8a78 3355 PPCODE:
0f17be83
JH
3356 PERL_UNUSED_VAR(str);
3357 PERL_UNUSED_VAR(base);
e80fee22
JH
3358 if (base == 0 || (base >= 2 && base <= 36)) {
3359 num = strtoul(str, &unparsed, base);
84c133a0 3360#if IVSIZE <= LONGSIZE
e80fee22
JH
3361 if (num > IV_MAX)
3362 PUSHs(sv_2mortal(newSVnv((double)num)));
3363 else
3364#endif
3365 PUSHs(sv_2mortal(newSViv((IV)num)));
3366 if (GIMME_V == G_ARRAY) {
3367 EXTEND(SP, 1);
3368 if (unparsed)
3369 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3370 else
3371 PUSHs(&PL_sv_undef);
3372 }
3373 } else {
3374 SETERRNO(EINVAL, LIB_INVARG);
3375 PUSHs(&PL_sv_undef);
3376 if (GIMME_V == G_ARRAY) {
3377 EXTEND(SP, 1);
3378 PUSHs(&PL_sv_undef);
3379 }
3380 }
a89d8a78 3381
8063af02 3382void
a0d0e21e
LW
3383strxfrm(src)
3384 SV * src
85e6fe83 3385 CODE:
a0d0e21e
LW
3386 {
3387 STRLEN srclen;
3388 STRLEN dstlen;
6ec5f825 3389 STRLEN buflen;
a0d0e21e
LW
3390 char *p = SvPV(src,srclen);
3391 srclen++;
6ec5f825
TC
3392 buflen = srclen * 4 + 1;
3393 ST(0) = sv_2mortal(newSV(buflen));
3394 dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)buflen);
3395 if (dstlen >= buflen) {
a0d0e21e
LW
3396 dstlen++;
3397 SvGROW(ST(0), dstlen);
3398 strxfrm(SvPVX(ST(0)), p, (size_t)dstlen);
3399 dstlen--;
3400 }
b162af07 3401 SvCUR_set(ST(0), dstlen);
a0d0e21e
LW
3402 SvPOK_only(ST(0));
3403 }
3404
3405SysRet
3406mkfifo(filename, mode)
3407 char * filename
3408 Mode_t mode
b5890904
NC
3409 ALIAS:
3410 access = 1
748a9306 3411 CODE:
b5890904
NC
3412 if(ix) {
3413 RETVAL = access(filename, mode);
3414 } else {
3415 TAINT_PROPER("mkfifo");
3416 RETVAL = mkfifo(filename, mode);
3417 }
748a9306
LW
3418 OUTPUT:
3419 RETVAL
a0d0e21e
LW
3420
3421SysRet
3422tcdrain(fd)
ddc7c5c7 3423 POSIX::Fd fd
9163475a
NC
3424 ALIAS:
3425 close = 1
3426 dup = 2
3427 CODE:
05732f97
JH
3428 if (fd >= 0) {
3429 RETVAL = ix == 1 ? close(fd)
3430 : (ix < 1 ? tcdrain(fd) : dup(fd));
3431 } else {
3432 SETERRNO(EBADF,RMS_IFI);
3433 RETVAL = -1;
3434 }
9163475a
NC
3435 OUTPUT:
3436 RETVAL
a0d0e21e
LW
3437
3438
3439SysRet
3440tcflow(fd, action)
ddc7c5c7 3441 POSIX::Fd fd
a0d0e21e 3442 int action
7a004119
NC
3443 ALIAS:
3444 tcflush = 1
3445 tcsendbreak = 2
3446 CODE:
ddc7c5c7 3447 if (action >= 0) {
af823f60
JH
3448 RETVAL = ix == 1 ? tcflush(fd, action)
3449 : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action));
3450 } else {
ddc7c5c7 3451 SETERRNO(EINVAL,LIB_INVARG);
af823f60
JH
3452 RETVAL = -1;
3453 }
7a004119
NC
3454 OUTPUT:
3455 RETVAL
a0d0e21e 3456
250d97fd 3457void
c1646883 3458asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
a0d0e21e
LW
3459 int sec
3460 int min
3461 int hour
3462 int mday
3463 int mon
3464 int year
3465 int wday
3466 int yday
3467 int isdst
250d97fd
NC
3468 ALIAS:
3469 mktime = 1
3470 PPCODE:
a0d0e21e 3471 {
250d97fd 3472 dXSTARG;
a0d0e21e 3473 struct tm mytm;
a748fe11 3474 init_tm(&mytm); /* XXX workaround - see init_tm() in core util.c */
a0d0e21e
LW
3475 mytm.tm_sec = sec;
3476 mytm.tm_min = min;
3477 mytm.tm_hour = hour;
3478 mytm.tm_mday = mday;
3479 mytm.tm_mon = mon;
3480 mytm.tm_year = year;
3481 mytm.tm_wday = wday;
3482 mytm.tm_yday = yday;
3483 mytm.tm_isdst = isdst;
250d97fd 3484 if (ix) {
e2054bce
TC
3485 const time_t result = mktime(&mytm);
3486 if (result == (time_t)-1)
250d97fd
NC
3487 SvOK_off(TARG);
3488 else if (result == 0)
cf97b304 3489 sv_setpvs(TARG, "0 but true");
250d97fd
NC
3490 else
3491 sv_setiv(TARG, (IV)result);
3492 } else {
3493 sv_setpv(TARG, asctime(&mytm));
3494 }
3495 ST(0) = TARG;
3496 XSRETURN(1);
a0d0e21e 3497 }
a0d0e21e
LW
3498
3499long
3500clock()
3501
3502char *
3503ctime(time)
748a9306 3504 Time_t &time
8990e307 3505
37120919
AD
3506void
3507times()
3508 PPCODE:
3509 struct tms tms;
3510 clock_t realtime;
3511 realtime = times( &tms );
924508f0 3512 EXTEND(SP,5);
9607fc9c
PP
3513 PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) );
3514 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) );
3515 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) );
3516 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) );
3517 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) );
37120919 3518
a0d0e21e
LW
3519double
3520difftime(time1, time2)
3521 Time_t time1
3522 Time_t time2
3523
8063af02
DM
3524#XXX: if $xsubpp::WantOptimize is always the default
3525# sv_setpv(TARG, ...) could be used rather than
3526# ST(0) = sv_2mortal(newSVpv(...))
3527void
e44f695e 3528strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
dc57de01 3529 SV * fmt
a0d0e21e
LW
3530 int sec
3531 int min
3532 int hour
3533 int mday
3534 int mon
3535 int year
3536 int wday
3537 int yday
3538 int isdst
3539 CODE:
3540 {
5d37acd6 3541 char *buf;
f406a445 3542 SV *sv;
5d37acd6
DM
3543
3544 /* allowing user-supplied (rather than literal) formats
3545 * is normally frowned upon as a potential security risk;
3546 * but this is part of the API so we have to allow it */
3547 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3548 buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst);
3549 GCC_DIAG_RESTORE;
f406a445 3550 sv = sv_newmortal();
2a74cb2d 3551 if (buf) {
9717af6d
KW
3552 STRLEN len = strlen(buf);
3553 sv_usepvn_flags(sv, buf, len, SV_HAS_TRAILING_NUL);
3554 if (SvUTF8(fmt)
c5f058df 3555 || (! is_utf8_invariant_string((U8*) buf, len)
9717af6d 3556 && is_utf8_string((U8*) buf, len)
323fd7cc 3557#ifdef USE_LOCALE_TIME
130c5df3
KW
3558 && _is_cur_LC_category_utf8(LC_TIME)
3559#endif
3560 )) {
8dbe7cf7
NC
3561 SvUTF8_on(sv);
3562 }
f406a445
KW
3563 }
3564 else { /* We can't distinguish between errors and just an empty
3565 * return; in all cases just return an empty string */
3566 SvUPGRADE(sv, SVt_PV);
3567 SvPV_set(sv, (char *) "");
3568 SvPOK_on(sv);
3569 SvCUR_set(sv, 0);
3570 SvLEN_set(sv, 0); /* Won't attempt to free the string when sv
3571 gets destroyed */
3572 }
3573 ST(0) = sv;
a0d0e21e
LW
3574 }
3575
3576void
3577tzset()
81ab4c44
SH
3578 PPCODE:
3579 my_tzset(aTHX);
a0d0e21e
LW
3580
3581void
3582tzname()
3583 PPCODE:
924508f0 3584 EXTEND(SP,2);
d3d34884
NC
3585 PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP));
3586 PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP));
a0d0e21e 3587
a0d0e21e
LW
3588char *
3589ctermid(s = 0)
3ab23a19
RGS
3590 char * s = 0;
3591 CODE:
3592#ifdef HAS_CTERMID_R
e02b9112 3593 s = (char *) safemalloc((size_t) L_ctermid);
3ab23a19
RGS
3594#endif
3595 RETVAL = ctermid(s);
3596 OUTPUT:
3597 RETVAL
d1fd7089 3598 CLEANUP:
3ab23a19 3599#ifdef HAS_CTERMID_R
d1fd7089 3600 Safefree(s);
3ab23a19 3601#endif
a0d0e21e
LW
3602
3603char *
3604cuserid(s = 0)
3605 char * s = 0;
56f4542c
TJ
3606 CODE:
3607#ifdef HAS_CUSERID
3608 RETVAL = cuserid(s);
3609#else
3d50e539 3610 PERL_UNUSED_VAR(s);
56f4542c
TJ
3611 RETVAL = 0;
3612 not_here("cuserid");
3613#endif
3614 OUTPUT:
3615 RETVAL
a0d0e21e
LW
3616
3617SysRetLong
3618fpathconf(fd, name)
ddc7c5c7 3619 POSIX::Fd fd
a0d0e21e
LW
3620 int name
3621
3622SysRetLong
3623pathconf(filename, name)
3624 char * filename
3625 int name
3626
3627SysRet
3628pause()