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