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