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