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