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