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