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