This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
POSIX math: have the Perl_func wrappers for the C89 math, too.
[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
39b5f1c4
JH		 60#ifndef M_E
61# define M_E 2.71828182845904523536028747135266250
62#endif
63#ifndef M_LOG2E
64# define M_LOG2E 1.44269504088896340735992468100189214
65#endif
66#ifndef M_LOG10E
67# define M_LOG10E 0.434294481903251827651128918916605082
68#endif
69#ifndef M_LN2
70# define M_LN2 0.693147180559945309417232121458176568
71#endif
72#ifndef M_LN10
73# define M_LN10 2.30258509299404568401799145468436421
74#endif
75#ifndef M_PI
76# define M_PI 3.14159265358979323846264338327950288
77#endif
78#ifndef M_PI_2
79# define M_PI_2 1.57079632679489661923132169163975144
80#endif
81#ifndef M_PI_4
82# define M_PI_4 0.785398163397448309615660845819875721
83#endif
84#ifndef M_1_PI
85# define M_1_PI 0.318309886183790671537767526745028724
86#endif
87#ifndef M_2_PI
88# define M_2_PI 0.636619772367581343075535053490057448
89#endif
90#ifndef M_2_SQRTPI
91# define M_2_SQRTPI 1.12837916709551257389615890312154517
92#endif
93#ifndef M_SQRT2
94# define M_SQRT2 1.41421356237309504880168872420969808
95#endif
96#ifndef M_SQRT1_2
97# define M_SQRT1_2 0.707106781186547524400844362104849039
98#endif
99
a5f1a7e5
JH		 100#if !defined(INFINITY) && defined(NV_INF)
101# define INFINITY NV_INF
102#endif
103
104#if !defined(NAN) && defined(NV_NAN)
105# define NAN NV_NAN
106#endif
107
108#if !defined(Inf) && defined(NV_INF)
109# define Inf NV_INF
110#endif
111
112#if !defined(NaN) && defined(NV_NAN)
113# define NaN NV_NAN
114#endif
115
935e3c48 116/* We will have an emulation. */
3f8e6f93 117#ifndef FP_INFINITE
935e3c48
JH		 118# define FP_INFINITE 0
119# define FP_NAN 1
120# define FP_NORMAL 2
121# define FP_SUBNORMAL 3
122# define FP_ZERO 4
123#endif
124
7965edec
JH		 125/* C89 math.h:
126
127 acos asin atan atan2 ceil cos cosh exp fabs floor fmod frexp ldexp
128 log log10 modf pow sin sinh sqrt tan tanh
129
130 * Implemented in core:
131
132 atan2 cos exp log pow sin sqrt
133
9d233e12 134 * C99 math.h added:
7965edec 135
9d233e12
JH		 136 acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma fmax
137 fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal isinf
138 isless islessequal islessgreater isnan isnormal isunordered lgamma
139 log1p log2 logb lrint nan nearbyint nextafter nexttoward remainder
140 remquo rint round scalbn signbit tgamma trunc
7965edec 141
26e0f0d3 142 * Berkeley/SVID extensions:
7965edec 143
26e0f0d3 144 j0 j1 jn y0 y1 yn
7965edec 145
26e0f0d3 146 * Configure already (5.21.0) scans for:
d2bce0fd 147
26e0f0d3 148 fpclassify isfinite isinf isnan ilogb*l* signbit
d2bce0fd 149
26e0f0d3 150 * For floating-point round mode (which matters for e.g. lrint and rint)
9d233e12 151
26e0f0d3 152 fegetround fesetround
9d233e12 153
7965edec
JH		 154*/
155
9d233e12
JH		 156/* XXX Constant FP_FAST_FMA (if true, FMA is faster) */
157
5716d070
JH		 158/* XXX Add ldiv(), lldiv()? It's C99, but from stdlib.h, not math.h */
159
39b5f1c4 160/* XXX Beware old gamma() -- one cannot know whether that is the
d334ccbe
JH		 161 * gamma or the log of gamma, that's why the new tgamma and lgamma.
162 * Though also remember tgamma_r and lgamma_r. */
39b5f1c4
JH		 163
164/* XXX The truthiness of acosh() is the canary for all of the
d2bce0fd 165 * C99 math. This is very likely wrong, especially in non-UNIX lands
d334ccbe
JH		 166 * like Win32 and VMS, but also older UNIXes have issues. For Win32,
167 * and other non-fully-C99, we later do some undefines for these interfaces.
d2bce0fd
JH		 168 *
169 * But we are very trying very hard to avoid introducing separate Configure
170 * symbols for all the 40-ish new math symbols. Especially since the set
171 * of missing functions doesn't seem to follow any patterns. */
bfce4ab3 172
5716d070 173#ifdef HAS_ACOSH
03397f96
JH		 174# if defined(USE_LONG_DOUBLE) && defined(HAS_ILOGBL)
175/* There's already a symbol for ilogbl, we will use its truthiness
5716d070 176 * as the canary for all the *l variants being defined. */
7965edec
JH		 177# define c99_acosh acoshl
178# define c99_asinh asinhl
179# define c99_atanh atanhl
180# define c99_cbrt cbrtl
181# define c99_copysign copysignl
7965edec
JH		 182# define c99_erf erfl
183# define c99_erfc erfcl
184# define c99_exp2 exp2l
185# define c99_expm1 expm1l
186# define c99_fdim fdiml
187# define c99_fma fmal
188# define c99_fmax fmaxl
189# define c99_fmin fminl
190# define c99_hypot hypotl
191# define c99_ilogb ilogbl
002ae7aa 192# define c99_lgamma lgammal
7965edec
JH		 193# define c99_log1p log1pl
194# define c99_log2 log2l
195# define c99_logb logbl
196# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG
197# define c99_lrint llrintl
198# else
199# define c99_lrint lrintl
200# endif
201# define c99_nan nanl
202# define c99_nearbyint nearbyintl
203# define c99_nextafter nextafterl
204# define c99_nexttoward nexttowardl
205# define c99_remainder remainderl
206# define c99_remquo remquol
207# define c99_rint rintl
208# define c99_round roundl
209# define c99_scalbn scalbnl
5716d070
JH		 210# ifdef HAS_SIGNBIT /* possibly bad assumption */
211# define c99_signbit signbitl
212# endif
7965edec
JH		 213# define c99_tgamma tgammal
214# define c99_trunc truncl
215# else
216# define c99_acosh acosh
217# define c99_asinh asinh
218# define c99_atanh atanh
219# define c99_cbrt cbrt
220# define c99_copysign copysign
7965edec
JH		 221# define c99_erf erf
222# define c99_erfc erfc
223# define c99_exp2 exp2
224# define c99_expm1 expm1
225# define c99_fdim fdim
226# define c99_fma fma
227# define c99_fmax fmax
228# define c99_fmin fmin
229# define c99_hypot hypot
230# define c99_ilogb ilogb
231# define c99_lgamma lgamma
232# define c99_log1p log1p
233# define c99_log2 log2
234# define c99_logb logb
235# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG
236# define c99_lrint llrint
237# else
238# define c99_lrint lrint
239# endif
240# define c99_nan nan
241# define c99_nearbyint nearbyint
242# define c99_nextafter nextafter
243# define c99_nexttoward nexttoward
244# define c99_remainder remainder
245# define c99_remquo remquo
246# define c99_rint rint
247# define c99_round round
248# define c99_scalbn scalbn
5716d070
JH		 249/* We already define Perl_signbit in perl.h. */
250# ifdef HAS_SIGNBIT
251# define c99_signbit signbit
252# endif
7965edec
JH		 253# define c99_tgamma tgamma
254# define c99_trunc trunc
255# endif
03397f96 256
92d982a3
JH		 257# ifndef isunordered
258# ifdef Perl_isnan
259# define isunordered(x, y) (Perl_isnan(x) || Perl_isnan(y))
260# elif defined(HAS_UNORDERED)
261# define isunordered(x, y) unordered(x, y)
262# endif
2bf3fd6f
JH		 263# endif
264
265# if !defined(isgreater) && defined(isunordered)
266# define isgreater(x, y) (!isunordered((x), (y)) && (x) > (y))
267# define isgreaterequal(x, y) (!isunordered((x), (y)) && (x) >= (y))
268# define isless(x, y) (!isunordered((x), (y)) && (x) < (y))
269# define islessequal(x, y) (!isunordered((x), (y)) && (x) <= (y))
270# define islessgreater(x, y) (!isunordered((x), (y)) && \
271 ((x) > (y) || (y) > (x)))
272# endif
273
03397f96
JH		 274/* Check both the Configure symbol and the macro-ness (like C99 promises). */
275# if defined(HAS_FPCLASSIFY) && defined(fpclassify)
276# define c99_fpclassify fpclassify
03397f96
JH		 277# endif
278/* Like isnormal(), the isfinite(), isinf(), and isnan() are also C99
279 and also (sizeof-arg-aware) macros, but they are already well taken
280 care of by Configure et al, and defined in perl.h as
281 Perl_isfinite(), Perl_isinf(), and Perl_isnan(). */
282# ifdef isnormal
5716d070 283# define c99_isnormal isnormal
03397f96 284# endif
5716d070 285# ifdef isgreater /* canary for all the C99 is*<cmp>* macros. */
03397f96
JH		 286# define c99_isgreater isgreater
287# define c99_isgreaterequal isgreaterequal
288# define c99_isless isless
289# define c99_islessequal islessequal
290# define c99_islessgreater islessgreater
291# define c99_isunordered isunordered
292# endif
7965edec
JH		 293#endif
294
360baf49
JH		 295/* If on legacy platforms, and not using gcc, some C99 math interfaces
296 * might be missing, turn them off so that the emulations hopefully
297 * kick in. This is admittedly nasty, and fragile, but the alternative
53e66ff6
JH		 298 * is to have Configure scans for all the 40+ interfaces.
299 *
300 * In other words: if you have an incomplete (or broken) C99 math interface,
301 * #undef the c99_foo here, and let the emulations kick in. */
302
360baf49
JH		 303#ifndef __GNUC__
304
d2bce0fd
JH		 305/* HP-UX on PA-RISC is missing certain C99 math functions,
306 * but on IA64 (Integrity) these do exist. */
360baf49 307# if defined(__hpux) && defined(__hppa)
53e66ff6
JH		 308# undef c99_exp2
309# undef c99_fdim
360baf49 310# undef c99_fma
53e66ff6
JH		 311# undef c99_fmax
312# undef c99_fmin
313# undef c99_fpclassify
314# undef c99_lrint
315# undef c99_nan
316# undef c99_nearbyint
360baf49 317# undef c99_nexttoward
53e66ff6
JH		 318# undef c99_remquo
319# undef c99_round
320# undef c99_scalbn
360baf49 321# undef c99_tgamma
53e66ff6 322# undef c99_trunc
360baf49
JH		 323# endif
324
325# if defined(__irix__)
326# undef c99_ilogb
327# undef c99_exp2
328# endif
329
330# if defined(__osf__) /* Tru64 */
331# undef c99_fdim
332# undef c99_fma
333# undef c99_fmax
334# undef c99_fmin
335# undef c99_fpclassify
336# undef c99_isfinite
337# undef c99_isinf
338# undef c99_isunordered
339# undef c99_lrint
340# undef c99_nearbyint
341# undef c99_nexttoward
342# undef c99_remquo
343# undef c99_rint
344# undef c99_round
345# undef c99_scalbn
346# endif
347
d2bce0fd
JH		 348#endif
349
c0cd65b2
CB		 350/* XXX Regarding C99 math.h, VMS seems to be missing these:
351
51a0624d 352 nan nearbyint round scalbn llrint
c0cd65b2
CB		 353 */
354
355#ifdef __VMS
356# undef c99_nan
357# undef c99_nearbyint
358# undef c99_round
359# undef c99_scalbn
51a0624d
CB		 360/* Have lrint but not llrint. */
361# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG
362# undef c99_lrint
363# endif
c0cd65b2
CB		 364#endif
365
bfce4ab3
JH		 366/* XXX Regarding C99 math.h, Win32 seems to be missing these:
367
3b422749 368 erf erfc exp2 fdim fma fmax fmin fpclassify ilogb lgamma log1p log2 lrint
bfce4ab3
JH		 369 remquo rint signbit tgamma trunc
370
371 Win32 does seem to have these:
372
3b422749 373 acosh asinh atanh cbrt copysign cosh expm1 hypot log10 nan
bfce4ab3
JH		 374 nearbyint nextafter nexttoward remainder round scalbn
375
376 And the Bessel functions are defined like _this.
377*/
39b5f1c4 378
bfce4ab3 379#ifdef WIN32
3b422749
JH		 380# undef c99_erf
381# undef c99_erfc
bfce4ab3
JH		 382# undef c99_exp2
383# undef c99_fdim
384# undef c99_fma
385# undef c99_fmax
386# undef c99_fmin
387# undef c99_ilogb
388# undef c99_lgamma
389# undef c99_log1p
390# undef c99_log2
391# undef c99_lrint
392# undef c99_remquo
393# undef c99_rint
394# undef c99_signbit
395# undef c99_tgamma
396# undef c99_trunc
39b5f1c4
JH		 397
398/* Some APIs exist under Win32 with "underbar" names. */
399# undef c99_hypot
400# undef c99_logb
401# undef c99_nextafter
402# define c99_hypot _hypot
403# define c99_logb _logb
404# define c99_nextafter _nextafter
405
85c93440
JH		 406# define bessel_j0 _j0
407# define bessel_j1 _j1
408# define bessel_jn _jn
409# define bessel_y0 _y0
410# define bessel_y1 _y1
411# define bessel_yn _yn
412
5716d070 413#endif
bfce4ab3 414
39b5f1c4 415/* The Bessel functions: BSD, SVID, XPG4, and POSIX. But not C99. */
5716d070
JH		 416#ifdef HAS_J0
417# if defined(USE_LONG_DOUBLE) && defined(HAS_J0L)
418# define bessel_j0 j0l
419# define bessel_j1 j1l
420# define bessel_jn jnl
421# define bessel_y0 y0l
422# define bessel_y1 y1l
423# define bessel_yn ynl
424# else
85c93440
JH		 425# define bessel_j0 j0
426# define bessel_j1 j1
427# define bessel_jn jn
428# define bessel_y0 y0
429# define bessel_y1 y1
430# define bessel_yn yn
5716d070 431# endif
bfce4ab3
JH		 432#endif
433
39b5f1c4 434/* Emulations for missing math APIs.
bfce4ab3
JH		 435 *
436 * Keep in mind that the point of many of these functions is that
437 * they, if available, are supposed to give more precise/more
39b5f1c4
JH		 438 * numerically stable results.
439 *
440 * See e.g. http://www.johndcook.com/math_h.html
441 */
442
39b5f1c4
JH		 443#ifndef c99_acosh
444static NV my_acosh(NV x)
445{
446 return Perl_log(x + Perl_sqrt(x * x - 1));
447}
448# define c99_acosh my_acosh
449#endif
450
451#ifndef c99_asinh
452static NV my_asinh(NV x)
453{
454 return Perl_log(x + Perl_sqrt(x * x + 1));
455}
456# define c99_asinh my_asinh
457#endif
458
459#ifndef c99_atanh
460static NV my_atanh(NV x)
461{
462 return (Perl_log(1 + x) - Perl_log(1 - x)) / 2;
463}
464# define c99_atanh my_atanh
465#endif
466
467#ifndef c99_cbrt
468static NV my_cbrt(NV x)
469{
470 static const NV one_third = (NV)1.0/3;
471 return x >= 0.0 ? Perl_pow(x, one_third) : -Perl_pow(-x, one_third);
472}
473# define c99_cbrt my_cbrt
474#endif
475
476#ifndef c99_copysign
477static NV my_copysign(NV x, NV y)
478{
479 return y >= 0 ? (x < 0 ? -x : x) : (x < 0 ? x : -x);
480}
481# define c99_copysign my_copysign
482#endif
483
1ae51000 484/* XXX cosh (though c89) */
d5f4f26a 485
7895eac5
JH		 486#ifndef c99_erf
487static NV my_erf(NV x)
488{
489 /* http://www.johndcook.com/cpp_erf.html -- public domain */
490 NV a1 = 0.254829592;
491 NV a2 = -0.284496736;
492 NV a3 = 1.421413741;
493 NV a4 = -1.453152027;
494 NV a5 = 1.061405429;
495 NV p = 0.3275911;
efc74307 496 NV t, y;
7895eac5
JH		 497 int sign = x < 0 ? -1 : 1; /* Save the sign. */
498 x = PERL_ABS(x);
499
500 /* Abramowitz and Stegun formula 7.1.26 */
efc74307
JH		 501 t = 1.0 / (1.0 + p * x);
502 y = 1.0 - (((((a5*t + a4)*t) + a3)*t + a2)*t + a1) * t * exp(-x*x);
7895eac5
JH		 503
504 return sign * y;
505}
506# define c99_erf my_erf
507#endif
508
ffbadafb
JH		 509#ifndef c99_erfc
510static NV my_erfc(NV x) {
aed13ba6
JH		 511 /* This is not necessarily numerically stable, but better than nothing. */
512 return 1.0 - c99_erf(x);
ffbadafb
JH		 513}
514# define c99_erfc my_erfc
515#endif
d5f4f26a 516
39b5f1c4
JH		 517#ifndef c99_exp2
518static NV my_exp2(NV x)
519{
520 return Perl_pow((NV)2.0, x);
521}
522# define c99_exp2 my_exp2
523#endif
524
525#ifndef c99_expm1
526static NV my_expm1(NV x)
527{
528 if (PERL_ABS(x) < 1e-5)
7895eac5
JH		 529 /* http://www.johndcook.com/cpp_expm1.html -- public domain.
530 * Also including the cubic term. */
39b5f1c4
JH		 531 /* Probably not enough for long doubles. */
532 return x * (1.0 + x * (0.5 + x / 6.0)); /* Taylor series */
533 else
534 return Perl_exp(x) - 1;
535}
536# define c99_expm1 my_expm1
537#endif
538
539#ifndef c99_fdim
540static NV my_fdim(NV x, NV y)
541{
542 return x > y ? x - y : 0;
543}
544# define c99_fdim my_fdim
545#endif
546
547#ifndef c99_fmax
548static NV my_fmax(NV x, NV y)
549{
550 if (Perl_isnan(x)) {
551 return Perl_isnan(y) ? NV_NAN : y;
552 } else if (Perl_isnan(y)) {
553 return x;
554 }
555 return x > y ? x : y;
556}
557# define c99_fmax my_fmax
558#endif
559
560#ifndef c99_fmin
561static NV my_fmin(NV x, NV y)
562{
563 if (Perl_isnan(x)) {
564 return Perl_isnan(y) ? NV_NAN : y;
565 } else if (Perl_isnan(y)) {
566 return x;
567 }
568 return x < y ? x : y;
569}
570# define c99_fmin my_fmin
571#endif
572
26e0f0d3
JH		 573#ifndef c99_fpclassify
574
ea464252 575static IV my_fpclassify(NV x)
935e3c48 576{
c3607571 577#ifdef Perl_fp_class_inf
935e3c48
JH		 578 if (Perl_fp_class_inf(x)) return FP_INFINITE;
579 if (Perl_fp_class_nan(x)) return FP_NAN;
580 if (Perl_fp_class_norm(x)) return FP_NORMAL;
581 if (Perl_fp_class_denorm(x)) return FP_SUBNORMAL;
582 if (Perl_fp_class_zero(x)) return FP_ZERO;
935e3c48
JH		 583# define c99_fpclassify my_fpclassify
584#endif
c3607571 585 return -1;
935e3c48 586}
935e3c48 587
26e0f0d3
JH		 588#endif
589
39b5f1c4
JH		 590#ifndef c99_hypot
591static NV my_hypot(NV x, NV y)
592{
7bbf2c9b
JH		 593 /* http://en.wikipedia.org/wiki/Hypot */
594 NV t;
595 x = PERL_ABS(x); /* Take absolute values. */
596 if (y == 0)
597 return x;
598 if (Perl_isnan(y))
599 return NV_INF;
600 y = PERL_ABS(y);
601 if (x < y) { /* Swap so that y is less. */
602 t = x;
603 x = y;
604 y = t;
39b5f1c4 605 }
7bbf2c9b
JH		 606 t = y / x;
607 return x * sqrt(1.0 + t * t);
39b5f1c4
JH		 608}
609# define c99_hypot my_hypot
610#endif
611
612#ifndef c99_ilogb
613static IV my_ilogb(NV x)
614{
615 return (IV)(Perl_log(x) * M_LOG2E);
616}
617# define c99_ilogb my_ilogb
618#endif
619
d5f4f26a
JH		 620/* XXX lgamma -- non-trivial */
621
39b5f1c4
JH		 622#ifndef c99_log1p
623static NV my_log1p(NV x)
624{
7895eac5
JH		 625 /* http://www.johndcook.com/cpp_log_one_plus_x.html -- public domain.
626 * Including also quadratic term. */
39b5f1c4
JH		 627 if (PERL_ABS(x) > 1e-4)
628 return Perl_log(1.0 + x);
629 else
630 /* Probably not enough for long doubles. */
631 return x * (1.0 - x * (-x / 2.0 + x / 3.0)); /* Taylor series */
632}
633# define c99_log1p my_log1p
634#endif
635
636#ifndef c99_log2
637static NV my_log2(NV x)
638{
639 return Perl_log(x) * M_LOG2E;
640}
641# define c99_log2 my_log2
642#endif
643
d5f4f26a
JH		 644/* XXX nextafter */
645
646/* XXX nexttoward */
647
648static int my_fegetround()
649{
650#ifdef HAS_FEGETROUND
651 return fegetround();
652#elif defined(FLT_ROUNDS)
653 return FLT_ROUNDS;
8ef03df4
JH		 654 /* XXX emulate using fpgetround() (HAS_FPGETROUND):
655 * FP_RN to nearest, FP_RM down, FP_RP, up, FP_RZ truncate */
d5f4f26a
JH		 656#else
657 return -1;
658#endif
659}
660
661static NV my_rint(NV x)
662{
663#ifdef FE_TONEAREST
664 switch (my_fegetround()) {
665 default:
666 case FE_TONEAREST:
667 return (NV)((IV)(x >= 0.0 ? x + 0.5 : x - 0.5)); /* like round() */
668 case FE_TOWARDZERO:
669 return (NV)((IV)(x)); /* like trunc() */
670 case FE_DOWNWARD:
671 return (NV)((IV)(x >= 0.0 ? x : x - 0.5));
672 case FE_UPWARD:
673 return (NV)((IV)(x >= 0.0 ? x + 0.5 : x));
674 }
675#else
8ef03df4
JH		 676 /* XXX emulate using fpsetround() (HAS_FPGETROUND):
677 * FP_RN to nearest, FP_RM down, FP_RP, up, FP_RZ truncate */
d5f4f26a
JH		 678 return NV_NAN;
679#endif
680}
681
682/* XXX nearbyint() and rint() are not really identical -- but the difference
683 * is messy: nearbyint is defined NOT to raise FE_INEXACT floating point
684 * exceptions, while rint() is defined to MAYBE raise them. At the moment
685 * Perl is blissfully unaware of such fine detail of floating point. */
686#ifndef c99_nearbyint
687# ifdef FE_TONEAREST
688# define c99_nearbyrint my_rint
689# endif
690#endif
691
692#ifndef c99_lrint
693# ifdef FE_TONEAREST
694static IV lrint(NV x)
695{
696 return (IV)my_rint(x);
697}
698# define c99_lrint my_lrint
699# endif
700#endif
701
702/* XXX remainder */
703
704/* XXX remquo */
705
706#ifndef c99_rint
707# ifdef FE_TONEAREST
708# define c99_rint my_rint
709# endif
710#endif
711
39b5f1c4
JH		 712#ifndef c99_round
713static NV my_round(NV x)
714{
715 return (NV)((IV)(x >= 0.0 ? x + 0.5 : x - 0.5));
716}
717# define c99_round my_round
718#endif
719
720#ifndef c99_scalbn
93ddb856 721# if defined(Perl_ldexp) && FLT_RADIX == 2
ea464252 722static NV my_scalbn(NV x, int y)
39b5f1c4
JH		 723{
724 return Perl_ldexp(x, y);
725}
726# define c99_scalbn my_scalbn
727# endif
728#endif
729
1ae51000 730/* XXX sinh (though c89) */
39b5f1c4
JH		 731
732#ifndef c99_tgamma
733# ifdef c99_lgamma
734static NV my_tgamma(NV x)
735{
736 double l = c99_lgamma(x);
737 return signgam * Perl_exp(l); /* XXX evil global signgam, need lgamma_r */
738}
d5f4f26a
JH		 739# define c99_tgamma my_tgamma
740/* XXX tgamma without lgamma -- non-trivial */
39b5f1c4
JH		 741# endif
742#endif
bfce4ab3 743
1ae51000 744/* XXX tanh (though c89) */
d5f4f26a
JH		 745
746#ifndef c99_trunc
747static NV my_trunc(NV x)
748{
749 return (NV)((IV)(x));
750}
751# define c99_trunc my_trunc
752#endif
753
3609ea0d 754/* XXX This comment is just to make I_TERMIO and I_SGTTY visible to
a0d0e21e
LW		 755 metaconfig for future extension writers. We don't use them in POSIX.
756 (This is really sneaky :-) --AD
757*/
758#if defined(I_TERMIOS)
759#include <termios.h>
760#endif
a0d0e21e 761#ifdef I_STDLIB
2304df62 762#include <stdlib.h>
a0d0e21e 763#endif
5518ecd4 764#ifndef __ultrix__
2304df62 765#include <string.h>
5518ecd4 766#endif
2304df62 767#include <sys/stat.h>
2304df62 768#include <sys/types.h>
2304df62 769#include <time.h>
6dead956 770#ifdef I_UNISTD
1d2dff63 771#include <unistd.h>
6dead956 772#endif
71be2cbc 773#include <fcntl.h>
774
e2465f50 775#ifdef HAS_TZNAME
fb207d52 776# if !defined(WIN32) && !defined(__CYGWIN__) && !defined(NETWARE) && !defined(__UWIN__)
e2465f50
JH		 777extern char *tzname[];
778# endif
779#else
fb207d52 780#if !defined(WIN32) && !defined(__UWIN__) || (defined(__MINGW32__) && !defined(tzname))
e2465f50
JH		 781char *tzname[] = { "" , "" };
782#endif
cb2479a8
JH		 783#endif
784
6c418a22 785#if defined(__VMS) && !defined(__POSIX_SOURCE)
294c8bc4
CB		 786
787# include <utsname.h>
6c418a22 788
6990d991 789# undef mkfifo
6c418a22 790# define mkfifo(a,b) (not_here("mkfifo"),-1)
6c418a22 791
792 /* The POSIX notion of ttyname() is better served by getname() under VMS */
793 static char ttnambuf[64];
794# define ttyname(fd) (isatty(fd) > 0 ? getname(fd,ttnambuf,0) : NULL)
795
6c418a22 796#else
d308986b 797#if defined (__CYGWIN__)
f89d6eaa
EF		 798# define tzname _tzname
799#endif
2986a63f 800#if defined (WIN32) || defined (NETWARE)
6990d991 801# undef mkfifo
6dead956 802# define mkfifo(a,b) not_here("mkfifo")
873ef191 803# define ttyname(a) (char*)not_here("ttyname")
6dead956 804# define sigset_t long
86200d5c 805# define pid_t long
6dead956
GS		 806# ifdef _MSC_VER
807# define mode_t short
808# endif
62520c91
GS		 809# ifdef __MINGW32__
810# define mode_t short
f6c6487a
GS		 811# ifndef tzset
812# define tzset() not_here("tzset")
813# endif
814# ifndef _POSIX_OPEN_MAX
815# define _POSIX_OPEN_MAX FOPEN_MAX /* XXX bogus ? */
816# endif
62520c91 817# endif
6dead956
GS		 818# define sigaction(a,b,c) not_here("sigaction")
819# define sigpending(a) not_here("sigpending")
820# define sigprocmask(a,b,c) not_here("sigprocmask")
821# define sigsuspend(a) not_here("sigsuspend")
822# define sigemptyset(a) not_here("sigemptyset")
823# define sigaddset(a,b) not_here("sigaddset")
824# define sigdelset(a,b) not_here("sigdelset")
825# define sigfillset(a) not_here("sigfillset")
826# define sigismember(a,b) not_here("sigismember")
2986a63f 827#ifndef NETWARE
6e22d046
JH		 828# undef setuid
829# undef setgid
2986a63f
JH		 830# define setuid(a) not_here("setuid")
831# define setgid(a) not_here("setgid")
832#endif /* NETWARE */
73e21afd 833# define strtold(s1,s2) not_here("strtold")
6dead956 834#else
6990d991
JH		 835
836# ifndef HAS_MKFIFO
e37778c2 837# if defined(OS2)
d6a255e6 838# define mkfifo(a,b) not_here("mkfifo")
3609ea0d 839# else /* !( defined OS2 ) */
d6a255e6
IZ		 840# ifndef mkfifo
841# define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0))
842# endif
6990d991
JH		 843# endif
844# endif /* !HAS_MKFIFO */
845
e37778c2
NC		 846# ifdef I_GRP
847# include <grp.h>
848# endif
849# include <sys/times.h>
850# ifdef HAS_UNAME
851# include <sys/utsname.h>
6c418a22 852# endif
e37778c2 853# include <sys/wait.h>
6c418a22 854# ifdef I_UTIME
855# include <utime.h>
856# endif
2986a63f 857#endif /* WIN32 || NETWARE */
6dead956 858#endif /* __VMS */
2304df62
AD		 859
860typedef int SysRet;
a0d0e21e 861typedef long SysRetLong;
2304df62
AD		 862typedef sigset_t* POSIX__SigSet;
863typedef HV* POSIX__SigAction;
a0d0e21e
LW		 864#ifdef I_TERMIOS
865typedef struct termios* POSIX__Termios;
866#else /* Define termios types to int, and call not_here for the functions.*/
867#define POSIX__Termios int
868#define speed_t int
869#define tcflag_t int
870#define cc_t int
871#define cfgetispeed(x) not_here("cfgetispeed")
872#define cfgetospeed(x) not_here("cfgetospeed")
873#define tcdrain(x) not_here("tcdrain")
874#define tcflush(x,y) not_here("tcflush")
875#define tcsendbreak(x,y) not_here("tcsendbreak")
876#define cfsetispeed(x,y) not_here("cfsetispeed")
877#define cfsetospeed(x,y) not_here("cfsetospeed")
878#define ctermid(x) (char *) not_here("ctermid")
879#define tcflow(x,y) not_here("tcflow")
880#define tcgetattr(x,y) not_here("tcgetattr")
881#define tcsetattr(x,y,z) not_here("tcsetattr")
882#endif
883
884/* Possibly needed prototypes */
6e22d046 885#ifndef WIN32
a2e65780 886START_EXTERN_C
20ce7b12
GS		 887double strtod (const char *, char **);
888long strtol (const char *, char **, int);
889unsigned long strtoul (const char *, char **, int);
0ff7b9da
JH		 890#ifdef HAS_STRTOLD
891long double strtold (const char *, char **);
892#endif
a2e65780 893END_EXTERN_C
6e22d046 894#endif
a0d0e21e 895
a0d0e21e
LW		 896#ifndef HAS_DIFFTIME
897#ifndef difftime
898#define difftime(a,b) not_here("difftime")
899#endif
900#endif
901#ifndef HAS_FPATHCONF
3609ea0d 902#define fpathconf(f,n) (SysRetLong) not_here("fpathconf")
a0d0e21e
LW		 903#endif
904#ifndef HAS_MKTIME
905#define mktime(a) not_here("mktime")
8990e307
LW		 906#endif
907#ifndef HAS_NICE
908#define nice(a) not_here("nice")
909#endif
a0d0e21e 910#ifndef HAS_PATHCONF
3609ea0d 911#define pathconf(f,n) (SysRetLong) not_here("pathconf")
a0d0e21e
LW		 912#endif
913#ifndef HAS_SYSCONF
3609ea0d 914#define sysconf(n) (SysRetLong) not_here("sysconf")
a0d0e21e 915#endif
8990e307
LW		 916#ifndef HAS_READLINK
917#define readlink(a,b,c) not_here("readlink")
918#endif
919#ifndef HAS_SETPGID
920#define setpgid(a,b) not_here("setpgid")
921#endif
8990e307
LW		 922#ifndef HAS_SETSID
923#define setsid() not_here("setsid")
924#endif
a0d0e21e
LW		 925#ifndef HAS_STRCOLL
926#define strcoll(s1,s2) not_here("strcoll")
927#endif
a89d8a78
DH		 928#ifndef HAS_STRTOD
929#define strtod(s1,s2) not_here("strtod")
930#endif
0ff7b9da
JH		 931#ifndef HAS_STRTOLD
932#define strtold(s1,s2) not_here("strtold")
933#endif
a89d8a78
DH		 934#ifndef HAS_STRTOL
935#define strtol(s1,s2,b) not_here("strtol")
936#endif
937#ifndef HAS_STRTOUL
938#define strtoul(s1,s2,b) not_here("strtoul")
939#endif
a0d0e21e
LW		 940#ifndef HAS_STRXFRM
941#define strxfrm(s1,s2,n) not_here("strxfrm")
8990e307
LW		 942#endif
943#ifndef HAS_TCGETPGRP
944#define tcgetpgrp(a) not_here("tcgetpgrp")
945#endif
946#ifndef HAS_TCSETPGRP
947#define tcsetpgrp(a,b) not_here("tcsetpgrp")
948#endif
949#ifndef HAS_TIMES
2986a63f 950#ifndef NETWARE
8990e307 951#define times(a) not_here("times")
2986a63f 952#endif /* NETWARE */
8990e307
LW		 953#endif
954#ifndef HAS_UNAME
955#define uname(a) not_here("uname")
956#endif
957#ifndef HAS_WAITPID
958#define waitpid(a,b,c) not_here("waitpid")
959#endif
960
a0d0e21e
LW		 961#ifndef HAS_MBLEN
962#ifndef mblen
963#define mblen(a,b) not_here("mblen")
964#endif
965#endif
966#ifndef HAS_MBSTOWCS
967#define mbstowcs(s, pwcs, n) not_here("mbstowcs")
968#endif
969#ifndef HAS_MBTOWC
970#define mbtowc(pwc, s, n) not_here("mbtowc")
971#endif
972#ifndef HAS_WCSTOMBS
973#define wcstombs(s, pwcs, n) not_here("wcstombs")
974#endif
975#ifndef HAS_WCTOMB
976#define wctomb(s, wchar) not_here("wcstombs")
977#endif
978#if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB)
979/* If we don't have these functions, then we wouldn't have gotten a typedef
980 for wchar_t, the wide character type. Defining wchar_t allows the
981 functions referencing it to compile. Its actual type is then meaningless,
982 since without the above functions, all sections using it end up calling
983 not_here() and croak. --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */
984#ifndef wchar_t
985#define wchar_t char
986#endif
987#endif
988
3f3bcbfc
KW		 989#ifndef HAS_LOCALECONV
990# define localeconv() not_here("localeconv")
991#else
2f0945cb
NC		 992struct lconv_offset {
993 const char *name;
994 size_t offset;
995};
996
997const struct lconv_offset lconv_strings[] = {
03ceeedf 998#ifdef USE_LOCALE_NUMERIC
3800c318
JH		 999 {"decimal_point", STRUCT_OFFSET(struct lconv, decimal_point)},
1000 {"thousands_sep", STRUCT_OFFSET(struct lconv, thousands_sep)},
03ceeedf 1001# ifndef NO_LOCALECONV_GROUPING
3800c318 1002 {"grouping", STRUCT_OFFSET(struct lconv, grouping)},
03ceeedf 1003# endif
2f0945cb 1004#endif
03ceeedf 1005#ifdef USE_LOCALE_MONETARY
3800c318
JH		 1006 {"int_curr_symbol", STRUCT_OFFSET(struct lconv, int_curr_symbol)},
1007 {"currency_symbol", STRUCT_OFFSET(struct lconv, currency_symbol)},
1008 {"mon_decimal_point", STRUCT_OFFSET(struct lconv, mon_decimal_point)},
03ceeedf 1009# ifndef NO_LOCALECONV_MON_THOUSANDS_SEP
3800c318 1010 {"mon_thousands_sep", STRUCT_OFFSET(struct lconv, mon_thousands_sep)},
03ceeedf
KW		 1011# endif
1012# ifndef NO_LOCALECONV_MON_GROUPING
3800c318 1013 {"mon_grouping", STRUCT_OFFSET(struct lconv, mon_grouping)},
03ceeedf 1014# endif
3800c318
JH		 1015 {"positive_sign", STRUCT_OFFSET(struct lconv, positive_sign)},
1016 {"negative_sign", STRUCT_OFFSET(struct lconv, negative_sign)},
03ceeedf 1017#endif
2f0945cb
NC		 1018 {NULL, 0}
1019};
1020
c1284011
KW		 1021#ifdef USE_LOCALE_NUMERIC
1022
1023/* The Linux man pages say these are the field names for the structure
1024 * components that are LC_NUMERIC; the rest being LC_MONETARY */
1025# define isLC_NUMERIC_STRING(name) (strcmp(name, "decimal_point") \
1026 || strcmp(name, "thousands_sep") \
1027 \
1028 /* There should be no harm done \
1029 * checking for this, even if \
1030 * NO_LOCALECONV_GROUPING */ \
1031 || strcmp(name, "grouping"))
1032#else
1033# define isLC_NUMERIC_STRING(name) (0)
1034#endif
1035
2f0945cb 1036const struct lconv_offset lconv_integers[] = {
03ceeedf 1037#ifdef USE_LOCALE_MONETARY
3800c318
JH		 1038 {"int_frac_digits", STRUCT_OFFSET(struct lconv, int_frac_digits)},
1039 {"frac_digits", STRUCT_OFFSET(struct lconv, frac_digits)},
1040 {"p_cs_precedes", STRUCT_OFFSET(struct lconv, p_cs_precedes)},
1041 {"p_sep_by_space", STRUCT_OFFSET(struct lconv, p_sep_by_space)},
1042 {"n_cs_precedes", STRUCT_OFFSET(struct lconv, n_cs_precedes)},
1043 {"n_sep_by_space", STRUCT_OFFSET(struct lconv, n_sep_by_space)},
1044 {"p_sign_posn", STRUCT_OFFSET(struct lconv, p_sign_posn)},
1045 {"n_sign_posn", STRUCT_OFFSET(struct lconv, n_sign_posn)},
03ceeedf 1046#endif
2f0945cb
NC		 1047 {NULL, 0}
1048};
1049
3f3bcbfc 1050#endif /* HAS_LOCALECONV */
a0d0e21e 1051
172ea7c8 1052#ifdef HAS_LONG_DOUBLE
53796371 1053# if LONG_DOUBLESIZE > NVSIZE
172ea7c8
JH		 1054# undef HAS_LONG_DOUBLE /* XXX until we figure out how to use them */
1055# endif
1056#endif
1057
1058#ifndef HAS_LONG_DOUBLE
1059#ifdef LDBL_MAX
1060#undef LDBL_MAX
1061#endif
1062#ifdef LDBL_MIN
1063#undef LDBL_MIN
1064#endif
1065#ifdef LDBL_EPSILON
1066#undef LDBL_EPSILON
1067#endif
1068#endif
1069
ec193bec
JH		 1070/* Background: in most systems the low byte of the wait status
1071 * is the signal (the lowest 7 bits) and the coredump flag is
1072 * the eight bit, and the second lowest byte is the exit status.
1073 * BeOS bucks the trend and has the bytes in different order.
1074 * See beos/beos.c for how the reality is bent even in BeOS
1075 * to follow the traditional. However, to make the POSIX
1076 * wait W*() macros to work in BeOS, we need to unbend the
1077 * reality back in place. --jhi */
17028706
IW		 1078/* In actual fact the code below is to blame here. Perl has an internal
1079 * representation of the exit status ($?), which it re-composes from the
1080 * OS's representation using the W*() POSIX macros. The code below
1081 * incorrectly uses the W*() macros on the internal representation,
1082 * which fails for OSs that have a different representation (namely BeOS
1083 * and Haiku). WMUNGE() is a hack that converts the internal
1084 * representation into the OS specific one, so that the W*() macros work
1085 * as expected. The better solution would be not to use the W*() macros
1086 * in the first place, though. -- Ingo Weinhold
1087 */
b6c36746 1088#if defined(__HAIKU__)
ec193bec
JH		 1089# define WMUNGE(x) (((x) & 0xFF00) >> 8 | ((x) & 0x00FF) << 8)
1090#else
1091# define WMUNGE(x) (x)
1092#endif
1093
8990e307 1094static int
4b48cf39 1095not_here(const char *s)
8990e307
LW		 1096{
1097 croak("POSIX::%s not implemented on this architecture", s);
1098 return -1;
1099}
463ee0b2 1100
1cb0fb50 1101#include "const-c.inc"
a290f238 1102
1dfe7606 1103static void
40b7a5f5 1104restore_sigmask(pTHX_ SV *osset_sv)
1dfe7606 1105{
7feb700b
JH		 1106 /* Fortunately, restoring the signal mask can't fail, because
1107 * there's nothing we can do about it if it does -- we're not
1108 * supposed to return -1 from sigaction unless the disposition
1109 * was unaffected.
1110 */
7feb700b
JH		 1111 sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv );
1112 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1dfe7606
AJ		 1113}
1114
a2261f90
NC		 1115static void *
1116allocate_struct(pTHX_ SV *rv, const STRLEN size, const char *packname) {
1117 SV *const t = newSVrv(rv, packname);
1118 void *const p = sv_grow(t, size + 1);
1119
1120 SvCUR_set(t, size);
1121 SvPOK_on(t);
1122 return p;
1123}
1124
81ab4c44
SH		 1125#ifdef WIN32
1126
1127/*
1128 * (1) The CRT maintains its own copy of the environment, separate from
1129 * the Win32API copy.
1130 *
1131 * (2) CRT getenv() retrieves from this copy. CRT putenv() updates this
1132 * copy, and then calls SetEnvironmentVariableA() to update the Win32API
1133 * copy.
1134 *
1135 * (3) win32_getenv() and win32_putenv() call GetEnvironmentVariableA() and
1136 * SetEnvironmentVariableA() directly, bypassing the CRT copy of the
1137 * environment.
1138 *
1139 * (4) The CRT strftime() "%Z" implementation calls __tzset(). That
1140 * calls CRT tzset(), but only the first time it is called, and in turn
1141 * that uses CRT getenv("TZ") to retrieve the timezone info from the CRT
1142 * local copy of the environment and hence gets the original setting as
1143 * perl never updates the CRT copy when assigning to $ENV{TZ}.
1144 *
1145 * Therefore, we need to retrieve the value of $ENV{TZ} and call CRT
1146 * putenv() to update the CRT copy of the environment (if it is different)
1147 * whenever we're about to call tzset().
1148 *
1149 * In addition to all that, when perl is built with PERL_IMPLICIT_SYS
1150 * defined:
1151 *
1152 * (a) Each interpreter has its own copy of the environment inside the
1153 * perlhost structure. That allows applications that host multiple
1154 * independent Perl interpreters to isolate environment changes from
1155 * each other. (This is similar to how the perlhost mechanism keeps a
1156 * separate working directory for each Perl interpreter, so that calling
1157 * chdir() will not affect other interpreters.)
1158 *
1159 * (b) Only the first Perl interpreter instantiated within a process will
1160 * "write through" environment changes to the process environment.
1161 *
1162 * (c) Even the primary Perl interpreter won't update the CRT copy of the
1163 * the environment, only the Win32API copy (it calls win32_putenv()).
1164 *
1165 * As with CPerlHost::Getenv() and CPerlHost::Putenv() themselves, it makes
1166 * sense to only update the process environment when inside the main
1167 * interpreter, but we don't have access to CPerlHost's m_bTopLevel member
1168 * from here so we'll just have to check PL_curinterp instead.
1169 *
1170 * Therefore, we can simply #undef getenv() and putenv() so that those names
1171 * always refer to the CRT functions, and explicitly call win32_getenv() to
1172 * access perl's %ENV.
1173 *
1174 * We also #undef malloc() and free() to be sure we are using the CRT
1175 * functions otherwise under PERL_IMPLICIT_SYS they are redefined to calls
1176 * into VMem::Malloc() and VMem::Free() and all allocations will be freed
1177 * when the Perl interpreter is being destroyed so we'd end up with a pointer
1178 * into deallocated memory in environ[] if a program embedding a Perl
1179 * interpreter continues to operate even after the main Perl interpreter has
1180 * been destroyed.
1181 *
1182 * Note that we don't free() the malloc()ed memory unless and until we call
1183 * malloc() again ourselves because the CRT putenv() function simply puts its
b7b1e41b 1184 * pointer argument into the environ[] array (it doesn't make a copy of it)
81ab4c44
SH		 1185 * so this memory must otherwise be leaked.
1186 */
1187
1188#undef getenv
1189#undef putenv
1190#undef malloc
1191#undef free
1192
1193static void
1194fix_win32_tzenv(void)
1195{
1196 static char* oldenv = NULL;
1197 char* newenv;
1198 const char* perl_tz_env = win32_getenv("TZ");
1199 const char* crt_tz_env = getenv("TZ");
1200 if (perl_tz_env == NULL)
1201 perl_tz_env = "";
1202 if (crt_tz_env == NULL)
1203 crt_tz_env = "";
1204 if (strcmp(perl_tz_env, crt_tz_env) != 0) {
1205 newenv = (char*)malloc((strlen(perl_tz_env) + 4) * sizeof(char));
1206 if (newenv != NULL) {
1207 sprintf(newenv, "TZ=%s", perl_tz_env);
1208 putenv(newenv);
1209 if (oldenv != NULL)
1210 free(oldenv);
1211 oldenv = newenv;
1212 }
1213 }
1214}
1215
1216#endif
1217
1218/*
1219 * my_tzset - wrapper to tzset() with a fix to make it work (better) on Win32.
1220 * This code is duplicated in the Time-Piece module, so any changes made here
1221 * should be made there too.
1222 */
1223static void
1224my_tzset(pTHX)
1225{
1226#ifdef WIN32
1227#if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
1228 if (PL_curinterp == aTHX)
1229#endif
1230 fix_win32_tzenv();
1231#endif
1232 tzset();
1233}
1234
fb52dbc1
NC		 1235typedef int (*isfunc_t)(int);
1236typedef void (*any_dptr_t)(void *);
1237
1238/* This needs to be ALIASed in a custom way, hence can't easily be defined as
1239 a regular XSUB. */
1240static XSPROTO(is_common); /* prototype to pass -Wmissing-prototypes */
1241static XSPROTO(is_common)
1242{
1243 dXSARGS;
2da736a2 1244
fb52dbc1
NC		 1245 if (items != 1)
1246 croak_xs_usage(cv, "charstring");
1247
1248 {
1249 dXSTARG;
1250 STRLEN len;
31e107a4
KW		 1251 /*int RETVAL = 0; YYY means uncomment this to return false on an
1252 * empty string input */
fb52dbc1
NC		 1253 int RETVAL;
1254 unsigned char *s = (unsigned char *) SvPV(ST(0), len);
1255 unsigned char *e = s + len;
1256 isfunc_t isfunc = (isfunc_t) XSANY.any_dptr;
1257
2da736a2
KW		 1258 if (ckWARN_d(WARN_DEPRECATED)) {
1259
1260 /* Warn exactly once for each lexical place this function is
1261 * called. See thread at
1262 * http://markmail.org/thread/jhqcag5njmx7jpyu */
1263
5c45bbe0
TC		 1264 HV *warned = get_hv("POSIX::_warned", GV_ADD | GV_ADDMULTI);
1265 if (! hv_exists(warned, (const char *)&PL_op, sizeof(PL_op))) {
2da736a2
KW		 1266 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
1267 "Calling POSIX::%"HEKf"() is deprecated",
1268 HEKfARG(GvNAME_HEK(CvGV(cv))));
5c45bbe0 1269 hv_store(warned, (const char *)&PL_op, sizeof(PL_op), &PL_sv_yes, 0);
2da736a2
KW		 1270 }
1271 }
1272
31e107a4 1273 /*if (e > s) { YYY */
fb52dbc1
NC		 1274 for (RETVAL = 1; RETVAL && s < e; s++)
1275 if (!isfunc(*s))
1276 RETVAL = 0;
31e107a4 1277 /*} YYY */
fb52dbc1
NC		 1278 XSprePUSH;
1279 PUSHi((IV)RETVAL);
1280 }
1281 XSRETURN(1);
1282}
1283
1284MODULE = POSIX PACKAGE = POSIX
1285
1286BOOT:
1287{
1288 CV *cv;
1289 const char *file = __FILE__;
1290
df164f52
DM		 1291
1292 /* silence compiler warning about not_here() defined but not used */
1293 if (0) not_here("");
1294
fb52dbc1
NC		 1295 /* Ensure we get the function, not a macro implementation. Like the C89
1296 standard says we can... */
1297#undef isalnum
1298 cv = newXS("POSIX::isalnum", is_common, file);
1299 XSANY.any_dptr = (any_dptr_t) &isalnum;
1300#undef isalpha
1301 cv = newXS("POSIX::isalpha", is_common, file);
1302 XSANY.any_dptr = (any_dptr_t) &isalpha;
1303#undef iscntrl
1304 cv = newXS("POSIX::iscntrl", is_common, file);
1305 XSANY.any_dptr = (any_dptr_t) &iscntrl;
1306#undef isdigit
1307 cv = newXS("POSIX::isdigit", is_common, file);
1308 XSANY.any_dptr = (any_dptr_t) &isdigit;
1309#undef isgraph
1310 cv = newXS("POSIX::isgraph", is_common, file);
1311 XSANY.any_dptr = (any_dptr_t) &isgraph;
1312#undef islower
1313 cv = newXS("POSIX::islower", is_common, file);
1314 XSANY.any_dptr = (any_dptr_t) &islower;
1315#undef isprint
1316 cv = newXS("POSIX::isprint", is_common, file);
1317 XSANY.any_dptr = (any_dptr_t) &isprint;
1318#undef ispunct
1319 cv = newXS("POSIX::ispunct", is_common, file);
1320 XSANY.any_dptr = (any_dptr_t) &ispunct;
1321#undef isspace
1322 cv = newXS("POSIX::isspace", is_common, file);
1323 XSANY.any_dptr = (any_dptr_t) &isspace;
1324#undef isupper
1325 cv = newXS("POSIX::isupper", is_common, file);
1326 XSANY.any_dptr = (any_dptr_t) &isupper;
1327#undef isxdigit
1328 cv = newXS("POSIX::isxdigit", is_common, file);
1329 XSANY.any_dptr = (any_dptr_t) &isxdigit;
1330}
1331
2304df62
AD		 1332MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig
1333
92b39396 1334void
2304df62 1335new(packname = "POSIX::SigSet", ...)
d3f5e399 1336 const char * packname
2304df62
AD		 1337 CODE:
1338 {
1339 int i;
92b39396
NC		 1340 sigset_t *const s
1341 = (sigset_t *) allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
1342 sizeof(sigset_t),
1343 packname);
1344 sigemptyset(s);
a0d0e21e 1345 for (i = 1; i < items; i++)
92b39396
NC		 1346 sigaddset(s, SvIV(ST(i)));
1347 XSRETURN(1);
2304df62 1348 }
2304df62
AD		 1349
1350SysRet
df6c2df2 1351addset(sigset, sig)
2304df62
AD		 1352 POSIX::SigSet sigset
1353 int sig
df6c2df2
NC		 1354 ALIAS:
1355 delset = 1
1356 CODE:
1357 RETVAL = ix ? sigdelset(sigset, sig) : sigaddset(sigset, sig);
1358 OUTPUT:
1359 RETVAL
2304df62
AD		 1360
1361SysRet
df6c2df2 1362emptyset(sigset)
2304df62 1363 POSIX::SigSet sigset
df6c2df2
NC		 1364 ALIAS:
1365 fillset = 1
1366 CODE:
1367 RETVAL = ix ? sigfillset(sigset) : sigemptyset(sigset);
1368 OUTPUT:
1369 RETVAL
2304df62
AD		 1370
1371int
1372sigismember(sigset, sig)
1373 POSIX::SigSet sigset
1374 int sig
1375
a0d0e21e
LW		 1376MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf
1377
11a39fe4 1378void
a0d0e21e 1379new(packname = "POSIX::Termios", ...)
d3f5e399 1380 const char * packname
a0d0e21e
LW		 1381 CODE:
1382 {
1383#ifdef I_TERMIOS
a2261f90
NC		 1384 void *const p = allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
1385 sizeof(struct termios), packname);
11a39fe4
NC		 1386 /* The previous implementation stored a pointer to an uninitialised
1387 struct termios. Seems safer to initialise it, particularly as
1388 this implementation exposes the struct to prying from perl-space.
1389 */
a2261f90 1390 memset(p, 0, 1 + sizeof(struct termios));
11a39fe4 1391 XSRETURN(1);
a0d0e21e
LW		 1392#else
1393 not_here("termios");
1394#endif
1395 }
a0d0e21e
LW		 1396
1397SysRet
1398getattr(termios_ref, fd = 0)
1399 POSIX::Termios termios_ref
1400 int fd
1401 CODE:
1402 RETVAL = tcgetattr(fd, termios_ref);
1403 OUTPUT:
1404 RETVAL
1405
e08f19f5
TC		 1406# If we define TCSANOW here then both a found and not found constant sub
1407# are created causing a Constant subroutine TCSANOW redefined warning
518487b2 1408#ifndef TCSANOW
e08f19f5
TC		 1409# define DEF_SETATTR_ACTION 0
1410#else
1411# define DEF_SETATTR_ACTION TCSANOW
518487b2 1412#endif
a0d0e21e 1413SysRet
e08f19f5 1414setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION)
a0d0e21e
LW		 1415 POSIX::Termios termios_ref
1416 int fd
1417 int optional_actions
1418 CODE:
518487b2
NC		 1419 /* The second argument to the call is mandatory, but we'd like to give
1420 it a useful default. 0 isn't valid on all operating systems - on
1421 Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same
1422 values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF. */
a0d0e21e
LW		 1423 RETVAL = tcsetattr(fd, optional_actions, termios_ref);
1424 OUTPUT:
1425 RETVAL
1426
1427speed_t
2a59a32c 1428getispeed(termios_ref)
a0d0e21e 1429 POSIX::Termios termios_ref
2a59a32c
NC		 1430 ALIAS:
1431 getospeed = 1
a0d0e21e 1432 CODE:
2a59a32c 1433 RETVAL = ix ? cfgetospeed(termios_ref) : cfgetispeed(termios_ref);
a0d0e21e
LW		 1434 OUTPUT:
1435 RETVAL
1436
1437tcflag_t
2a59a32c 1438getiflag(termios_ref)
a0d0e21e 1439 POSIX::Termios termios_ref
2a59a32c
NC		 1440 ALIAS:
1441 getoflag = 1
1442 getcflag = 2
1443 getlflag = 3
a0d0e21e
LW		 1444 CODE:
1445#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2a59a32c
NC		 1446 switch(ix) {
1447 case 0:
1448 RETVAL = termios_ref->c_iflag;
1449 break;
1450 case 1:
1451 RETVAL = termios_ref->c_oflag;
1452 break;
1453 case 2:
1454 RETVAL = termios_ref->c_cflag;
1455 break;
1456 case 3:
1457 RETVAL = termios_ref->c_lflag;
1458 break;
df164f52
DM		 1459 default:
1460 RETVAL = 0; /* silence compiler warning */
2a59a32c 1461 }
a0d0e21e 1462#else
2a59a32c
NC		 1463 not_here(GvNAME(CvGV(cv)));
1464 RETVAL = 0;
a0d0e21e
LW		 1465#endif
1466 OUTPUT:
1467 RETVAL
1468
1469cc_t
1470getcc(termios_ref, ccix)
1471 POSIX::Termios termios_ref
b56fc9ec 1472 unsigned int ccix
a0d0e21e
LW		 1473 CODE:
1474#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
1475 if (ccix >= NCCS)
1476 croak("Bad getcc subscript");
1477 RETVAL = termios_ref->c_cc[ccix];
1478#else
640cc986
HM		 1479 not_here("getcc");
1480 RETVAL = 0;
a0d0e21e
LW		 1481#endif
1482 OUTPUT:
1483 RETVAL
1484
1485SysRet
2a59a32c 1486setispeed(termios_ref, speed)
a0d0e21e
LW		 1487 POSIX::Termios termios_ref
1488 speed_t speed
2a59a32c
NC		 1489 ALIAS:
1490 setospeed = 1
a0d0e21e 1491 CODE:
2a59a32c
NC		 1492 RETVAL = ix
1493 ? cfsetospeed(termios_ref, speed) : cfsetispeed(termios_ref, speed);
1494 OUTPUT:
1495 RETVAL
a0d0e21e
LW		 1496
1497void
2a59a32c 1498setiflag(termios_ref, flag)
a0d0e21e 1499 POSIX::Termios termios_ref
2a59a32c
NC		 1500 tcflag_t flag
1501 ALIAS:
1502 setoflag = 1
1503 setcflag = 2
1504 setlflag = 3
a0d0e21e
LW		 1505 CODE:
1506#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2a59a32c
NC		 1507 switch(ix) {
1508 case 0:
1509 termios_ref->c_iflag = flag;
1510 break;
1511 case 1:
1512 termios_ref->c_oflag = flag;
1513 break;
1514 case 2:
1515 termios_ref->c_cflag = flag;
1516 break;
1517 case 3:
1518 termios_ref->c_lflag = flag;
1519 break;
1520 }
a0d0e21e 1521#else
2a59a32c 1522 not_here(GvNAME(CvGV(cv)));
a0d0e21e
LW		 1523#endif
1524
1525void
1526setcc(termios_ref, ccix, cc)
1527 POSIX::Termios termios_ref
b56fc9ec 1528 unsigned int ccix
a0d0e21e
LW		 1529 cc_t cc
1530 CODE:
1531#ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
1532 if (ccix >= NCCS)
1533 croak("Bad setcc subscript");
1534 termios_ref->c_cc[ccix] = cc;
1535#else
1536 not_here("setcc");
1537#endif
1538
1539
a0d0e21e
LW		 1540MODULE = POSIX PACKAGE = POSIX
1541
1cb0fb50 1542INCLUDE: const-xs.inc
a290f238 1543
e99d581a
NC		 1544int
1545WEXITSTATUS(status)
1546 int status
72bfe1b2
NC		 1547 ALIAS:
1548 POSIX::WIFEXITED = 1
1549 POSIX::WIFSIGNALED = 2
1550 POSIX::WIFSTOPPED = 3
1551 POSIX::WSTOPSIG = 4
1552 POSIX::WTERMSIG = 5
1553 CODE:
fabb67aa
SK		 1554#if !defined(WEXITSTATUS) || !defined(WIFEXITED) || !defined(WIFSIGNALED) \
1555 || !defined(WIFSTOPPED) || !defined(WSTOPSIG) || !defined(WTERMSIG)
19c4478c
NC		 1556 RETVAL = 0; /* Silence compilers that notice this, but don't realise
1557 that not_here() can't return. */
1558#endif
72bfe1b2
NC		 1559 switch(ix) {
1560 case 0:
d49025b7 1561#ifdef WEXITSTATUS
17028706 1562 RETVAL = WEXITSTATUS(WMUNGE(status));
d49025b7
NC		 1563#else
1564 not_here("WEXITSTATUS");
1565#endif
72bfe1b2
NC		 1566 break;
1567 case 1:
d49025b7 1568#ifdef WIFEXITED
17028706 1569 RETVAL = WIFEXITED(WMUNGE(status));
d49025b7
NC		 1570#else
1571 not_here("WIFEXITED");
1572#endif
72bfe1b2
NC		 1573 break;
1574 case 2:
d49025b7 1575#ifdef WIFSIGNALED
17028706 1576 RETVAL = WIFSIGNALED(WMUNGE(status));
d49025b7
NC		 1577#else
1578 not_here("WIFSIGNALED");
1579#endif
72bfe1b2
NC		 1580 break;
1581 case 3:
d49025b7 1582#ifdef WIFSTOPPED
17028706 1583 RETVAL = WIFSTOPPED(WMUNGE(status));
d49025b7
NC		 1584#else
1585 not_here("WIFSTOPPED");
1586#endif
72bfe1b2
NC		 1587 break;
1588 case 4:
d49025b7 1589#ifdef WSTOPSIG
17028706 1590 RETVAL = WSTOPSIG(WMUNGE(status));
d49025b7
NC		 1591#else
1592 not_here("WSTOPSIG");
1593#endif
72bfe1b2
NC		 1594 break;
1595 case 5:
d49025b7 1596#ifdef WTERMSIG
17028706 1597 RETVAL = WTERMSIG(WMUNGE(status));
d49025b7
NC		 1598#else
1599 not_here("WTERMSIG");
1600#endif
72bfe1b2
NC		 1601 break;
1602 default:
c33e8be1 1603 Perl_croak(aTHX_ "Illegal alias %d for POSIX::W*", (int)ix);
72bfe1b2
NC		 1604 }
1605 OUTPUT:
1606 RETVAL
2304df62 1607
2304df62
AD		 1608SysRet
1609open(filename, flags = O_RDONLY, mode = 0666)
1610 char * filename
1611 int flags
a0d0e21e 1612 Mode_t mode
748a9306
LW		 1613 CODE:
1614 if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL))
1615 TAINT_PROPER("open");
1616 RETVAL = open(filename, flags, mode);
1617 OUTPUT:
1618 RETVAL
1619
2304df62
AD		 1620
1621HV *
1622localeconv()
1623 CODE:
3f3bcbfc
KW		 1624#ifndef HAS_LOCALECONV
1625 localeconv(); /* A stub to call not_here(). */
1626#else
2304df62 1627 struct lconv *lcbuf;
a835cd47
KW		 1628
1629 /* localeconv() deals with both LC_NUMERIC and LC_MONETARY, but
1630 * LC_MONETARY is already in the correct locale */
1631 STORE_NUMERIC_STANDARD_FORCE_LOCAL();
1632
2304df62 1633 RETVAL = newHV();
c4e79b56 1634 sv_2mortal((SV*)RETVAL);
8063af02 1635 if ((lcbuf = localeconv())) {
2f0945cb
NC		 1636 const struct lconv_offset *strings = lconv_strings;
1637 const struct lconv_offset *integers = lconv_integers;
1638 const char *ptr = (const char *) lcbuf;
1639
1640 do {
c1284011
KW		 1641 /* This string may be controlled by either LC_NUMERIC, or
1642 * LC_MONETARY */
1643 bool is_utf8_locale
1644#if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY)
1645 = _is_cur_LC_category_utf8((isLC_NUMERIC_STRING(strings->name))
1646 ? LC_NUMERIC
1647 : LC_MONETARY);
1648#elif defined(USE_LOCALE_NUMERIC)
1649 = _is_cur_LC_category_utf8(LC_NUMERIC);
1650#elif defined(USE_LOCALE_MONETARY)
1651 = _is_cur_LC_category_utf8(LC_MONETARY);
1652#else
1653 = FALSE;
1654#endif
1655
2f0945cb
NC		 1656 const char *value = *((const char **)(ptr + strings->offset));
1657
c1284011
KW		 1658 if (value && *value) {
1659 (void) hv_store(RETVAL,
1660 strings->name,
1661 strlen(strings->name),
1662 newSVpvn_utf8(value,
1663 strlen(value),
1664
1665 /* We mark it as UTF-8 if a utf8 locale
1666 * and is valid, non-ascii UTF-8 */
1667 is_utf8_locale
1668 && ! is_ascii_string((U8 *) value, 0)
1669 && is_utf8_string((U8 *) value, 0)),
1670 0);
1671 }
2f0945cb
NC		 1672 } while ((++strings)->name);
1673
1674 do {
1675 const char value = *((const char *)(ptr + integers->offset));
1676
1677 if (value != CHAR_MAX)
1678 (void) hv_store(RETVAL, integers->name,
1679 strlen(integers->name), newSViv(value), 0);
1680 } while ((++integers)->name);
2304df62 1681 }
a835cd47 1682 RESTORE_NUMERIC_STANDARD();
3f3bcbfc 1683#endif /* HAS_LOCALECONV */
2304df62
AD		 1684 OUTPUT:
1685 RETVAL
1686
1687char *
c28ee57b 1688setlocale(category, locale = 0)
2304df62 1689 int category
8e70cf7a 1690 const char * locale
1ba01ae3
SH		 1691 PREINIT:
1692 char * retval;
c28ee57b 1693 CODE:
49efabc8
KW		 1694#ifdef USE_LOCALE_NUMERIC
1695 /* A 0 (or NULL) locale means only query what the current one is. We
1696 * have the LC_NUMERIC name saved, because we are normally switched
1697 * into the C locale for it. Switch back so an LC_ALL query will yield
1698 * the correct results; all other categories don't require special
1699 * handling */
1700 if (locale == 0) {
1701 if (category == LC_NUMERIC) {
1702 XSRETURN_PV(PL_numeric_name);
1703 }
1704# ifdef LC_ALL
1705 else if (category == LC_ALL) {
1706 SET_NUMERIC_LOCAL();
1707 }
1708# endif
1709 }
1710#endif
b385bb4d
KW		 1711#ifdef WIN32 /* Use wrapper on Windows */
1712 retval = Perl_my_setlocale(aTHX_ category, locale);
1713#else
1ba01ae3 1714 retval = setlocale(category, locale);
b385bb4d 1715#endif
fbd840df 1716 if (! retval) {
49efabc8
KW		 1717 /* Should never happen that a query would return an error, but be
1718 * sure and reset to C locale */
1719 if (locale == 0) {
1720 SET_NUMERIC_STANDARD();
1721 }
fbd840df
KW		 1722 XSRETURN_UNDEF;
1723 }
49efabc8
KW		 1724
1725 /* Save retval since subsequent setlocale() calls may overwrite it. */
1726 retval = savepv(retval);
1727
1728 /* For locale == 0, we may have switched to NUMERIC_LOCAL. Switch back
1729 * */
1730 if (locale == 0) {
1731 SET_NUMERIC_STANDARD();
1732 XSRETURN_PV(retval);
1733 }
fbd840df 1734 else {
49efabc8 1735 RETVAL = retval;
36477c24 1736#ifdef USE_LOCALE_CTYPE
bbce6d69 1737 if (category == LC_CTYPE
1738#ifdef LC_ALL
1739 || category == LC_ALL
1740#endif
1741 )
1742 {
1743 char *newctype;
1744#ifdef LC_ALL
1745 if (category == LC_ALL)
1746 newctype = setlocale(LC_CTYPE, NULL);
1747 else
1748#endif
1749 newctype = RETVAL;
864dbfa3 1750 new_ctype(newctype);
bbce6d69 1751 }
36477c24 1752#endif /* USE_LOCALE_CTYPE */
1753#ifdef USE_LOCALE_COLLATE
bbce6d69 1754 if (category == LC_COLLATE
1755#ifdef LC_ALL
1756 || category == LC_ALL
1757#endif
1758 )
1759 {
1760 char *newcoll;
1761#ifdef LC_ALL
1762 if (category == LC_ALL)
1763 newcoll = setlocale(LC_COLLATE, NULL);
1764 else
1765#endif
1766 newcoll = RETVAL;
864dbfa3 1767 new_collate(newcoll);
bbce6d69 1768 }
36477c24 1769#endif /* USE_LOCALE_COLLATE */
1770#ifdef USE_LOCALE_NUMERIC
bbce6d69 1771 if (category == LC_NUMERIC
1772#ifdef LC_ALL
1773 || category == LC_ALL
1774#endif
1775 )
1776 {
1777 char *newnum;
1778#ifdef LC_ALL
1779 if (category == LC_ALL)
1780 newnum = setlocale(LC_NUMERIC, NULL);
1781 else
1782#endif
1783 newnum = RETVAL;
864dbfa3 1784 new_numeric(newnum);
bbce6d69 1785 }
36477c24 1786#endif /* USE_LOCALE_NUMERIC */
bbce6d69 1787 }
c28ee57b
JH		 1788 OUTPUT:
1789 RETVAL
1ba01ae3 1790 CLEANUP:
fbd840df 1791 Safefree(RETVAL);
2304df62 1792
e1ca407b 1793NV
2304df62 1794acos(x)
e1ca407b 1795 NV x
b256643b 1796 ALIAS:
7965edec
JH		 1797 acosh = 1
1798 asin = 2
1799 asinh = 3
1800 atan = 4
1801 atanh = 5
1802 cbrt = 6
1803 ceil = 7
1804 cosh = 8
1805 erf = 9
1806 erfc = 10
1807 exp2 = 11
1808 expm1 = 12
1809 floor = 13
1810 j0 = 14
1811 j1 = 15
1812 lgamma = 16
1813 log10 = 17
1814 log1p = 18
1815 log2 = 19
1816 logb = 20
1817 nearbyint = 21
1818 rint = 22
1819 round = 23
1820 sinh = 24
1821 tan = 25
1822 tanh = 26
1823 tgamma = 27
1824 trunc = 28
1825 y0 = 29
1826 y1 = 30
b256643b 1827 CODE:
78a0541a 1828 RETVAL = NV_NAN;
b256643b
NC		 1829 switch (ix) {
1830 case 0:
8a00eddc 1831 RETVAL = Perl_acos(x); /* C89 math */
b256643b
NC		 1832 break;
1833 case 1:
5716d070 1834#ifdef c99_acosh
7965edec 1835 RETVAL = c99_acosh(x);
5716d070
JH		 1836#else
1837 not_here("acosh");
1838#endif
b256643b
NC		 1839 break;
1840 case 2:
8a00eddc 1841 RETVAL = Perl_asin(x); /* C89 math */
b256643b
NC		 1842 break;
1843 case 3:
5716d070 1844#ifdef c99_asinh
7965edec 1845 RETVAL = c99_asinh(x);
5716d070
JH		 1846#else
1847 not_here("asinh");
1848#endif
b256643b
NC		 1849 break;
1850 case 4:
8a00eddc 1851 RETVAL = Perl_atan(x); /* C89 math */
b256643b
NC		 1852 break;
1853 case 5:
5716d070 1854#ifdef c99_atanh
7965edec 1855 RETVAL = c99_atanh(x);
5716d070
JH		 1856#else
1857 not_here("atanh");
1858#endif
b256643b
NC		 1859 break;
1860 case 6:
5716d070 1861#ifdef c99_cbrt
7965edec 1862 RETVAL = c99_cbrt(x);
5716d070
JH		 1863#else
1864 not_here("cbrt");
1865#endif
b256643b
NC		 1866 break;
1867 case 7:
8a00eddc 1868 RETVAL = Perl_ceil(x); /* C89 math */
b256643b
NC		 1869 break;
1870 case 8:
8a00eddc 1871 RETVAL = Perl_cosh(x); /* C89 math */
7965edec
JH		 1872 break;
1873 case 9:
5716d070 1874#ifdef c99_erf
7965edec 1875 RETVAL = c99_erf(x);
5716d070
JH		 1876#else
1877 not_here("erf");
1878#endif
7965edec
JH		 1879 break;
1880 case 10:
5716d070 1881#ifdef c99_erfc
d5799f37 1882 RETVAL = c99_erfc(x);
5716d070
JH		 1883#else
1884 not_here("erfc");
1885#endif
7965edec
JH		 1886 break;
1887 case 11:
5716d070 1888#ifdef c99_exp2
7965edec 1889 RETVAL = c99_exp2(x);
5716d070
JH		 1890#else
1891 not_here("exp2");
1892#endif
7965edec
JH		 1893 break;
1894 case 12:
5716d070 1895#ifdef c99_expm1
7965edec 1896 RETVAL = c99_expm1(x);
5716d070
JH		 1897#else
1898 not_here("expm1");
1899#endif
7965edec
JH		 1900 break;
1901 case 13:
8a00eddc 1902 RETVAL = Perl_floor(x); /* C89 math */
7965edec
JH		 1903 break;
1904 case 14:
5716d070 1905#ifdef bessel_j0
7965edec 1906 RETVAL = bessel_j0(x);
5716d070 1907#else
85c93440 1908 not_here("j0");
5716d070 1909#endif
7965edec
JH		 1910 break;
1911 case 15:
5716d070 1912#ifdef bessel_j1
7965edec 1913 RETVAL = bessel_j1(x);
5716d070 1914#else
85c93440 1915 not_here("j1");
5716d070 1916#endif
7965edec
JH		 1917 break;
1918 case 16:
d334ccbe
JH		 1919 /* XXX lgamma_r -- the lgamma accesses a global variable (signgam),
1920 * which is evil. Some platforms have lgamma_r, which has
1921 * extra parameter instead of the global variable. */
5716d070 1922#ifdef c99_lgamma
7965edec 1923 RETVAL = c99_lgamma(x);
5716d070
JH		 1924#else
1925 not_here("lgamma");
1926#endif
7965edec
JH		 1927 break;
1928 case 17:
5716d070 1929 RETVAL = log10(x); /* C89 math */
7965edec
JH		 1930 break;
1931 case 18:
5716d070 1932#ifdef c99_log1p
7965edec 1933 RETVAL = c99_log1p(x);
5716d070
JH		 1934#else
1935 not_here("log1p");
1936#endif
7965edec
JH		 1937 break;
1938 case 19:
5716d070 1939#ifdef c99_log2
7965edec 1940 RETVAL = c99_log2(x);
5716d070
JH		 1941#else
1942 not_here("log2");
1943#endif
7965edec
JH		 1944 break;
1945 case 20:
5716d070 1946#ifdef c99_logb
7965edec 1947 RETVAL = c99_logb(x);
5716d070
JH		 1948#else
1949 not_here("logb");
1950#endif
7965edec
JH		 1951 break;
1952 case 21:
5716d070 1953#ifdef c99_nearbyint
7965edec 1954 RETVAL = c99_nearbyint(x);
5716d070
JH		 1955#else
1956 not_here("nearbyint");
1957#endif
7965edec
JH		 1958 break;
1959 case 22:
5716d070 1960#ifdef c99_rint
7965edec 1961 RETVAL = c99_rint(x);
5716d070
JH		 1962#else
1963 not_here("rint");
1964#endif
7965edec
JH		 1965 break;
1966 case 23:
5716d070 1967#ifdef c99_round
7965edec 1968 RETVAL = c99_round(x);
5716d070
JH		 1969#else
1970 not_here("round");
1971#endif
7965edec
JH		 1972 break;
1973 case 24:
8a00eddc 1974 RETVAL = Perl_sinh(x); /* C89 math */
7965edec
JH		 1975 break;
1976 case 25:
8a00eddc 1977 RETVAL = Perl_tan(x); /* C89 math */
b256643b 1978 break;
7965edec 1979 case 26:
8a00eddc 1980 RETVAL = Perl_tanh(x); /* C89 math */
7965edec
JH		 1981 break;
1982 case 27:
d334ccbe
JH		 1983 /* XXX tgamma_r -- the lgamma accesses a global variable (signgam),
1984 * which is evil. Some platforms have tgamma_r, which has
1985 * extra parameter instead of the global variable. */
5716d070 1986#ifdef c99_tgamma
7965edec 1987 RETVAL = c99_tgamma(x);
5716d070
JH		 1988#else
1989 not_here("tgamma");
1990#endif
7965edec
JH		 1991 break;
1992 case 28:
5716d070 1993#ifdef c99_trunc
7965edec 1994 RETVAL = c99_trunc(x);
5716d070
JH		 1995#else
1996 not_here("trunc");
1997#endif
7965edec
JH		 1998 break;
1999 case 29:
5716d070 2000#ifdef bessel_y0
7965edec 2001 RETVAL = bessel_y0(x);
5716d070 2002#else
85c93440 2003 not_here("y0");
5716d070 2004#endif
7965edec
JH		 2005 break;
2006 case 30:
2007 default:
5716d070 2008#ifdef bessel_y1
7965edec 2009 RETVAL = bessel_y1(x);
5716d070 2010#else
85c93440 2011 not_here("y1");
5716d070 2012#endif
7965edec
JH		 2013 }
2014 OUTPUT:
2015 RETVAL
2016
2017IV
a5713e21
JH		 2018fegetround()
2019 CODE:
78a0541a 2020#ifdef HAS_FEGETROUND
d5f4f26a 2021 RETVAL = my_fegetround();
78a0541a
JH		 2022#else
2023 RETVAL = -1;
a5713e21
JH		 2024 not_here("fegetround");
2025#endif
2026 OUTPUT:
2027 RETVAL
2028
2029IV
2030fesetround(x)
2031 IV x
2032 CODE:
2033#ifdef HAS_FEGETROUND /* canary for fesetround */
2034 RETVAL = fesetround(x);
2035#else
78a0541a 2036 RETVAL = -1;
a5713e21
JH		 2037 not_here("fesetround");
2038#endif
2039 OUTPUT:
2040 RETVAL
2041
2042IV
7965edec
JH		 2043fpclassify(x)
2044 NV x
2045 ALIAS:
2046 ilogb = 1
2047 isfinite = 2
2048 isinf = 3
2049 isnan = 4
2050 isnormal = 5
d5f4f26a
JH		 2051 lrint = 6
2052 signbit = 7
7965edec 2053 CODE:
78a0541a 2054 RETVAL = -1;
7965edec
JH		 2055 switch (ix) {
2056 case 0:
5716d070 2057#ifdef c99_fpclassify
7965edec 2058 RETVAL = c99_fpclassify(x);
5716d070
JH		 2059#else
2060 not_here("fpclassify");
2061#endif
7965edec
JH		 2062 break;
2063 case 1:
5716d070 2064#ifdef c99_ilogb
7965edec 2065 RETVAL = c99_ilogb(x);
5716d070
JH		 2066#else
2067 not_here("ilogb");
2068#endif
7965edec
JH		 2069 break;
2070 case 2:
2071 RETVAL = Perl_isfinite(x);
2072 break;
2073 case 3:
2074 RETVAL = Perl_isinf(x);
2075 break;
2076 case 4:
2077 RETVAL = Perl_isnan(x);
2078 break;
2079 case 5:
5716d070 2080#ifdef c99_isnormal
7965edec 2081 RETVAL = c99_isnormal(x);
5716d070
JH		 2082#else
2083 not_here("isnormal");
2084#endif
7965edec
JH		 2085 break;
2086 case 6:
d5f4f26a
JH		 2087#ifdef c99_lrint
2088 RETVAL = c99_lrint(x);
2089#else
2090 not_here("lrint");
2091#endif
2092 break;
2093 case 7:
7965edec 2094 default:
5716d070
JH		 2095#ifdef Perl_signbit
2096 RETVAL = Perl_signbit(x);
2097#endif
7965edec 2098 break;
b256643b
NC		 2099 }
2100 OUTPUT:
2101 RETVAL
2304df62 2102
e1ca407b 2103NV
7965edec 2104copysign(x,y)
e1ca407b
A		 2105 NV x
2106 NV y
7965edec
JH		 2107 ALIAS:
2108 fdim = 1
2109 fmax = 2
2110 fmin = 3
2111 fmod = 4
2112 hypot = 5
2113 isgreater = 6
2114 isgreaterequal = 7
2115 isless = 8
2116 islessequal = 9
2117 islessgreater = 10
2118 isunordered = 11
2119 nextafter = 12
2120 nexttoward = 13
2121 remainder = 14
2122 CODE:
78a0541a 2123 RETVAL = NV_NAN;
7965edec
JH		 2124 switch (ix) {
2125 case 0:
5716d070 2126#ifdef c99_copysign
7965edec 2127 RETVAL = c99_copysign(x, y);
5716d070
JH		 2128#else
2129 not_here("copysign");
2130#endif
7965edec
JH		 2131 break;
2132 case 1:
5716d070 2133#ifdef c99_fdim
7965edec 2134 RETVAL = c99_fdim(x, y);
5716d070
JH		 2135#else
2136 not_here("fdim");
2137#endif
7965edec
JH		 2138 break;
2139 case 2:
5716d070 2140#ifdef c99_fmax
7965edec 2141 RETVAL = c99_fmax(x, y);
5716d070
JH		 2142#else
2143 not_here("fmax");
2144#endif
7965edec
JH		 2145 break;
2146 case 3:
5716d070 2147#ifdef c99_fmin
7965edec 2148 RETVAL = c99_fmin(x, y);
5716d070
JH		 2149#else
2150 not_here("fmin");
2151#endif
7965edec
JH		 2152 break;
2153 case 4:
8a00eddc 2154 RETVAL = Perl_fmod(x, y); /* C89 math */
7965edec
JH		 2155 break;
2156 case 5:
5716d070 2157#ifdef c99_hypot
7965edec 2158 RETVAL = c99_hypot(x, y);
5716d070
JH		 2159#else
2160 not_here("hypot");
2161#endif
7965edec
JH		 2162 break;
2163 case 6:
5716d070 2164#ifdef c99_isgreater
7965edec 2165 RETVAL = c99_isgreater(x, y);
5716d070
JH		 2166#else
2167 not_here("isgreater");
2168#endif
7965edec
JH		 2169 break;
2170 case 7:
5716d070 2171#ifdef c99_isgreaterequal
7965edec 2172 RETVAL = c99_isgreaterequal(x, y);
5716d070
JH		 2173#else
2174 not_here("isgreaterequal");
2175#endif
7965edec
JH		 2176 break;
2177 case 8:
5716d070 2178#ifdef c99_isless
7965edec 2179 RETVAL = c99_isless(x, y);
5716d070
JH		 2180#else
2181 not_here("isless");
2182#endif
7965edec
JH		 2183 break;
2184 case 9:
5716d070 2185#ifdef c99_islessequal
7965edec 2186 RETVAL = c99_islessequal(x, y);
5716d070
JH		 2187#else
2188 not_here("islessequal");
2189#endif
7965edec
JH		 2190 break;
2191 case 10:
5716d070 2192#ifdef c99_islessgreater
7965edec 2193 RETVAL = c99_islessgreater(x, y);
5716d070
JH		 2194#else
2195 not_here("islessgreater");
2196#endif
7965edec
JH		 2197 break;
2198 case 11:
5716d070 2199#ifdef c99_isunordered
7965edec 2200 RETVAL = c99_isunordered(x, y);
5716d070
JH		 2201#else
2202 not_here("isunordered");
2203#endif
7965edec
JH		 2204 break;
2205 case 12:
5716d070 2206#ifdef c99_nextafter
7965edec 2207 RETVAL = c99_nextafter(x, y);
5716d070
JH		 2208#else
2209 not_here("nextafter");
2210#endif
7965edec
JH		 2211 break;
2212 case 13:
5716d070 2213#ifdef c99_nexttoward
7965edec 2214 RETVAL = c99_nexttoward(x, y);
5716d070
JH		 2215#else
2216 not_here("nexttoward");
2217#endif
7965edec
JH		 2218 break;
2219 case 14:
2220 default:
5716d070 2221#ifdef c99_remainder
7965edec 2222 RETVAL = c99_remainder(x, y);
5716d070
JH		 2223#else
2224 not_here("remainder");
2225#endif
7965edec
JH		 2226 break;
2227 }
2228 OUTPUT:
2229 RETVAL
2304df62
AD		 2230
2231void
2232frexp(x)
e1ca407b 2233 NV x
2304df62
AD		 2234 PPCODE:
2235 int expvar;
2304df62 2236 /* (We already know stack is long enough.) */
5716d070 2237 PUSHs(sv_2mortal(newSVnv(Perl_frexp(x,&expvar)))); /* C89 math */
2304df62
AD		 2238 PUSHs(sv_2mortal(newSViv(expvar)));
2239
e1ca407b 2240NV
2304df62 2241ldexp(x,exp)
e1ca407b 2242 NV x
2304df62
AD		 2243 int exp
2244
2304df62
AD		 2245void
2246modf(x)
e1ca407b 2247 NV x
2304df62 2248 PPCODE:
e1ca407b 2249 NV intvar;
2304df62 2250 /* (We already know stack is long enough.) */
5716d070 2251 PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); /* C89 math */
2304df62
AD		 2252 PUSHs(sv_2mortal(newSVnv(intvar)));
2253
7965edec
JH		 2254void
2255remquo(x,y)
2256 NV x
2257 NV y
2258 PPCODE:
5716d070 2259#ifdef c99_remquo
7965edec
JH		 2260 int intvar;
2261 PUSHs(sv_2mortal(newSVnv(c99_remquo(x,y,&intvar))));
2262 PUSHs(sv_2mortal(newSVnv(intvar)));
5716d070
JH		 2263#else
2264 not_here("remquo");
2265#endif
7965edec
JH		 2266
2267NV
2268scalbn(x,y)
2269 NV x
2270 IV y
2271 CODE:
5716d070 2272#ifdef c99_scalbn
7965edec 2273 RETVAL = c99_scalbn(x, y);
5716d070 2274#else
78a0541a 2275 RETVAL = NV_NAN;
5716d070
JH		 2276 not_here("scalbn");
2277#endif
7965edec
JH		 2278 OUTPUT:
2279 RETVAL
2280
2281NV
2282fma(x,y,z)
2283 NV x
2284 NV y
2285 NV z
2286 CODE:
5716d070 2287#ifdef c99_fma
7965edec 2288 RETVAL = c99_fma(x, y, z);
5716d070 2289#else
78a0541a 2290 RETVAL = NV_NAN;
5716d070
JH		 2291 not_here("fma");
2292#endif
7965edec
JH		 2293 OUTPUT:
2294 RETVAL
2295
2296NV
b05fd80e 2297nan(s = 0)
7965edec
JH		 2298 char* s;
2299 CODE:
5716d070 2300#ifdef c99_nan
b05fd80e 2301 RETVAL = c99_nan(s ? s : "");
5716d070 2302#else
78a0541a 2303 RETVAL = NV_NAN;
5716d070
JH		 2304 not_here("nan");
2305#endif
7965edec
JH		 2306 OUTPUT:
2307 RETVAL
2308
2309NV
2310jn(x,y)
2311 IV x
2312 NV y
2313 ALIAS:
2314 yn = 1
2315 CODE:
78a0541a 2316 RETVAL = NV_NAN;
7965edec
JH		 2317 switch (ix) {
2318 case 0:
5716d070 2319#ifdef bessel_jn
7965edec 2320 RETVAL = bessel_jn(x, y);
5716d070
JH		 2321#else
2322 not_here("jn");
2323#endif
7965edec
JH		 2324 break;
2325 case 1:
2326 default:
5716d070 2327#ifdef bessel_yn
7965edec 2328 RETVAL = bessel_yn(x, y);
5716d070
JH		 2329#else
2330 not_here("yn");
2331#endif
7965edec
JH		 2332 break;
2333 }
2334 OUTPUT:
2335 RETVAL
2336
2304df62 2337SysRet
1dfe7606 2338sigaction(sig, optaction, oldaction = 0)
2304df62 2339 int sig
1dfe7606 2340 SV * optaction
2304df62
AD		 2341 POSIX::SigAction oldaction
2342 CODE:
2986a63f 2343#if defined(WIN32) || defined(NETWARE)
6dead956
GS		 2344 RETVAL = not_here("sigaction");
2345#else
2304df62
AD		 2346# This code is really grody because we're trying to make the signal
2347# interface look beautiful, which is hard.
2348
2304df62 2349 {
27da23d5 2350 dVAR;
1dfe7606 2351 POSIX__SigAction action;
f584eb2d 2352 GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV);
2304df62
AD		 2353 struct sigaction act;
2354 struct sigaction oact;
1dfe7606 2355 sigset_t sset;
183bde56 2356 SV *osset_sv;
27c1a449 2357 sigset_t osset;
2304df62
AD		 2358 POSIX__SigSet sigset;
2359 SV** svp;
1d81eac9 2360 SV** sigsvp;
3609ea0d 2361
516d25e8
SP		 2362 if (sig < 0) {
2363 croak("Negative signals are not allowed");
2364 }
2365
1d81eac9 2366 if (sig == 0 && SvPOK(ST(0))) {
aa07b2f6 2367 const char *s = SvPVX_const(ST(0));
1d81eac9
JH		 2368 int i = whichsig(s);
2369
2370 if (i < 0 && memEQ(s, "SIG", 3))
2371 i = whichsig(s + 3);
2372 if (i < 0) {
2373 if (ckWARN(WARN_SIGNAL))
2374 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2375 "No such signal: SIG%s", s);
2376 XSRETURN_UNDEF;
2377 }
2378 else
2379 sig = i;
2380 }
3609ea0d
JH		 2381#ifdef NSIG
2382 if (sig > NSIG) { /* NSIG - 1 is still okay. */
2383 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2384 "No such signal: %d", sig);
2385 XSRETURN_UNDEF;
2386 }
2387#endif
1d81eac9
JH		 2388 sigsvp = hv_fetch(GvHVn(siggv),
2389 PL_sig_name[sig],
2390 strlen(PL_sig_name[sig]),
2391 TRUE);
2304df62 2392
1dfe7606
AJ		 2393 /* Check optaction and set action */
2394 if(SvTRUE(optaction)) {
2395 if(sv_isa(optaction, "POSIX::SigAction"))
2396 action = (HV*)SvRV(optaction);
2397 else
2398 croak("action is not of type POSIX::SigAction");
2399 }
2400 else {
2401 action=0;
2402 }
2403
2404 /* sigaction() is supposed to look atomic. In particular, any
2405 * signal handler invoked during a sigaction() call should
2406 * see either the old or the new disposition, and not something
2407 * in between. We use sigprocmask() to make it so.
2408 */
2409 sigfillset(&sset);
2410 RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
2411 if(RETVAL == -1)
15c0d34a 2412 XSRETURN_UNDEF;
1dfe7606
AJ		 2413 ENTER;
2414 /* Restore signal mask no matter how we exit this block. */
f584eb2d 2415 osset_sv = newSVpvn((char *)(&osset), sizeof(sigset_t));
183bde56 2416 SAVEFREESV( osset_sv );
40b7a5f5 2417 SAVEDESTRUCTOR_X(restore_sigmask, osset_sv);
1dfe7606
AJ		 2418
2419 RETVAL=-1; /* In case both oldaction and action are 0. */
2420
2421 /* Remember old disposition if desired. */
2304df62 2422 if (oldaction) {
017a3ce5 2423 svp = hv_fetchs(oldaction, "HANDLER", TRUE);
1dfe7606
AJ		 2424 if(!svp)
2425 croak("Can't supply an oldaction without a HANDLER");
2426 if(SvTRUE(*sigsvp)) { /* TBD: what if "0"? */
2427 sv_setsv(*svp, *sigsvp);
2428 }
2429 else {
f584eb2d 2430 sv_setpvs(*svp, "DEFAULT");
1dfe7606
AJ		 2431 }
2432 RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
6ca4bbc9
GG		 2433 if(RETVAL == -1) {
2434 LEAVE;
15c0d34a 2435 XSRETURN_UNDEF;
6ca4bbc9 2436 }
1dfe7606 2437 /* Get back the mask. */
017a3ce5 2438 svp = hv_fetchs(oldaction, "MASK", TRUE);
1dfe7606 2439 if (sv_isa(*svp, "POSIX::SigSet")) {
92b39396 2440 sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
1dfe7606
AJ		 2441 }
2442 else {
92b39396
NC		 2443 sigset = (sigset_t *) allocate_struct(aTHX_ *svp,
2444 sizeof(sigset_t),
2445 "POSIX::SigSet");
1dfe7606
AJ		 2446 }
2447 *sigset = oact.sa_mask;
2448
2449 /* Get back the flags. */
017a3ce5 2450 svp = hv_fetchs(oldaction, "FLAGS", TRUE);
1dfe7606 2451 sv_setiv(*svp, oact.sa_flags);
d36b6582
CS		 2452
2453 /* Get back whether the old handler used safe signals. */
017a3ce5 2454 svp = hv_fetchs(oldaction, "SAFE", TRUE);
e91e3b10
RB		 2455 sv_setiv(*svp,
2456 /* compare incompatible pointers by casting to integer */
2457 PTR2nat(oact.sa_handler) == PTR2nat(PL_csighandlerp));
2304df62
AD		 2458 }
2459
2460 if (action) {
d36b6582
CS		 2461 /* Safe signals use "csighandler", which vectors through the
2462 PL_sighandlerp pointer when it's safe to do so.
2463 (BTW, "csighandler" is very different from "sighandler".) */
017a3ce5 2464 svp = hv_fetchs(action, "SAFE", FALSE);
e91e3b10
RB		 2465 act.sa_handler =
2466 DPTR2FPTR(
87d46f97 2467 void (*)(int),
e91e3b10
RB		 2468 (*svp && SvTRUE(*svp))
2469 ? PL_csighandlerp : PL_sighandlerp
2470 );
d36b6582
CS		 2471
2472 /* Vector new Perl handler through %SIG.
2473 (The core signal handlers read %SIG to dispatch.) */
017a3ce5 2474 svp = hv_fetchs(action, "HANDLER", FALSE);
2304df62
AD		 2475 if (!svp)
2476 croak("Can't supply an action without a HANDLER");
1dfe7606 2477 sv_setsv(*sigsvp, *svp);
d36b6582
CS		 2478
2479 /* This call actually calls sigaction() with almost the
2480 right settings, including appropriate interpretation
2481 of DEFAULT and IGNORE. However, why are we doing
2482 this when we're about to do it again just below? XXX */
17cffb37 2483 SvSETMAGIC(*sigsvp);
d36b6582
CS		 2484
2485 /* And here again we duplicate -- DEFAULT/IGNORE checking. */
1dfe7606 2486 if(SvPOK(*svp)) {
aa07b2f6 2487 const char *s=SvPVX_const(*svp);
1dfe7606
AJ		 2488 if(strEQ(s,"IGNORE")) {
2489 act.sa_handler = SIG_IGN;
2490 }
2491 else if(strEQ(s,"DEFAULT")) {
2492 act.sa_handler = SIG_DFL;
2493 }
1dfe7606 2494 }
2304df62
AD		 2495
2496 /* Set up any desired mask. */
017a3ce5 2497 svp = hv_fetchs(action, "MASK", FALSE);
2304df62 2498 if (svp && sv_isa(*svp, "POSIX::SigSet")) {
92b39396 2499 sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
2304df62
AD		 2500 act.sa_mask = *sigset;
2501 }
2502 else
85e6fe83 2503 sigemptyset(& act.sa_mask);
2304df62
AD		 2504
2505 /* Set up any desired flags. */
017a3ce5 2506 svp = hv_fetchs(action, "FLAGS", FALSE);
2304df62 2507 act.sa_flags = svp ? SvIV(*svp) : 0;
2304df62 2508
1dfe7606
AJ		 2509 /* Don't worry about cleaning up *sigsvp if this fails,
2510 * because that means we tried to disposition a
2511 * nonblockable signal, in which case *sigsvp is
2512 * essentially meaningless anyway.
2513 */
6c418a22 2514 RETVAL = sigaction(sig, & act, (struct sigaction *)0);
6ca4bbc9
GG		 2515 if(RETVAL == -1) {
2516 LEAVE;
a7aad5de 2517 XSRETURN_UNDEF;
6ca4bbc9 2518 }
2304df62 2519 }
1dfe7606
AJ		 2520
2521 LEAVE;
2304df62 2522 }
6dead956 2523#endif
2304df62
AD		 2524 OUTPUT:
2525 RETVAL
2526
2527SysRet
2528sigpending(sigset)
2529 POSIX::SigSet sigset
7a004119
NC		 2530 ALIAS:
2531 sigsuspend = 1
2532 CODE:
2533 RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
2534 OUTPUT:
2535 RETVAL
20120e59
LT		 2536 CLEANUP:
2537 PERL_ASYNC_CHECK();
2304df62
AD		 2538
2539SysRet
2540sigprocmask(how, sigset, oldsigset = 0)
2541 int how
b13bbac7 2542 POSIX::SigSet sigset = NO_INIT
33c27489
GS		 2543 POSIX::SigSet oldsigset = NO_INIT
2544INIT:
a3b811a7 2545 if (! SvOK(ST(1))) {
b13bbac7 2546 sigset = NULL;
a3b811a7 2547 } else if (sv_isa(ST(1), "POSIX::SigSet")) {
92b39396 2548 sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1)));
b13bbac7
AB		 2549 } else {
2550 croak("sigset is not of type POSIX::SigSet");
33c27489 2551 }
b13bbac7 2552
194cfca0 2553 if (items < 3 || ! SvOK(ST(2))) {
b13bbac7 2554 oldsigset = NULL;
a3b811a7 2555 } else if (sv_isa(ST(2), "POSIX::SigSet")) {
92b39396 2556 oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2)));
b13bbac7
AB		 2557 } else {
2558 croak("oldsigset is not of type POSIX::SigSet");
33c27489 2559 }
2304df62 2560
2304df62
AD		 2561void
2562_exit(status)
2563 int status
8990e307 2564
85e6fe83 2565SysRet
8990e307
LW		 2566dup2(fd1, fd2)
2567 int fd1
2568 int fd2
ad413e46
NC		 2569 CODE:
2570#ifdef WIN32
2571 /* RT #98912 - More Microsoft muppetry - failing to actually implemented
2572 the well known documented POSIX behaviour for a POSIX API.
2573 http://msdn.microsoft.com/en-us/library/8syseb29.aspx */
2574 RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2;
2575#else
2576 RETVAL = dup2(fd1, fd2);
2577#endif
2578 OUTPUT:
2579 RETVAL
8990e307 2580
4a9d6100 2581SV *
a0d0e21e 2582lseek(fd, offset, whence)
85e6fe83
LW		 2583 int fd
2584 Off_t offset
2585 int whence
4a9d6100
GS		 2586 CODE:
2587 Off_t pos = PerlLIO_lseek(fd, offset, whence);
2588 RETVAL = sizeof(Off_t) > sizeof(IV)
2589 ? newSVnv((NV)pos) : newSViv((IV)pos);
2590 OUTPUT:
2591 RETVAL
8990e307 2592
c5661c80 2593void
8990e307
LW		 2594nice(incr)
2595 int incr
15f0f28a
AE		 2596 PPCODE:
2597 errno = 0;
2598 if ((incr = nice(incr)) != -1 || errno == 0) {
2599 if (incr == 0)
d3d34884 2600 XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP));
15f0f28a
AE		 2601 else
2602 XPUSHs(sv_2mortal(newSViv(incr)));
2603 }
8990e307 2604
8063af02 2605void
8990e307 2606pipe()
85e6fe83
LW		 2607 PPCODE:
2608 int fds[2];
85e6fe83 2609 if (pipe(fds) != -1) {
924508f0 2610 EXTEND(SP,2);
85e6fe83
LW		 2611 PUSHs(sv_2mortal(newSViv(fds[0])));
2612 PUSHs(sv_2mortal(newSViv(fds[1])));
2613 }
8990e307 2614
85e6fe83 2615SysRet
a0d0e21e 2616read(fd, buffer, nbytes)
7747499c
TB		 2617 PREINIT:
2618 SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
2619 INPUT:
2620 int fd
2621 size_t nbytes
2622 char * buffer = sv_grow( sv_buffer, nbytes+1 );
a0d0e21e 2623 CLEANUP:
7747499c 2624 if (RETVAL >= 0) {
b162af07 2625 SvCUR_set(sv_buffer, RETVAL);
7747499c
TB		 2626 SvPOK_only(sv_buffer);
2627 *SvEND(sv_buffer) = '\0';
bbce6d69 2628 SvTAINTED_on(sv_buffer);
7747499c 2629 }
8990e307 2630
85e6fe83 2631SysRet
8990e307 2632setpgid(pid, pgid)
86200d5c
JH		 2633 pid_t pid
2634 pid_t pgid
8990e307 2635
86200d5c 2636pid_t
8990e307
LW		 2637setsid()
2638
86200d5c 2639pid_t
8990e307
LW		 2640tcgetpgrp(fd)
2641 int fd
2642
85e6fe83 2643SysRet
8990e307
LW		 2644tcsetpgrp(fd, pgrp_id)
2645 int fd
86200d5c 2646 pid_t pgrp_id
8990e307 2647
8063af02 2648void
8990e307 2649uname()
2304df62 2650 PPCODE:
a0d0e21e 2651#ifdef HAS_UNAME
85e6fe83 2652 struct utsname buf;
85e6fe83 2653 if (uname(&buf) >= 0) {
924508f0 2654 EXTEND(SP, 5);
d3d34884
NC		 2655 PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP));
2656 PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP));
2657 PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP));
2658 PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP));
2659 PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP));
8990e307 2660 }
a0d0e21e
LW		 2661#else
2662 uname((char *) 0); /* A stub to call not_here(). */
2663#endif
8990e307 2664
85e6fe83 2665SysRet
a0d0e21e
LW		 2666write(fd, buffer, nbytes)
2667 int fd
2668 char * buffer
2669 size_t nbytes
2670
33f01dd1
SH		 2671SV *
2672tmpnam()
2673 PREINIT:
2674 STRLEN i;
2675 int len;
2676 CODE:
c2b90b61 2677 RETVAL = newSVpvs("");
33f01dd1 2678 SvGROW(RETVAL, L_tmpnam);
0fadf2db
JH		 2679 /* Yes, we know tmpnam() is bad. So bad that some compilers
2680 * and linkers warn against using it. But it is here for
2681 * completeness. POSIX.pod warns against using it.
2682 *
2683 * Then again, maybe this should be removed at some point.
2684 * No point in enabling dangerous interfaces. */
33f01dd1
SH		 2685 len = strlen(tmpnam(SvPV(RETVAL, i)));
2686 SvCUR_set(RETVAL, len);
2687 OUTPUT:
2688 RETVAL
a0d0e21e
LW		 2689
2690void
2691abort()
2692
2693int
2694mblen(s, n)
2695 char * s
2696 size_t n
2697
2698size_t
2699mbstowcs(s, pwcs, n)
2700 wchar_t * s
2701 char * pwcs
2702 size_t n
2703
2704int
2705mbtowc(pwc, s, n)
2706 wchar_t * pwc
2707 char * s
2708 size_t n
2709
2710int
2711wcstombs(s, pwcs, n)
2712 char * s
2713 wchar_t * pwcs
2714 size_t n
2715
2716int
2717wctomb(s, wchar)
2718 char * s
2719 wchar_t wchar
2720
2721int
2722strcoll(s1, s2)
2723 char * s1
2724 char * s2
2725
a89d8a78
DH		 2726void
2727strtod(str)
2728 char * str
2729 PREINIT:
2730 double num;
2731 char *unparsed;
2732 PPCODE:
371d5d44 2733 STORE_NUMERIC_STANDARD_FORCE_LOCAL();
a89d8a78
DH		 2734 num = strtod(str, &unparsed);
2735 PUSHs(sv_2mortal(newSVnv(num)));
2736 if (GIMME == G_ARRAY) {
924508f0 2737 EXTEND(SP, 1);
a89d8a78
DH		 2738 if (unparsed)
2739 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
2740 else
6b88bc9c 2741 PUSHs(&PL_sv_undef);
a89d8a78 2742 }
371d5d44 2743 RESTORE_NUMERIC_STANDARD();
a89d8a78 2744
0ff7b9da
JH		 2745#ifdef HAS_STRTOLD
2746
2747void
2748strtold(str)
2749 char * str
2750 PREINIT:
2751 long double num;
2752 char *unparsed;
2753 PPCODE:
2754 STORE_NUMERIC_STANDARD_FORCE_LOCAL();
2755 num = strtold(str, &unparsed);
2756 PUSHs(sv_2mortal(newSVnv(num)));
2757 if (GIMME == G_ARRAY) {
2758 EXTEND(SP, 1);
2759 if (unparsed)
2760 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
2761 else
2762 PUSHs(&PL_sv_undef);
2763 }
2764 RESTORE_NUMERIC_STANDARD();
2765
2766#endif
2767
a89d8a78
DH		 2768void
2769strtol(str, base = 0)
2770 char * str
2771 int base
2772 PREINIT:
2773 long num;
2774 char *unparsed;
2775 PPCODE:
2776 num = strtol(str, &unparsed, base);
42718184
RB		 2777#if IVSIZE <= LONGSIZE
2778 if (num < IV_MIN || num > IV_MAX)
a89d8a78 2779 PUSHs(sv_2mortal(newSVnv((double)num)));
42718184
RB		 2780 else
2781#endif
2782 PUSHs(sv_2mortal(newSViv((IV)num)));
a89d8a78 2783 if (GIMME == G_ARRAY) {
924508f0 2784 EXTEND(SP, 1);
a89d8a78
DH		 2785 if (unparsed)
2786 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
2787 else
6b88bc9c 2788 PUSHs(&PL_sv_undef);
a89d8a78
DH		 2789 }
2790
2791void
2792strtoul(str, base = 0)
4b48cf39 2793 const char * str
a89d8a78
DH		 2794 int base
2795 PREINIT:
2796 unsigned long num;
2797 char *unparsed;
2798 PPCODE:
2799 num = strtoul(str, &unparsed, base);
84c133a0
RB		 2800#if IVSIZE <= LONGSIZE
2801 if (num > IV_MAX)
a89d8a78 2802 PUSHs(sv_2mortal(newSVnv((double)num)));
84c133a0
RB		 2803 else
2804#endif
2805 PUSHs(sv_2mortal(newSViv((IV)num)));
a89d8a78 2806 if (GIMME == G_ARRAY) {
924508f0 2807 EXTEND(SP, 1);
a89d8a78
DH		 2808 if (unparsed)
2809 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
2810 else
6b88bc9c 2811 PUSHs(&PL_sv_undef);
a89d8a78
DH		 2812 }
2813
8063af02 2814void
a0d0e21e
LW		 2815strxfrm(src)
2816 SV * src
85e6fe83 2817 CODE:
a0d0e21e
LW		 2818 {
2819 STRLEN srclen;
2820 STRLEN dstlen;
6ec5f825 2821 STRLEN buflen;
a0d0e21e
LW		 2822 char *p = SvPV(src,srclen);
2823 srclen++;
6ec5f825
TC		 2824 buflen = srclen * 4 + 1;
2825 ST(0) = sv_2mortal(newSV(buflen));
2826 dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)buflen);
2827 if (dstlen >= buflen) {
a0d0e21e
LW		 2828 dstlen++;
2829 SvGROW(ST(0), dstlen);
2830 strxfrm(SvPVX(ST(0)), p, (size_t)dstlen);
2831 dstlen--;
2832 }
b162af07 2833 SvCUR_set(ST(0), dstlen);
a0d0e21e
LW		 2834 SvPOK_only(ST(0));
2835 }
2836
2837SysRet
2838mkfifo(filename, mode)
2839 char * filename
2840 Mode_t mode
b5890904
NC		 2841 ALIAS:
2842 access = 1
748a9306 2843 CODE:
b5890904
NC		 2844 if(ix) {
2845 RETVAL = access(filename, mode);
2846 } else {
2847 TAINT_PROPER("mkfifo");
2848 RETVAL = mkfifo(filename, mode);
2849 }
748a9306
LW		 2850 OUTPUT:
2851 RETVAL
a0d0e21e
LW		 2852
2853SysRet
2854tcdrain(fd)
2855 int fd
9163475a
NC		 2856 ALIAS:
2857 close = 1
2858 dup = 2
2859 CODE:
2860 RETVAL = ix == 1 ? close(fd)
2861 : (ix < 1 ? tcdrain(fd) : dup(fd));
2862 OUTPUT:
2863 RETVAL
a0d0e21e
LW		 2864
2865
2866SysRet
2867tcflow(fd, action)
2868 int fd
2869 int action
7a004119
NC		 2870 ALIAS:
2871 tcflush = 1
2872 tcsendbreak = 2
2873 CODE:
2874 RETVAL = ix == 1 ? tcflush(fd, action)
2875 : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action));
2876 OUTPUT:
2877 RETVAL
a0d0e21e 2878
250d97fd 2879void
c1646883 2880asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
a0d0e21e
LW		 2881 int sec
2882 int min
2883 int hour
2884 int mday
2885 int mon
2886 int year
2887 int wday
2888 int yday
2889 int isdst
250d97fd
NC		 2890 ALIAS:
2891 mktime = 1
2892 PPCODE:
a0d0e21e 2893 {
250d97fd 2894 dXSTARG;
a0d0e21e 2895 struct tm mytm;
a748fe11 2896 init_tm(&mytm); /* XXX workaround - see init_tm() in core util.c */
a0d0e21e
LW		 2897 mytm.tm_sec = sec;
2898 mytm.tm_min = min;
2899 mytm.tm_hour = hour;
2900 mytm.tm_mday = mday;
2901 mytm.tm_mon = mon;
2902 mytm.tm_year = year;
2903 mytm.tm_wday = wday;
2904 mytm.tm_yday = yday;
2905 mytm.tm_isdst = isdst;
250d97fd 2906 if (ix) {
e2054bce
TC		 2907 const time_t result = mktime(&mytm);
2908 if (result == (time_t)-1)
250d97fd
NC		 2909 SvOK_off(TARG);
2910 else if (result == 0)
2911 sv_setpvn(TARG, "0 but true", 10);
2912 else
2913 sv_setiv(TARG, (IV)result);
2914 } else {
2915 sv_setpv(TARG, asctime(&mytm));
2916 }
2917 ST(0) = TARG;
2918 XSRETURN(1);
a0d0e21e 2919 }
a0d0e21e
LW		 2920
2921long
2922clock()
2923
2924char *
2925ctime(time)
748a9306 2926 Time_t &time
8990e307 2927
37120919
AD		 2928void
2929times()
2930 PPCODE:
2931 struct tms tms;
2932 clock_t realtime;
2933 realtime = times( &tms );
924508f0 2934 EXTEND(SP,5);
9607fc9c 2935 PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) );
2936 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) );
2937 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) );
2938 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) );
2939 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) );
37120919 2940
a0d0e21e
LW		 2941double
2942difftime(time1, time2)
2943 Time_t time1
2944 Time_t time2
2945
8063af02
DM		 2946#XXX: if $xsubpp::WantOptimize is always the default
2947# sv_setpv(TARG, ...) could be used rather than
2948# ST(0) = sv_2mortal(newSVpv(...))
2949void
e44f695e 2950strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
dc57de01 2951 SV * fmt
a0d0e21e
LW		 2952 int sec
2953 int min
2954 int hour
2955 int mday
2956 int mon
2957 int year
2958 int wday
2959 int yday
2960 int isdst
2961 CODE:
2962 {
5d37acd6 2963 char *buf;
f406a445 2964 SV *sv;
5d37acd6
DM		 2965
2966 /* allowing user-supplied (rather than literal) formats
2967 * is normally frowned upon as a potential security risk;
2968 * but this is part of the API so we have to allow it */
2969 GCC_DIAG_IGNORE(-Wformat-nonliteral);
2970 buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst);
2971 GCC_DIAG_RESTORE;
f406a445 2972 sv = sv_newmortal();
2a74cb2d 2973 if (buf) {
9717af6d
KW		 2974 STRLEN len = strlen(buf);
2975 sv_usepvn_flags(sv, buf, len, SV_HAS_TRAILING_NUL);
2976 if (SvUTF8(fmt)
2977 || (! is_ascii_string((U8*) buf, len)
2978 && is_utf8_string((U8*) buf, len)
323fd7cc 2979#ifdef USE_LOCALE_TIME
130c5df3
KW		 2980 && _is_cur_LC_category_utf8(LC_TIME)
2981#endif
2982 )) {
8dbe7cf7
NC		 2983 SvUTF8_on(sv);
2984 }
f406a445
KW		 2985 }
2986 else { /* We can't distinguish between errors and just an empty
2987 * return; in all cases just return an empty string */
2988 SvUPGRADE(sv, SVt_PV);
2989 SvPV_set(sv, (char *) "");
2990 SvPOK_on(sv);
2991 SvCUR_set(sv, 0);
2992 SvLEN_set(sv, 0); /* Won't attempt to free the string when sv
2993 gets destroyed */
2994 }
2995 ST(0) = sv;
a0d0e21e
LW		 2996 }
2997
2998void
2999tzset()
81ab4c44
SH		 3000 PPCODE:
3001 my_tzset(aTHX);
a0d0e21e
LW		 3002
3003void
3004tzname()
3005 PPCODE:
924508f0 3006 EXTEND(SP,2);
d3d34884
NC		 3007 PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP));
3008 PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP));
a0d0e21e 3009
a0d0e21e
LW		 3010char *
3011ctermid(s = 0)
3ab23a19
RGS		 3012 char * s = 0;
3013 CODE:
3014#ifdef HAS_CTERMID_R
e02b9112 3015 s = (char *) safemalloc((size_t) L_ctermid);
3ab23a19
RGS		 3016#endif
3017 RETVAL = ctermid(s);
3018 OUTPUT:
3019 RETVAL
d1fd7089 3020 CLEANUP:
3ab23a19 3021#ifdef HAS_CTERMID_R
d1fd7089 3022 Safefree(s);
3ab23a19 3023#endif
a0d0e21e
LW		 3024
3025char *
3026cuserid(s = 0)
3027 char * s = 0;
56f4542c
TJ		 3028 CODE:
3029#ifdef HAS_CUSERID
3030 RETVAL = cuserid(s);
3031#else
3032 RETVAL = 0;
3033 not_here("cuserid");
3034#endif
3035 OUTPUT:
3036 RETVAL
a0d0e21e
LW		 3037
3038SysRetLong
3039fpathconf(fd, name)
3040 int fd
3041 int name
3042
3043SysRetLong
3044pathconf(filename, name)
3045 char * filename
3046 int name
3047
3048SysRet
3049pause()
20120e59
LT		 3050 CLEANUP:
3051 PERL_ASYNC_CHECK();
a0d0e21e 3052
a387c53a
NC		 3053unsigned int
3054sleep(seconds)
3055 unsigned int seconds
3056 CODE:
3057 RETVAL = PerlProc_sleep(seconds);
3058 OUTPUT:
3059 RETVAL
3060
a043a685
GW		 3061SysRet
3062setgid(gid)
3063 Gid_t gid
3064
3065SysRet
3066setuid(uid)
3067 Uid_t uid
3068
a0d0e21e
LW		 3069SysRetLong
3070sysconf(name)
3071 int name
3072
3073char *
3074ttyname(fd)
3075 int fd
a043a685 3076
c6c619a9 3077void
b5846a0b 3078getcwd()
8f95b30d
JH		 3079 PPCODE:
3080 {
3081 dXSTARG;
89423764 3082 getcwd_sv(TARG);
8f95b30d
JH		 3083 XSprePUSH; PUSHTARG;
3084 }
3085
0d7021f5
RGS		 3086SysRet
3087lchown(uid, gid, path)
3088 Uid_t uid
3089 Gid_t gid
3090 char * path
3091 CODE:
3092#ifdef HAS_LCHOWN
3093 /* yes, the order of arguments is different,
3094 * but consistent with CORE::chown() */
3095 RETVAL = lchown(path, uid, gid);
3096#else
3097 RETVAL = not_here("lchown");
3098#endif
3099 OUTPUT:
3100 RETVAL
Unnamed repository; edit this file 'description' to name the repository.