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