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