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