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