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