This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
261fa34c2b09862e8c6f8fc6d3020d87765c17e4
[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 = (int)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 #ifndef USE_LONG_DOUBLE
1138 #  define strtold(s1,s2)        not_here("strtold")
1139 #endif  /* USE_LONG_DOUBLE */
1140 #else
1141
1142 #  ifndef HAS_MKFIFO
1143 #    if defined(OS2)
1144 #      define mkfifo(a,b) not_here("mkfifo")
1145 #    else       /* !( defined OS2 ) */
1146 #      ifndef mkfifo
1147 #        define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0))
1148 #      endif
1149 #    endif
1150 #  endif /* !HAS_MKFIFO */
1151
1152 #  ifdef I_GRP
1153 #    include <grp.h>
1154 #  endif
1155 #  include <sys/times.h>
1156 #  ifdef HAS_UNAME
1157 #    include <sys/utsname.h>
1158 #  endif
1159 #  include <sys/wait.h>
1160 #  ifdef I_UTIME
1161 #    include <utime.h>
1162 #  endif
1163 #endif /* WIN32 || NETWARE */
1164 #endif /* __VMS */
1165
1166 typedef int SysRet;
1167 typedef long SysRetLong;
1168 typedef sigset_t* POSIX__SigSet;
1169 typedef HV* POSIX__SigAction;
1170 #ifdef I_TERMIOS
1171 typedef struct termios* POSIX__Termios;
1172 #else /* Define termios types to int, and call not_here for the functions.*/
1173 #define POSIX__Termios int
1174 #define speed_t int
1175 #define tcflag_t int
1176 #define cc_t int
1177 #define cfgetispeed(x) not_here("cfgetispeed")
1178 #define cfgetospeed(x) not_here("cfgetospeed")
1179 #define tcdrain(x) not_here("tcdrain")
1180 #define tcflush(x,y) not_here("tcflush")
1181 #define tcsendbreak(x,y) not_here("tcsendbreak")
1182 #define cfsetispeed(x,y) not_here("cfsetispeed")
1183 #define cfsetospeed(x,y) not_here("cfsetospeed")
1184 #define ctermid(x) (char *) not_here("ctermid")
1185 #define tcflow(x,y) not_here("tcflow")
1186 #define tcgetattr(x,y) not_here("tcgetattr")
1187 #define tcsetattr(x,y,z) not_here("tcsetattr")
1188 #endif
1189
1190 /* Possibly needed prototypes */
1191 #ifndef WIN32
1192 START_EXTERN_C
1193 double strtod (const char *, char **);
1194 long strtol (const char *, char **, int);
1195 unsigned long strtoul (const char *, char **, int);
1196 #ifdef HAS_STRTOLD
1197 long double strtold (const char *, char **);
1198 #endif
1199 END_EXTERN_C
1200 #endif
1201
1202 #ifndef HAS_DIFFTIME
1203 #ifndef difftime
1204 #define difftime(a,b) not_here("difftime")
1205 #endif
1206 #endif
1207 #ifndef HAS_FPATHCONF
1208 #define fpathconf(f,n)  (SysRetLong) not_here("fpathconf")
1209 #endif
1210 #ifndef HAS_MKTIME
1211 #define mktime(a) not_here("mktime")
1212 #endif
1213 #ifndef HAS_NICE
1214 #define nice(a) not_here("nice")
1215 #endif
1216 #ifndef HAS_PATHCONF
1217 #define pathconf(f,n)   (SysRetLong) not_here("pathconf")
1218 #endif
1219 #ifndef HAS_SYSCONF
1220 #define sysconf(n)      (SysRetLong) not_here("sysconf")
1221 #endif
1222 #ifndef HAS_READLINK
1223 #define readlink(a,b,c) not_here("readlink")
1224 #endif
1225 #ifndef HAS_SETPGID
1226 #define setpgid(a,b) not_here("setpgid")
1227 #endif
1228 #ifndef HAS_SETSID
1229 #define setsid() not_here("setsid")
1230 #endif
1231 #ifndef HAS_STRCOLL
1232 #define strcoll(s1,s2) not_here("strcoll")
1233 #endif
1234 #ifndef HAS_STRTOD
1235 #define strtod(s1,s2) not_here("strtod")
1236 #endif
1237 #ifndef HAS_STRTOLD
1238 #define strtold(s1,s2) not_here("strtold")
1239 #endif
1240 #ifndef HAS_STRTOL
1241 #define strtol(s1,s2,b) not_here("strtol")
1242 #endif
1243 #ifndef HAS_STRTOUL
1244 #define strtoul(s1,s2,b) not_here("strtoul")
1245 #endif
1246 #ifndef HAS_STRXFRM
1247 #define strxfrm(s1,s2,n) not_here("strxfrm")
1248 #endif
1249 #ifndef HAS_TCGETPGRP
1250 #define tcgetpgrp(a) not_here("tcgetpgrp")
1251 #endif
1252 #ifndef HAS_TCSETPGRP
1253 #define tcsetpgrp(a,b) not_here("tcsetpgrp")
1254 #endif
1255 #ifndef HAS_TIMES
1256 #ifndef NETWARE
1257 #define times(a) not_here("times")
1258 #endif  /* NETWARE */
1259 #endif
1260 #ifndef HAS_UNAME
1261 #define uname(a) not_here("uname")
1262 #endif
1263 #ifndef HAS_WAITPID
1264 #define waitpid(a,b,c) not_here("waitpid")
1265 #endif
1266
1267 #ifndef HAS_MBLEN
1268 #ifndef mblen
1269 #define mblen(a,b) not_here("mblen")
1270 #endif
1271 #endif
1272 #ifndef HAS_MBSTOWCS
1273 #define mbstowcs(s, pwcs, n) not_here("mbstowcs")
1274 #endif
1275 #ifndef HAS_MBTOWC
1276 #define mbtowc(pwc, s, n) not_here("mbtowc")
1277 #endif
1278 #ifndef HAS_WCSTOMBS
1279 #define wcstombs(s, pwcs, n) not_here("wcstombs")
1280 #endif
1281 #ifndef HAS_WCTOMB
1282 #define wctomb(s, wchar) not_here("wcstombs")
1283 #endif
1284 #if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB)
1285 /* If we don't have these functions, then we wouldn't have gotten a typedef
1286    for wchar_t, the wide character type.  Defining wchar_t allows the
1287    functions referencing it to compile.  Its actual type is then meaningless,
1288    since without the above functions, all sections using it end up calling
1289    not_here() and croak.  --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */
1290 #ifndef wchar_t
1291 #define wchar_t char
1292 #endif
1293 #endif
1294
1295 #ifndef HAS_LOCALECONV
1296 #   define localeconv() not_here("localeconv")
1297 #else
1298 struct lconv_offset {
1299     const char *name;
1300     size_t offset;
1301 };
1302
1303 const struct lconv_offset lconv_strings[] = {
1304 #ifdef USE_LOCALE_NUMERIC
1305     {"decimal_point",     STRUCT_OFFSET(struct lconv, decimal_point)},
1306     {"thousands_sep",     STRUCT_OFFSET(struct lconv, thousands_sep)},
1307 #  ifndef NO_LOCALECONV_GROUPING
1308     {"grouping",          STRUCT_OFFSET(struct lconv, grouping)},
1309 #  endif
1310 #endif
1311 #ifdef USE_LOCALE_MONETARY
1312     {"int_curr_symbol",   STRUCT_OFFSET(struct lconv, int_curr_symbol)},
1313     {"currency_symbol",   STRUCT_OFFSET(struct lconv, currency_symbol)},
1314     {"mon_decimal_point", STRUCT_OFFSET(struct lconv, mon_decimal_point)},
1315 #  ifndef NO_LOCALECONV_MON_THOUSANDS_SEP
1316     {"mon_thousands_sep", STRUCT_OFFSET(struct lconv, mon_thousands_sep)},
1317 #  endif
1318 #  ifndef NO_LOCALECONV_MON_GROUPING
1319     {"mon_grouping",      STRUCT_OFFSET(struct lconv, mon_grouping)},
1320 #  endif
1321     {"positive_sign",     STRUCT_OFFSET(struct lconv, positive_sign)},
1322     {"negative_sign",     STRUCT_OFFSET(struct lconv, negative_sign)},
1323 #endif
1324     {NULL, 0}
1325 };
1326
1327 #ifdef USE_LOCALE_NUMERIC
1328
1329 /* The Linux man pages say these are the field names for the structure
1330  * components that are LC_NUMERIC; the rest being LC_MONETARY */
1331 #   define isLC_NUMERIC_STRING(name) (strcmp(name, "decimal_point")     \
1332                                       || strcmp(name, "thousands_sep")  \
1333                                                                         \
1334                                       /* There should be no harm done   \
1335                                        * checking for this, even if     \
1336                                        * NO_LOCALECONV_GROUPING */      \
1337                                       || strcmp(name, "grouping"))
1338 #else
1339 #   define isLC_NUMERIC_STRING(name) (0)
1340 #endif
1341
1342 const struct lconv_offset lconv_integers[] = {
1343 #ifdef USE_LOCALE_MONETARY
1344     {"int_frac_digits",   STRUCT_OFFSET(struct lconv, int_frac_digits)},
1345     {"frac_digits",       STRUCT_OFFSET(struct lconv, frac_digits)},
1346     {"p_cs_precedes",     STRUCT_OFFSET(struct lconv, p_cs_precedes)},
1347     {"p_sep_by_space",    STRUCT_OFFSET(struct lconv, p_sep_by_space)},
1348     {"n_cs_precedes",     STRUCT_OFFSET(struct lconv, n_cs_precedes)},
1349     {"n_sep_by_space",    STRUCT_OFFSET(struct lconv, n_sep_by_space)},
1350     {"p_sign_posn",       STRUCT_OFFSET(struct lconv, p_sign_posn)},
1351     {"n_sign_posn",       STRUCT_OFFSET(struct lconv, n_sign_posn)},
1352 #ifdef HAS_LC_MONETARY_2008
1353     {"int_p_cs_precedes",  STRUCT_OFFSET(struct lconv, int_p_cs_precedes)},
1354     {"int_p_sep_by_space", STRUCT_OFFSET(struct lconv, int_p_sep_by_space)},
1355     {"int_n_cs_precedes",  STRUCT_OFFSET(struct lconv, int_n_cs_precedes)},
1356     {"int_n_sep_by_space", STRUCT_OFFSET(struct lconv, int_n_sep_by_space)},
1357     {"int_p_sign_posn",    STRUCT_OFFSET(struct lconv, int_p_sign_posn)},
1358     {"int_n_sign_posn",    STRUCT_OFFSET(struct lconv, int_n_sign_posn)},
1359 #endif
1360 #endif
1361     {NULL, 0}
1362 };
1363
1364 #endif /* HAS_LOCALECONV */
1365
1366 #ifdef HAS_LONG_DOUBLE
1367 #  if LONG_DOUBLESIZE > NVSIZE
1368 #    undef HAS_LONG_DOUBLE  /* XXX until we figure out how to use them */
1369 #  endif
1370 #endif
1371
1372 #ifndef HAS_LONG_DOUBLE
1373 #ifdef LDBL_MAX
1374 #undef LDBL_MAX
1375 #endif
1376 #ifdef LDBL_MIN
1377 #undef LDBL_MIN
1378 #endif
1379 #ifdef LDBL_EPSILON
1380 #undef LDBL_EPSILON
1381 #endif
1382 #endif
1383
1384 /* Background: in most systems the low byte of the wait status
1385  * is the signal (the lowest 7 bits) and the coredump flag is
1386  * the eight bit, and the second lowest byte is the exit status.
1387  * BeOS bucks the trend and has the bytes in different order.
1388  * See beos/beos.c for how the reality is bent even in BeOS
1389  * to follow the traditional.  However, to make the POSIX
1390  * wait W*() macros to work in BeOS, we need to unbend the
1391  * reality back in place. --jhi */
1392 /* In actual fact the code below is to blame here. Perl has an internal
1393  * representation of the exit status ($?), which it re-composes from the
1394  * OS's representation using the W*() POSIX macros. The code below
1395  * incorrectly uses the W*() macros on the internal representation,
1396  * which fails for OSs that have a different representation (namely BeOS
1397  * and Haiku). WMUNGE() is a hack that converts the internal
1398  * representation into the OS specific one, so that the W*() macros work
1399  * as expected. The better solution would be not to use the W*() macros
1400  * in the first place, though. -- Ingo Weinhold
1401  */
1402 #if defined(__HAIKU__)
1403 #    define WMUNGE(x) (((x) & 0xFF00) >> 8 | ((x) & 0x00FF) << 8)
1404 #else
1405 #    define WMUNGE(x) (x)
1406 #endif
1407
1408 static int
1409 not_here(const char *s)
1410 {
1411     croak("POSIX::%s not implemented on this architecture", s);
1412     return -1;
1413 }
1414
1415 #include "const-c.inc"
1416
1417 static void
1418 restore_sigmask(pTHX_ SV *osset_sv)
1419 {
1420      /* Fortunately, restoring the signal mask can't fail, because
1421       * there's nothing we can do about it if it does -- we're not
1422       * supposed to return -1 from sigaction unless the disposition
1423       * was unaffected.
1424       */
1425      sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv );
1426      (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1427 }
1428
1429 static void *
1430 allocate_struct(pTHX_ SV *rv, const STRLEN size, const char *packname) {
1431     SV *const t = newSVrv(rv, packname);
1432     void *const p = sv_grow(t, size + 1);
1433
1434     SvCUR_set(t, size);
1435     SvPOK_on(t);
1436     return p;
1437 }
1438
1439 #ifdef WIN32
1440
1441 /*
1442  * (1) The CRT maintains its own copy of the environment, separate from
1443  * the Win32API copy.
1444  *
1445  * (2) CRT getenv() retrieves from this copy. CRT putenv() updates this
1446  * copy, and then calls SetEnvironmentVariableA() to update the Win32API
1447  * copy.
1448  *
1449  * (3) win32_getenv() and win32_putenv() call GetEnvironmentVariableA() and
1450  * SetEnvironmentVariableA() directly, bypassing the CRT copy of the
1451  * environment.
1452  *
1453  * (4) The CRT strftime() "%Z" implementation calls __tzset(). That
1454  * calls CRT tzset(), but only the first time it is called, and in turn
1455  * that uses CRT getenv("TZ") to retrieve the timezone info from the CRT
1456  * local copy of the environment and hence gets the original setting as
1457  * perl never updates the CRT copy when assigning to $ENV{TZ}.
1458  *
1459  * Therefore, we need to retrieve the value of $ENV{TZ} and call CRT
1460  * putenv() to update the CRT copy of the environment (if it is different)
1461  * whenever we're about to call tzset().
1462  *
1463  * In addition to all that, when perl is built with PERL_IMPLICIT_SYS
1464  * defined:
1465  *
1466  * (a) Each interpreter has its own copy of the environment inside the
1467  * perlhost structure. That allows applications that host multiple
1468  * independent Perl interpreters to isolate environment changes from
1469  * each other. (This is similar to how the perlhost mechanism keeps a
1470  * separate working directory for each Perl interpreter, so that calling
1471  * chdir() will not affect other interpreters.)
1472  *
1473  * (b) Only the first Perl interpreter instantiated within a process will
1474  * "write through" environment changes to the process environment.
1475  *
1476  * (c) Even the primary Perl interpreter won't update the CRT copy of the
1477  * the environment, only the Win32API copy (it calls win32_putenv()).
1478  *
1479  * As with CPerlHost::Getenv() and CPerlHost::Putenv() themselves, it makes
1480  * sense to only update the process environment when inside the main
1481  * interpreter, but we don't have access to CPerlHost's m_bTopLevel member
1482  * from here so we'll just have to check PL_curinterp instead.
1483  *
1484  * Therefore, we can simply #undef getenv() and putenv() so that those names
1485  * always refer to the CRT functions, and explicitly call win32_getenv() to
1486  * access perl's %ENV.
1487  *
1488  * We also #undef malloc() and free() to be sure we are using the CRT
1489  * functions otherwise under PERL_IMPLICIT_SYS they are redefined to calls
1490  * into VMem::Malloc() and VMem::Free() and all allocations will be freed
1491  * when the Perl interpreter is being destroyed so we'd end up with a pointer
1492  * into deallocated memory in environ[] if a program embedding a Perl
1493  * interpreter continues to operate even after the main Perl interpreter has
1494  * been destroyed.
1495  *
1496  * Note that we don't free() the malloc()ed memory unless and until we call
1497  * malloc() again ourselves because the CRT putenv() function simply puts its
1498  * pointer argument into the environ[] array (it doesn't make a copy of it)
1499  * so this memory must otherwise be leaked.
1500  */
1501
1502 #undef getenv
1503 #undef putenv
1504 #undef malloc
1505 #undef free
1506
1507 static void
1508 fix_win32_tzenv(void)
1509 {
1510     static char* oldenv = NULL;
1511     char* newenv;
1512     const char* perl_tz_env = win32_getenv("TZ");
1513     const char* crt_tz_env = getenv("TZ");
1514     if (perl_tz_env == NULL)
1515         perl_tz_env = "";
1516     if (crt_tz_env == NULL)
1517         crt_tz_env = "";
1518     if (strcmp(perl_tz_env, crt_tz_env) != 0) {
1519         newenv = (char*)malloc((strlen(perl_tz_env) + 4) * sizeof(char));
1520         if (newenv != NULL) {
1521             sprintf(newenv, "TZ=%s", perl_tz_env);
1522             putenv(newenv);
1523             if (oldenv != NULL)
1524                 free(oldenv);
1525             oldenv = newenv;
1526         }
1527     }
1528 }
1529
1530 #endif
1531
1532 /*
1533  * my_tzset - wrapper to tzset() with a fix to make it work (better) on Win32.
1534  * This code is duplicated in the Time-Piece module, so any changes made here
1535  * should be made there too.
1536  */
1537 static void
1538 my_tzset(pTHX)
1539 {
1540 #ifdef WIN32
1541 #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
1542     if (PL_curinterp == aTHX)
1543 #endif
1544         fix_win32_tzenv();
1545 #endif
1546     tzset();
1547 }
1548
1549 typedef int (*isfunc_t)(int);
1550 typedef void (*any_dptr_t)(void *);
1551
1552 /* This needs to be ALIASed in a custom way, hence can't easily be defined as
1553    a regular XSUB.  */
1554 static XSPROTO(is_common); /* prototype to pass -Wmissing-prototypes */
1555 static XSPROTO(is_common)
1556 {
1557     dXSARGS;
1558
1559     if (items != 1)
1560        croak_xs_usage(cv,  "charstring");
1561
1562     {
1563         dXSTARG;
1564         STRLEN  len;
1565         /*int   RETVAL = 0;   YYY means uncomment this to return false on an
1566                             * empty string input */
1567         int     RETVAL;
1568         unsigned char *s = (unsigned char *) SvPV(ST(0), len);
1569         unsigned char *e = s + len;
1570         isfunc_t isfunc = (isfunc_t) XSANY.any_dptr;
1571
1572         if (ckWARN_d(WARN_DEPRECATED)) {
1573
1574             /* Warn exactly once for each lexical place this function is
1575              * called.  See thread at
1576              * http://markmail.org/thread/jhqcag5njmx7jpyu */
1577
1578             HV *warned = get_hv("POSIX::_warned", GV_ADD | GV_ADDMULTI);
1579             if (! hv_exists(warned, (const char *)&PL_op, sizeof(PL_op))) {
1580                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
1581                             "Calling POSIX::%"HEKf"() is deprecated",
1582                             HEKfARG(GvNAME_HEK(CvGV(cv))));
1583                 (void)hv_store(warned, (const char *)&PL_op, sizeof(PL_op), &PL_sv_yes, 0);
1584             }
1585         }
1586
1587         /*if (e > s) { YYY */
1588         for (RETVAL = 1; RETVAL && s < e; s++)
1589             if (!isfunc(*s))
1590                 RETVAL = 0;
1591         /*} YYY */
1592         XSprePUSH;
1593         PUSHi((IV)RETVAL);
1594     }
1595     XSRETURN(1);
1596 }
1597
1598 MODULE = POSIX          PACKAGE = POSIX
1599
1600 BOOT:
1601 {
1602     CV *cv;
1603     const char *file = __FILE__;
1604
1605
1606     /* silence compiler warning about not_here() defined but not used */
1607     if (0) not_here("");
1608
1609     /* Ensure we get the function, not a macro implementation. Like the C89
1610        standard says we can...  */
1611 #undef isalnum
1612     cv = newXS("POSIX::isalnum", is_common, file);
1613     XSANY.any_dptr = (any_dptr_t) &isalnum;
1614 #undef isalpha
1615     cv = newXS("POSIX::isalpha", is_common, file);
1616     XSANY.any_dptr = (any_dptr_t) &isalpha;
1617 #undef iscntrl
1618     cv = newXS("POSIX::iscntrl", is_common, file);
1619     XSANY.any_dptr = (any_dptr_t) &iscntrl;
1620 #undef isdigit
1621     cv = newXS("POSIX::isdigit", is_common, file);
1622     XSANY.any_dptr = (any_dptr_t) &isdigit;
1623 #undef isgraph
1624     cv = newXS("POSIX::isgraph", is_common, file);
1625     XSANY.any_dptr = (any_dptr_t) &isgraph;
1626 #undef islower
1627     cv = newXS("POSIX::islower", is_common, file);
1628     XSANY.any_dptr = (any_dptr_t) &islower;
1629 #undef isprint
1630     cv = newXS("POSIX::isprint", is_common, file);
1631     XSANY.any_dptr = (any_dptr_t) &isprint;
1632 #undef ispunct
1633     cv = newXS("POSIX::ispunct", is_common, file);
1634     XSANY.any_dptr = (any_dptr_t) &ispunct;
1635 #undef isspace
1636     cv = newXS("POSIX::isspace", is_common, file);
1637     XSANY.any_dptr = (any_dptr_t) &isspace;
1638 #undef isupper
1639     cv = newXS("POSIX::isupper", is_common, file);
1640     XSANY.any_dptr = (any_dptr_t) &isupper;
1641 #undef isxdigit
1642     cv = newXS("POSIX::isxdigit", is_common, file);
1643     XSANY.any_dptr = (any_dptr_t) &isxdigit;
1644 }
1645
1646 MODULE = SigSet         PACKAGE = POSIX::SigSet         PREFIX = sig
1647
1648 void
1649 new(packname = "POSIX::SigSet", ...)
1650     const char *        packname
1651     CODE:
1652         {
1653             int i;
1654             sigset_t *const s
1655                 = (sigset_t *) allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
1656                                                sizeof(sigset_t),
1657                                                packname);
1658             sigemptyset(s);
1659             for (i = 1; i < items; i++)
1660                 sigaddset(s, SvIV(ST(i)));
1661             XSRETURN(1);
1662         }
1663
1664 SysRet
1665 addset(sigset, sig)
1666         POSIX::SigSet   sigset
1667         int             sig
1668    ALIAS:
1669         delset = 1
1670    CODE:
1671         RETVAL = ix ? sigdelset(sigset, sig) : sigaddset(sigset, sig);
1672    OUTPUT:
1673         RETVAL
1674
1675 SysRet
1676 emptyset(sigset)
1677         POSIX::SigSet   sigset
1678    ALIAS:
1679         fillset = 1
1680    CODE:
1681         RETVAL = ix ? sigfillset(sigset) : sigemptyset(sigset);
1682    OUTPUT:
1683         RETVAL
1684
1685 int
1686 sigismember(sigset, sig)
1687         POSIX::SigSet   sigset
1688         int             sig
1689
1690 MODULE = Termios        PACKAGE = POSIX::Termios        PREFIX = cf
1691
1692 void
1693 new(packname = "POSIX::Termios", ...)
1694     const char *        packname
1695     CODE:
1696         {
1697 #ifdef I_TERMIOS
1698             void *const p = allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
1699                                             sizeof(struct termios), packname);
1700             /* The previous implementation stored a pointer to an uninitialised
1701                struct termios. Seems safer to initialise it, particularly as
1702                this implementation exposes the struct to prying from perl-space.
1703             */
1704             memset(p, 0, 1 + sizeof(struct termios));
1705             XSRETURN(1);
1706 #else
1707             not_here("termios");
1708 #endif
1709         }
1710
1711 SysRet
1712 getattr(termios_ref, fd = 0)
1713         POSIX::Termios  termios_ref
1714         int             fd
1715     CODE:
1716         RETVAL = tcgetattr(fd, termios_ref);
1717     OUTPUT:
1718         RETVAL
1719
1720 # If we define TCSANOW here then both a found and not found constant sub
1721 # are created causing a Constant subroutine TCSANOW redefined warning
1722 #ifndef TCSANOW
1723 #  define DEF_SETATTR_ACTION 0
1724 #else
1725 #  define DEF_SETATTR_ACTION TCSANOW
1726 #endif
1727 SysRet
1728 setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION)
1729         POSIX::Termios  termios_ref
1730         int             fd
1731         int             optional_actions
1732     CODE:
1733         /* The second argument to the call is mandatory, but we'd like to give
1734            it a useful default. 0 isn't valid on all operating systems - on
1735            Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same
1736            values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF.  */
1737         RETVAL = tcsetattr(fd, optional_actions, termios_ref);
1738     OUTPUT:
1739         RETVAL
1740
1741 speed_t
1742 getispeed(termios_ref)
1743         POSIX::Termios  termios_ref
1744     ALIAS:
1745         getospeed = 1
1746     CODE:
1747         RETVAL = ix ? cfgetospeed(termios_ref) : cfgetispeed(termios_ref);
1748     OUTPUT:
1749         RETVAL
1750
1751 tcflag_t
1752 getiflag(termios_ref)
1753         POSIX::Termios  termios_ref
1754     ALIAS:
1755         getoflag = 1
1756         getcflag = 2
1757         getlflag = 3
1758     CODE:
1759 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
1760         switch(ix) {
1761         case 0:
1762             RETVAL = termios_ref->c_iflag;
1763             break;
1764         case 1:
1765             RETVAL = termios_ref->c_oflag;
1766             break;
1767         case 2:
1768             RETVAL = termios_ref->c_cflag;
1769             break;
1770         case 3:
1771             RETVAL = termios_ref->c_lflag;
1772             break;
1773         default:
1774             RETVAL = 0; /* silence compiler warning */
1775         }
1776 #else
1777         not_here(GvNAME(CvGV(cv)));
1778         RETVAL = 0;
1779 #endif
1780     OUTPUT:
1781         RETVAL
1782
1783 cc_t
1784 getcc(termios_ref, ccix)
1785         POSIX::Termios  termios_ref
1786         unsigned int    ccix
1787     CODE:
1788 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
1789         if (ccix >= NCCS)
1790             croak("Bad getcc subscript");
1791         RETVAL = termios_ref->c_cc[ccix];
1792 #else
1793      not_here("getcc");
1794      RETVAL = 0;
1795 #endif
1796     OUTPUT:
1797         RETVAL
1798
1799 SysRet
1800 setispeed(termios_ref, speed)
1801         POSIX::Termios  termios_ref
1802         speed_t         speed
1803     ALIAS:
1804         setospeed = 1
1805     CODE:
1806         RETVAL = ix
1807             ? cfsetospeed(termios_ref, speed) : cfsetispeed(termios_ref, speed);
1808     OUTPUT:
1809         RETVAL
1810
1811 void
1812 setiflag(termios_ref, flag)
1813         POSIX::Termios  termios_ref
1814         tcflag_t        flag
1815     ALIAS:
1816         setoflag = 1
1817         setcflag = 2
1818         setlflag = 3
1819     CODE:
1820 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
1821         switch(ix) {
1822         case 0:
1823             termios_ref->c_iflag = flag;
1824             break;
1825         case 1:
1826             termios_ref->c_oflag = flag;
1827             break;
1828         case 2:
1829             termios_ref->c_cflag = flag;
1830             break;
1831         case 3:
1832             termios_ref->c_lflag = flag;
1833             break;
1834         }
1835 #else
1836         not_here(GvNAME(CvGV(cv)));
1837 #endif
1838
1839 void
1840 setcc(termios_ref, ccix, cc)
1841         POSIX::Termios  termios_ref
1842         unsigned int    ccix
1843         cc_t            cc
1844     CODE:
1845 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
1846         if (ccix >= NCCS)
1847             croak("Bad setcc subscript");
1848         termios_ref->c_cc[ccix] = cc;
1849 #else
1850             not_here("setcc");
1851 #endif
1852
1853
1854 MODULE = POSIX          PACKAGE = POSIX
1855
1856 INCLUDE: const-xs.inc
1857
1858 int
1859 WEXITSTATUS(status)
1860         int status
1861     ALIAS:
1862         POSIX::WIFEXITED = 1
1863         POSIX::WIFSIGNALED = 2
1864         POSIX::WIFSTOPPED = 3
1865         POSIX::WSTOPSIG = 4
1866         POSIX::WTERMSIG = 5
1867     CODE:
1868 #if !defined(WEXITSTATUS) || !defined(WIFEXITED) || !defined(WIFSIGNALED) \
1869       || !defined(WIFSTOPPED) || !defined(WSTOPSIG) || !defined(WTERMSIG)
1870         RETVAL = 0; /* Silence compilers that notice this, but don't realise
1871                        that not_here() can't return.  */
1872 #endif
1873         switch(ix) {
1874         case 0:
1875 #ifdef WEXITSTATUS
1876             RETVAL = WEXITSTATUS(WMUNGE(status));
1877 #else
1878             not_here("WEXITSTATUS");
1879 #endif
1880             break;
1881         case 1:
1882 #ifdef WIFEXITED
1883             RETVAL = WIFEXITED(WMUNGE(status));
1884 #else
1885             not_here("WIFEXITED");
1886 #endif
1887             break;
1888         case 2:
1889 #ifdef WIFSIGNALED
1890             RETVAL = WIFSIGNALED(WMUNGE(status));
1891 #else
1892             not_here("WIFSIGNALED");
1893 #endif
1894             break;
1895         case 3:
1896 #ifdef WIFSTOPPED
1897             RETVAL = WIFSTOPPED(WMUNGE(status));
1898 #else
1899             not_here("WIFSTOPPED");
1900 #endif
1901             break;
1902         case 4:
1903 #ifdef WSTOPSIG
1904             RETVAL = WSTOPSIG(WMUNGE(status));
1905 #else
1906             not_here("WSTOPSIG");
1907 #endif
1908             break;
1909         case 5:
1910 #ifdef WTERMSIG
1911             RETVAL = WTERMSIG(WMUNGE(status));
1912 #else
1913             not_here("WTERMSIG");
1914 #endif
1915             break;
1916         default:
1917             Perl_croak(aTHX_ "Illegal alias %d for POSIX::W*", (int)ix);
1918         }
1919     OUTPUT:
1920         RETVAL
1921
1922 SysRet
1923 open(filename, flags = O_RDONLY, mode = 0666)
1924         char *          filename
1925         int             flags
1926         Mode_t          mode
1927     CODE:
1928         if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL))
1929             TAINT_PROPER("open");
1930         RETVAL = open(filename, flags, mode);
1931     OUTPUT:
1932         RETVAL
1933
1934
1935 HV *
1936 localeconv()
1937     CODE:
1938 #ifndef HAS_LOCALECONV
1939         localeconv(); /* A stub to call not_here(). */
1940 #else
1941         struct lconv *lcbuf;
1942
1943         /* localeconv() deals with both LC_NUMERIC and LC_MONETARY, but
1944          * LC_MONETARY is already in the correct locale */
1945         STORE_NUMERIC_STANDARD_FORCE_LOCAL();
1946
1947         RETVAL = newHV();
1948         sv_2mortal((SV*)RETVAL);
1949         if ((lcbuf = localeconv())) {
1950             const struct lconv_offset *strings = lconv_strings;
1951             const struct lconv_offset *integers = lconv_integers;
1952             const char *ptr = (const char *) lcbuf;
1953
1954             do {
1955                 /* This string may be controlled by either LC_NUMERIC, or
1956                  * LC_MONETARY */
1957                 bool is_utf8_locale
1958 #if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY)
1959                  = _is_cur_LC_category_utf8((isLC_NUMERIC_STRING(strings->name))
1960                                              ? LC_NUMERIC
1961                                              : LC_MONETARY);
1962 #elif defined(USE_LOCALE_NUMERIC)
1963                  = _is_cur_LC_category_utf8(LC_NUMERIC);
1964 #elif defined(USE_LOCALE_MONETARY)
1965                  = _is_cur_LC_category_utf8(LC_MONETARY);
1966 #else
1967                  = FALSE;
1968 #endif
1969
1970                 const char *value = *((const char **)(ptr + strings->offset));
1971
1972                 if (value && *value) {
1973                     (void) hv_store(RETVAL,
1974                         strings->name,
1975                         strlen(strings->name),
1976                         newSVpvn_utf8(value,
1977                                       strlen(value),
1978
1979                                       /* We mark it as UTF-8 if a utf8 locale
1980                                        * and is valid and variant under UTF-8 */
1981                                       is_utf8_locale
1982                                         && ! is_invariant_string((U8 *) value, 0)
1983                                         && is_utf8_string((U8 *) value, 0)),
1984                         0);
1985                   }
1986             } while ((++strings)->name);
1987
1988             do {
1989                 const char value = *((const char *)(ptr + integers->offset));
1990
1991                 if (value != CHAR_MAX)
1992                     (void) hv_store(RETVAL, integers->name,
1993                                     strlen(integers->name), newSViv(value), 0);
1994             } while ((++integers)->name);
1995         }
1996         RESTORE_NUMERIC_STANDARD();
1997 #endif  /* HAS_LOCALECONV */
1998     OUTPUT:
1999         RETVAL
2000
2001 char *
2002 setlocale(category, locale = 0)
2003         int             category
2004         const char *    locale
2005     PREINIT:
2006         char *          retval;
2007     CODE:
2008 #ifdef USE_LOCALE_NUMERIC
2009         /* A 0 (or NULL) locale means only query what the current one is.  We
2010          * have the LC_NUMERIC name saved, because we are normally switched
2011          * into the C locale for it.  Switch back so an LC_ALL query will yield
2012          * the correct results; all other categories don't require special
2013          * handling */
2014         if (locale == 0) {
2015             if (category == LC_NUMERIC) {
2016                 XSRETURN_PV(PL_numeric_name);
2017             }
2018 #   ifdef LC_ALL
2019             else if (category == LC_ALL) {
2020                 SET_NUMERIC_LOCAL();
2021             }
2022 #   endif
2023         }
2024 #endif
2025 #ifdef WIN32    /* Use wrapper on Windows */
2026         retval = Perl_my_setlocale(aTHX_ category, locale);
2027 #else
2028         retval = setlocale(category, locale);
2029 #endif
2030         if (! retval) {
2031             /* Should never happen that a query would return an error, but be
2032              * sure and reset to C locale */
2033             if (locale == 0) {
2034                 SET_NUMERIC_STANDARD();
2035             }
2036             XSRETURN_UNDEF;
2037         }
2038
2039         /* Save retval since subsequent setlocale() calls may overwrite it. */
2040         retval = savepv(retval);
2041
2042         /* For locale == 0, we may have switched to NUMERIC_LOCAL.  Switch back
2043          * */
2044         if (locale == 0) {
2045             SET_NUMERIC_STANDARD();
2046             XSRETURN_PV(retval);
2047         }
2048         else {
2049             RETVAL = retval;
2050 #ifdef USE_LOCALE_CTYPE
2051             if (category == LC_CTYPE
2052 #ifdef LC_ALL
2053                 || category == LC_ALL
2054 #endif
2055                 )
2056             {
2057                 char *newctype;
2058 #ifdef LC_ALL
2059                 if (category == LC_ALL)
2060                     newctype = setlocale(LC_CTYPE, NULL);
2061                 else
2062 #endif
2063                     newctype = RETVAL;
2064                 new_ctype(newctype);
2065             }
2066 #endif /* USE_LOCALE_CTYPE */
2067 #ifdef USE_LOCALE_COLLATE
2068             if (category == LC_COLLATE
2069 #ifdef LC_ALL
2070                 || category == LC_ALL
2071 #endif
2072                 )
2073             {
2074                 char *newcoll;
2075 #ifdef LC_ALL
2076                 if (category == LC_ALL)
2077                     newcoll = setlocale(LC_COLLATE, NULL);
2078                 else
2079 #endif
2080                     newcoll = RETVAL;
2081                 new_collate(newcoll);
2082             }
2083 #endif /* USE_LOCALE_COLLATE */
2084 #ifdef USE_LOCALE_NUMERIC
2085             if (category == LC_NUMERIC
2086 #ifdef LC_ALL
2087                 || category == LC_ALL
2088 #endif
2089                 )
2090             {
2091                 char *newnum;
2092 #ifdef LC_ALL
2093                 if (category == LC_ALL)
2094                     newnum = setlocale(LC_NUMERIC, NULL);
2095                 else
2096 #endif
2097                     newnum = RETVAL;
2098                 new_numeric(newnum);
2099             }
2100 #endif /* USE_LOCALE_NUMERIC */
2101         }
2102     OUTPUT:
2103         RETVAL
2104     CLEANUP:
2105         Safefree(RETVAL);
2106
2107 NV
2108 acos(x)
2109         NV              x
2110     ALIAS:
2111         acosh = 1
2112         asin = 2
2113         asinh = 3
2114         atan = 4
2115         atanh = 5
2116         cbrt = 6
2117         ceil = 7
2118         cosh = 8
2119         erf = 9
2120         erfc = 10
2121         exp2 = 11
2122         expm1 = 12
2123         floor = 13
2124         j0 = 14
2125         j1 = 15
2126         lgamma = 16
2127         log10 = 17
2128         log1p = 18
2129         log2 = 19
2130         logb = 20
2131         nearbyint = 21
2132         rint = 22
2133         round = 23
2134         sinh = 24
2135         tan = 25
2136         tanh = 26
2137         tgamma = 27
2138         trunc = 28
2139         y0 = 29
2140         y1 = 30
2141     CODE:
2142         PERL_UNUSED_VAR(x);
2143         RETVAL = NV_NAN;
2144         switch (ix) {
2145         case 0:
2146             RETVAL = Perl_acos(x); /* C89 math */
2147             break;
2148         case 1:
2149 #ifdef c99_acosh
2150             RETVAL = c99_acosh(x);
2151 #else
2152             not_here("acosh");
2153 #endif
2154             break;
2155         case 2:
2156             RETVAL = Perl_asin(x); /* C89 math */
2157             break;
2158         case 3:
2159 #ifdef c99_asinh
2160             RETVAL = c99_asinh(x);
2161 #else
2162             not_here("asinh");
2163 #endif
2164             break;
2165         case 4:
2166             RETVAL = Perl_atan(x); /* C89 math */
2167             break;
2168         case 5:
2169 #ifdef c99_atanh
2170             RETVAL = c99_atanh(x);
2171 #else
2172             not_here("atanh");
2173 #endif
2174             break;
2175         case 6:
2176 #ifdef c99_cbrt
2177             RETVAL = c99_cbrt(x);
2178 #else
2179             not_here("cbrt");
2180 #endif
2181             break;
2182         case 7:
2183             RETVAL = Perl_ceil(x); /* C89 math */
2184             break;
2185         case 8:
2186             RETVAL = Perl_cosh(x); /* C89 math */
2187             break;
2188         case 9:
2189 #ifdef c99_erf
2190             RETVAL = c99_erf(x);
2191 #else
2192             not_here("erf");
2193 #endif
2194             break;
2195         case 10:
2196 #ifdef c99_erfc
2197             RETVAL = c99_erfc(x);
2198 #else
2199             not_here("erfc");
2200 #endif
2201             break;
2202         case 11:
2203 #ifdef c99_exp2
2204             RETVAL = c99_exp2(x);
2205 #else
2206             not_here("exp2");
2207 #endif
2208             break;
2209         case 12:
2210 #ifdef c99_expm1
2211             RETVAL = c99_expm1(x);
2212 #else
2213             not_here("expm1");
2214 #endif
2215             break;
2216         case 13:
2217             RETVAL = Perl_floor(x); /* C89 math */
2218             break;
2219         case 14:
2220 #ifdef bessel_j0
2221             RETVAL = bessel_j0(x);
2222 #else
2223             not_here("j0");
2224 #endif
2225             break;
2226         case 15:
2227 #ifdef bessel_j1
2228             RETVAL = bessel_j1(x);
2229 #else
2230             not_here("j1");
2231 #endif
2232             break;
2233         case 16:
2234         /* XXX Note: the lgamma modifies a global variable (signgam),
2235          * which is evil.  Some platforms have lgamma_r, which has
2236          * extra output parameter instead of the global variable. */
2237 #ifdef c99_lgamma
2238             RETVAL = c99_lgamma(x);
2239 #else
2240             not_here("lgamma");
2241 #endif
2242             break;
2243         case 17:
2244             RETVAL = log10(x); /* C89 math */
2245             break;
2246         case 18:
2247 #ifdef c99_log1p
2248             RETVAL = c99_log1p(x);
2249 #else
2250             not_here("log1p");
2251 #endif
2252             break;
2253         case 19:
2254 #ifdef c99_log2
2255             RETVAL = c99_log2(x);
2256 #else
2257             not_here("log2");
2258 #endif
2259             break;
2260         case 20:
2261 #ifdef c99_logb
2262             RETVAL = c99_logb(x);
2263 #else
2264             not_here("logb");
2265 #endif
2266             break;
2267         case 21:
2268 #ifdef c99_nearbyint
2269             RETVAL = c99_nearbyint(x);
2270 #else
2271             not_here("nearbyint");
2272 #endif
2273             break;
2274         case 22:
2275 #ifdef c99_rint
2276             RETVAL = c99_rint(x);
2277 #else
2278             not_here("rint");
2279 #endif
2280             break;
2281         case 23:
2282 #ifdef c99_round
2283             RETVAL = c99_round(x);
2284 #else
2285             not_here("round");
2286 #endif
2287             break;
2288         case 24:
2289             RETVAL = Perl_sinh(x); /* C89 math */
2290             break;
2291         case 25:
2292             RETVAL = Perl_tan(x); /* C89 math */
2293             break;
2294         case 26:
2295             RETVAL = Perl_tanh(x); /* C89 math */
2296             break;
2297         case 27:
2298 #ifdef c99_tgamma
2299             RETVAL = c99_tgamma(x);
2300 #else
2301             not_here("tgamma");
2302 #endif
2303             break;
2304         case 28:
2305 #ifdef c99_trunc
2306             RETVAL = c99_trunc(x);
2307 #else
2308             not_here("trunc");
2309 #endif
2310             break;
2311         case 29:
2312 #ifdef bessel_y0
2313             RETVAL = bessel_y0(x);
2314 #else
2315             not_here("y0");
2316 #endif
2317             break;
2318         case 30:
2319         default:
2320 #ifdef bessel_y1
2321             RETVAL = bessel_y1(x);
2322 #else
2323             not_here("y1");
2324 #endif
2325         }
2326     OUTPUT:
2327         RETVAL
2328
2329 IV
2330 fegetround()
2331     CODE:
2332 #ifdef HAS_FEGETROUND
2333         RETVAL = my_fegetround();
2334 #else
2335         RETVAL = -1;
2336         not_here("fegetround");
2337 #endif
2338     OUTPUT:
2339         RETVAL
2340
2341 IV
2342 fesetround(x)
2343         IV      x
2344     CODE:
2345 #ifdef HAS_FEGETROUND /* canary for fesetround */
2346         RETVAL = fesetround(x);
2347 #elif defined(HAS_FPGETROUND) /* canary for fpsetround */
2348         switch (x) {
2349         case FE_TONEAREST:  RETVAL = fpsetround(FP_RN); break;
2350         case FE_TOWARDZERO: RETVAL = fpsetround(FP_RZ); break;
2351         case FE_DOWNWARD:   RETVAL = fpsetround(FP_RM); break;
2352         case FE_UPWARD:     RETVAL = fpsetround(FP_RP); break;
2353         default: RETVAL = -1; break;
2354         }
2355 #elif defined(__osf__) /* Tru64 */
2356         switch (x) {
2357         case FE_TONEAREST:  RETVAL = write_rnd(FP_RND_RN); break;
2358         case FE_TOWARDZERO: RETVAL = write_rnd(FP_RND_RZ); break;
2359         case FE_DOWNWARD:   RETVAL = write_rnd(FP_RND_RM); break;
2360         case FE_UPWARD:     RETVAL = write_rnd(FP_RND_RP); break;
2361         default: RETVAL = -1; break;
2362         }
2363 #else
2364         PERL_UNUSED_VAR(x);
2365         RETVAL = -1;
2366         not_here("fesetround");
2367 #endif
2368     OUTPUT:
2369         RETVAL
2370
2371 IV
2372 fpclassify(x)
2373         NV              x
2374     ALIAS:
2375         ilogb = 1
2376         isfinite = 2
2377         isinf = 3
2378         isnan = 4
2379         isnormal = 5
2380         lrint = 6
2381         lround = 7
2382         signbit = 8
2383     CODE:
2384         PERL_UNUSED_VAR(x);
2385         RETVAL = -1;
2386         switch (ix) {
2387         case 0:
2388 #ifdef c99_fpclassify
2389             RETVAL = c99_fpclassify(x);
2390 #else
2391             not_here("fpclassify");
2392 #endif
2393             break;
2394         case 1:
2395 #ifdef c99_ilogb
2396             RETVAL = c99_ilogb(x);
2397 #else
2398             not_here("ilogb");
2399 #endif
2400             break;
2401         case 2:
2402             RETVAL = Perl_isfinite(x);
2403             break;
2404         case 3:
2405             RETVAL = Perl_isinf(x);
2406             break;
2407         case 4:
2408             RETVAL = Perl_isnan(x);
2409             break;
2410         case 5:
2411 #ifdef c99_isnormal
2412             RETVAL = c99_isnormal(x);
2413 #else
2414             not_here("isnormal");
2415 #endif
2416             break;
2417         case 6:
2418 #ifdef c99_lrint
2419             RETVAL = c99_lrint(x);
2420 #else
2421             not_here("lrint");
2422 #endif
2423             break;
2424         case 7:
2425 #ifdef c99_lround
2426             RETVAL = c99_lround(x);
2427 #else
2428             not_here("lround");
2429 #endif
2430             break;
2431         case 8:
2432         default:
2433 #ifdef Perl_signbit
2434             RETVAL = Perl_signbit(x);
2435 #else
2436             RETVAL = (x < 0) || (x == -0.0);
2437 #endif
2438             break;
2439         }
2440     OUTPUT:
2441         RETVAL
2442
2443 NV
2444 copysign(x,y)
2445         NV              x
2446         NV              y
2447     ALIAS:
2448         fdim = 1
2449         fmax = 2
2450         fmin = 3
2451         fmod = 4
2452         hypot = 5
2453         isgreater = 6
2454         isgreaterequal = 7
2455         isless = 8
2456         islessequal = 9
2457         islessgreater = 10
2458         isunordered = 11
2459         nextafter = 12
2460         nexttoward = 13
2461         remainder = 14
2462     CODE:
2463         PERL_UNUSED_VAR(x);
2464         PERL_UNUSED_VAR(y);
2465         RETVAL = NV_NAN;
2466         switch (ix) {
2467         case 0:
2468 #ifdef c99_copysign
2469             RETVAL = c99_copysign(x, y);
2470 #else
2471             not_here("copysign");
2472 #endif
2473             break;
2474         case 1:
2475 #ifdef c99_fdim
2476             RETVAL = c99_fdim(x, y);
2477 #else
2478             not_here("fdim");
2479 #endif
2480             break;
2481         case 2:
2482 #ifdef c99_fmax
2483             RETVAL = c99_fmax(x, y);
2484 #else
2485             not_here("fmax");
2486 #endif
2487             break;
2488         case 3:
2489 #ifdef c99_fmin
2490             RETVAL = c99_fmin(x, y);
2491 #else
2492             not_here("fmin");
2493 #endif
2494             break;
2495         case 4:
2496             RETVAL = Perl_fmod(x, y); /* C89 math */
2497             break;
2498         case 5:
2499 #ifdef c99_hypot
2500             RETVAL = c99_hypot(x, y);
2501 #else
2502             not_here("hypot");
2503 #endif
2504             break;
2505         case 6:
2506 #ifdef c99_isgreater
2507             RETVAL = c99_isgreater(x, y);
2508 #else
2509             not_here("isgreater");
2510 #endif
2511             break;
2512         case 7:
2513 #ifdef c99_isgreaterequal
2514             RETVAL = c99_isgreaterequal(x, y);
2515 #else
2516             not_here("isgreaterequal");
2517 #endif
2518             break;
2519         case 8:
2520 #ifdef c99_isless
2521             RETVAL = c99_isless(x, y);
2522 #else
2523             not_here("isless");
2524 #endif
2525             break;
2526         case 9:
2527 #ifdef c99_islessequal
2528             RETVAL = c99_islessequal(x, y);
2529 #else
2530             not_here("islessequal");
2531 #endif
2532             break;
2533         case 10:
2534 #ifdef c99_islessgreater
2535             RETVAL = c99_islessgreater(x, y);
2536 #else
2537             not_here("islessgreater");
2538 #endif
2539             break;
2540         case 11:
2541 #ifdef c99_isunordered
2542             RETVAL = c99_isunordered(x, y);
2543 #else
2544             not_here("isunordered");
2545 #endif
2546             break;
2547         case 12:
2548 #ifdef c99_nextafter
2549             RETVAL = c99_nextafter(x, y);
2550 #else
2551             not_here("nextafter");
2552 #endif
2553             break;
2554         case 13:
2555 #ifdef c99_nexttoward
2556             RETVAL = c99_nexttoward(x, y);
2557 #else
2558             not_here("nexttoward");
2559 #endif
2560             break;
2561         case 14:
2562         default:
2563 #ifdef c99_remainder
2564           RETVAL = c99_remainder(x, y);
2565 #else
2566           not_here("remainder");
2567 #endif
2568             break;
2569         }
2570         OUTPUT:
2571             RETVAL
2572
2573 void
2574 frexp(x)
2575         NV              x
2576     PPCODE:
2577         int expvar;
2578         /* (We already know stack is long enough.) */
2579         PUSHs(sv_2mortal(newSVnv(Perl_frexp(x,&expvar)))); /* C89 math */
2580         PUSHs(sv_2mortal(newSViv(expvar)));
2581
2582 NV
2583 ldexp(x,exp)
2584         NV              x
2585         int             exp
2586
2587 void
2588 modf(x)
2589         NV              x
2590     PPCODE:
2591         NV intvar;
2592         /* (We already know stack is long enough.) */
2593         PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); /* C89 math */
2594         PUSHs(sv_2mortal(newSVnv(intvar)));
2595
2596 void
2597 remquo(x,y)
2598         NV              x
2599         NV              y
2600     PPCODE:
2601 #ifdef c99_remquo
2602         int intvar;
2603         PUSHs(sv_2mortal(newSVnv(c99_remquo(x,y,&intvar))));
2604         PUSHs(sv_2mortal(newSVnv(intvar)));
2605 #else
2606         PERL_UNUSED_VAR(x);
2607         PERL_UNUSED_VAR(y);
2608         not_here("remquo");
2609 #endif
2610
2611 NV
2612 scalbn(x,y)
2613         NV              x
2614         IV              y
2615     CODE:
2616 #ifdef c99_scalbn
2617         RETVAL = c99_scalbn(x, y);
2618 #else
2619         PERL_UNUSED_VAR(x);
2620         PERL_UNUSED_VAR(y);
2621         RETVAL = NV_NAN;
2622         not_here("scalbn");
2623 #endif
2624     OUTPUT:
2625         RETVAL
2626
2627 NV
2628 fma(x,y,z)
2629         NV              x
2630         NV              y
2631         NV              z
2632     CODE:
2633 #ifdef c99_fma
2634         PERL_UNUSED_VAR(x);
2635         PERL_UNUSED_VAR(y);
2636         PERL_UNUSED_VAR(z);
2637         RETVAL = c99_fma(x, y, z);
2638 #endif
2639     OUTPUT:
2640         RETVAL
2641
2642 NV
2643 nan(s = 0)
2644         char*   s;
2645     CODE:
2646         PERL_UNUSED_VAR(s);
2647 #ifdef c99_nan
2648         RETVAL = c99_nan(s ? s : "");
2649 #elif defined(NV_NAN)
2650         /* XXX if s != NULL, warn about unused argument,
2651          * or implement the nan payload setting. */
2652         /* NVSIZE == 8: the NaN "header" (the exponent) is 0x7FF (the 0x800
2653          * is the sign bit, which should be irrelevant for NaN, so really
2654          * also 0xFFF), leaving 64 - 12 = 52 bits for the NaN payload
2655          * (6.5 bytes, note about infinities below).
2656          *
2657          * (USE_LONG_DOUBLE and)
2658          * LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN:
2659          * the NaN "header" is still 0x7FF, leaving 80 - 12 = 68 bits
2660          * for the payload (8.5 bytes, note about infinities below).
2661          *
2662          * doubledouble? aargh. Maybe like doubles, 52 + 52 = 104 bits?
2663          *
2664          * NVSIZE == 16:
2665          * the NaN "header" is still 0x7FF, leaving 128 - 12 = 116 bits
2666          * for the payload (14.5 bytes, note about infinities below)
2667          *
2668          * Which ones of the NaNs are 'signaling' and which are 'quiet',
2669          * depends.  In the IEEE-754 1985, nothing was specified.  But the
2670          * majority of companies decided that the MSB of the mantissa was
2671          * the bit for 'quiet'.  (Only PA-RISC and MIPS were different,
2672          * using the MSB as 'signaling'.)  The IEEE-754 2008 *recommended*
2673          * (but did not dictate) the MSB as the 'quiet' bit.
2674          *
2675          * In other words, on most platforms, and for 64-bit doubles:
2676          * [7FF8000000000000, 7FFFFFFFFFFFFFFF] quiet
2677          * [FFF8000000000000, FFFFFFFFFFFFFFFF] quiet
2678          * [7FF0000000000001, 7FF7FFFFFFFFFFFF] signaling
2679          * [FFF0000000000001, FFF7FFFFFFFFFFFF] signaling
2680          *
2681          * The C99 nan() is supposed to generate *quiet* NaNs.
2682          *
2683          * Note the asymmetry:
2684          * The 7FF0000000000000 is positive infinity,
2685          * the FFF0000000000000 is negative infinity.
2686          */
2687         RETVAL = NV_NAN;
2688 #else
2689         not_here("nan");
2690 #endif
2691     OUTPUT:
2692         RETVAL
2693
2694 NV
2695 jn(x,y)
2696         IV              x
2697         NV              y
2698     ALIAS:
2699         yn = 1
2700     CODE:
2701         PERL_UNUSED_VAR(x);
2702         PERL_UNUSED_VAR(y);
2703         RETVAL = NV_NAN;
2704         switch (ix) {
2705         case 0:
2706 #ifdef bessel_jn
2707           RETVAL = bessel_jn(x, y);
2708 #else
2709           not_here("jn");
2710 #endif
2711             break;
2712         case 1:
2713         default:
2714 #ifdef bessel_yn
2715           RETVAL = bessel_yn(x, y);
2716 #else
2717           not_here("yn");
2718 #endif
2719             break;
2720         }
2721     OUTPUT:
2722         RETVAL
2723
2724 SysRet
2725 sigaction(sig, optaction, oldaction = 0)
2726         int                     sig
2727         SV *                    optaction
2728         POSIX::SigAction        oldaction
2729     CODE:
2730 #if defined(WIN32) || defined(NETWARE)
2731         RETVAL = not_here("sigaction");
2732 #else
2733 # This code is really grody because we're trying to make the signal
2734 # interface look beautiful, which is hard.
2735
2736         {
2737             dVAR;
2738             POSIX__SigAction action;
2739             GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV);
2740             struct sigaction act;
2741             struct sigaction oact;
2742             sigset_t sset;
2743             SV *osset_sv;
2744             sigset_t osset;
2745             POSIX__SigSet sigset;
2746             SV** svp;
2747             SV** sigsvp;
2748
2749             if (sig < 0) {
2750                 croak("Negative signals are not allowed");
2751             }
2752
2753             if (sig == 0 && SvPOK(ST(0))) {
2754                 const char *s = SvPVX_const(ST(0));
2755                 int i = whichsig(s);
2756
2757                 if (i < 0 && memEQ(s, "SIG", 3))
2758                     i = whichsig(s + 3);
2759                 if (i < 0) {
2760                     if (ckWARN(WARN_SIGNAL))
2761                         Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2762                                     "No such signal: SIG%s", s);
2763                     XSRETURN_UNDEF;
2764                 }
2765                 else
2766                     sig = i;
2767             }
2768 #ifdef NSIG
2769             if (sig > NSIG) { /* NSIG - 1 is still okay. */
2770                 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
2771                             "No such signal: %d", sig);
2772                 XSRETURN_UNDEF;
2773             }
2774 #endif
2775             sigsvp = hv_fetch(GvHVn(siggv),
2776                               PL_sig_name[sig],
2777                               strlen(PL_sig_name[sig]),
2778                               TRUE);
2779
2780             /* Check optaction and set action */
2781             if(SvTRUE(optaction)) {
2782                 if(sv_isa(optaction, "POSIX::SigAction"))
2783                         action = (HV*)SvRV(optaction);
2784                 else
2785                         croak("action is not of type POSIX::SigAction");
2786             }
2787             else {
2788                 action=0;
2789             }
2790
2791             /* sigaction() is supposed to look atomic. In particular, any
2792              * signal handler invoked during a sigaction() call should
2793              * see either the old or the new disposition, and not something
2794              * in between. We use sigprocmask() to make it so.
2795              */
2796             sigfillset(&sset);
2797             RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
2798             if(RETVAL == -1)
2799                XSRETURN_UNDEF;
2800             ENTER;
2801             /* Restore signal mask no matter how we exit this block. */
2802             osset_sv = newSVpvn((char *)(&osset), sizeof(sigset_t));
2803             SAVEFREESV( osset_sv );
2804             SAVEDESTRUCTOR_X(restore_sigmask, osset_sv);
2805
2806             RETVAL=-1; /* In case both oldaction and action are 0. */
2807
2808             /* Remember old disposition if desired. */
2809             if (oldaction) {
2810                 svp = hv_fetchs(oldaction, "HANDLER", TRUE);
2811                 if(!svp)
2812                     croak("Can't supply an oldaction without a HANDLER");
2813                 if(SvTRUE(*sigsvp)) { /* TBD: what if "0"? */
2814                         sv_setsv(*svp, *sigsvp);
2815                 }
2816                 else {
2817                         sv_setpvs(*svp, "DEFAULT");
2818                 }
2819                 RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
2820                 if(RETVAL == -1) {
2821                    LEAVE;
2822                    XSRETURN_UNDEF;
2823                 }
2824                 /* Get back the mask. */
2825                 svp = hv_fetchs(oldaction, "MASK", TRUE);
2826                 if (sv_isa(*svp, "POSIX::SigSet")) {
2827                     sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
2828                 }
2829                 else {
2830                     sigset = (sigset_t *) allocate_struct(aTHX_ *svp,
2831                                                           sizeof(sigset_t),
2832                                                           "POSIX::SigSet");
2833                 }
2834                 *sigset = oact.sa_mask;
2835
2836                 /* Get back the flags. */
2837                 svp = hv_fetchs(oldaction, "FLAGS", TRUE);
2838                 sv_setiv(*svp, oact.sa_flags);
2839
2840                 /* Get back whether the old handler used safe signals. */
2841                 svp = hv_fetchs(oldaction, "SAFE", TRUE);
2842                 sv_setiv(*svp,
2843                 /* compare incompatible pointers by casting to integer */
2844                     PTR2nat(oact.sa_handler) == PTR2nat(PL_csighandlerp));
2845             }
2846
2847             if (action) {
2848                 /* Safe signals use "csighandler", which vectors through the
2849                    PL_sighandlerp pointer when it's safe to do so.
2850                    (BTW, "csighandler" is very different from "sighandler".) */
2851                 svp = hv_fetchs(action, "SAFE", FALSE);
2852                 act.sa_handler =
2853                         DPTR2FPTR(
2854                             void (*)(int),
2855                             (*svp && SvTRUE(*svp))
2856                                 ? PL_csighandlerp : PL_sighandlerp
2857                         );
2858
2859                 /* Vector new Perl handler through %SIG.
2860                    (The core signal handlers read %SIG to dispatch.) */
2861                 svp = hv_fetchs(action, "HANDLER", FALSE);
2862                 if (!svp)
2863                     croak("Can't supply an action without a HANDLER");
2864                 sv_setsv(*sigsvp, *svp);
2865
2866                 /* This call actually calls sigaction() with almost the
2867                    right settings, including appropriate interpretation
2868                    of DEFAULT and IGNORE.  However, why are we doing
2869                    this when we're about to do it again just below?  XXX */
2870                 SvSETMAGIC(*sigsvp);
2871
2872                 /* And here again we duplicate -- DEFAULT/IGNORE checking. */
2873                 if(SvPOK(*svp)) {
2874                         const char *s=SvPVX_const(*svp);
2875                         if(strEQ(s,"IGNORE")) {
2876                                 act.sa_handler = SIG_IGN;
2877                         }
2878                         else if(strEQ(s,"DEFAULT")) {
2879                                 act.sa_handler = SIG_DFL;
2880                         }
2881                 }
2882
2883                 /* Set up any desired mask. */
2884                 svp = hv_fetchs(action, "MASK", FALSE);
2885                 if (svp && sv_isa(*svp, "POSIX::SigSet")) {
2886                     sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
2887                     act.sa_mask = *sigset;
2888                 }
2889                 else
2890                     sigemptyset(& act.sa_mask);
2891
2892                 /* Set up any desired flags. */
2893                 svp = hv_fetchs(action, "FLAGS", FALSE);
2894                 act.sa_flags = svp ? SvIV(*svp) : 0;
2895
2896                 /* Don't worry about cleaning up *sigsvp if this fails,
2897                  * because that means we tried to disposition a
2898                  * nonblockable signal, in which case *sigsvp is
2899                  * essentially meaningless anyway.
2900                  */
2901                 RETVAL = sigaction(sig, & act, (struct sigaction *)0);
2902                 if(RETVAL == -1) {
2903                     LEAVE;
2904                     XSRETURN_UNDEF;
2905                 }
2906             }
2907
2908             LEAVE;
2909         }
2910 #endif
2911     OUTPUT:
2912         RETVAL
2913
2914 SysRet
2915 sigpending(sigset)
2916         POSIX::SigSet           sigset
2917     ALIAS:
2918         sigsuspend = 1
2919     CODE:
2920         RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
2921     OUTPUT:
2922         RETVAL
2923     CLEANUP:
2924     PERL_ASYNC_CHECK();
2925
2926 SysRet
2927 sigprocmask(how, sigset, oldsigset = 0)
2928         int                     how
2929         POSIX::SigSet           sigset = NO_INIT
2930         POSIX::SigSet           oldsigset = NO_INIT
2931 INIT:
2932         if (! SvOK(ST(1))) {
2933             sigset = NULL;
2934         } else if (sv_isa(ST(1), "POSIX::SigSet")) {
2935             sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1)));
2936         } else {
2937             croak("sigset is not of type POSIX::SigSet");
2938         }
2939
2940         if (items < 3 || ! SvOK(ST(2))) {
2941             oldsigset = NULL;
2942         } else if (sv_isa(ST(2), "POSIX::SigSet")) {
2943             oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2)));
2944         } else {
2945             croak("oldsigset is not of type POSIX::SigSet");
2946         }
2947
2948 void
2949 _exit(status)
2950         int             status
2951
2952 SysRet
2953 dup2(fd1, fd2)
2954         int             fd1
2955         int             fd2
2956     CODE:
2957 #ifdef WIN32
2958         /* RT #98912 - More Microsoft muppetry - failing to actually implemented
2959            the well known documented POSIX behaviour for a POSIX API.
2960            http://msdn.microsoft.com/en-us/library/8syseb29.aspx   */
2961         RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2;
2962 #else
2963         RETVAL = dup2(fd1, fd2);
2964 #endif
2965     OUTPUT:
2966         RETVAL
2967
2968 SV *
2969 lseek(fd, offset, whence)
2970         int             fd
2971         Off_t           offset
2972         int             whence
2973     CODE:
2974         Off_t pos = PerlLIO_lseek(fd, offset, whence);
2975         RETVAL = sizeof(Off_t) > sizeof(IV)
2976                  ? newSVnv((NV)pos) : newSViv((IV)pos);
2977     OUTPUT:
2978         RETVAL
2979
2980 void
2981 nice(incr)
2982         int             incr
2983     PPCODE:
2984         errno = 0;
2985         if ((incr = nice(incr)) != -1 || errno == 0) {
2986             if (incr == 0)
2987                 XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP));
2988             else
2989                 XPUSHs(sv_2mortal(newSViv(incr)));
2990         }
2991
2992 void
2993 pipe()
2994     PPCODE:
2995         int fds[2];
2996         if (pipe(fds) != -1) {
2997             EXTEND(SP,2);
2998             PUSHs(sv_2mortal(newSViv(fds[0])));
2999             PUSHs(sv_2mortal(newSViv(fds[1])));
3000         }
3001
3002 SysRet
3003 read(fd, buffer, nbytes)
3004     PREINIT:
3005         SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3006     INPUT:
3007         int             fd
3008         size_t          nbytes
3009         char *          buffer = sv_grow( sv_buffer, nbytes+1 );
3010     CLEANUP:
3011         if (RETVAL >= 0) {
3012             SvCUR_set(sv_buffer, RETVAL);
3013             SvPOK_only(sv_buffer);
3014             *SvEND(sv_buffer) = '\0';
3015             SvTAINTED_on(sv_buffer);
3016         }
3017
3018 SysRet
3019 setpgid(pid, pgid)
3020         pid_t           pid
3021         pid_t           pgid
3022
3023 pid_t
3024 setsid()
3025
3026 pid_t
3027 tcgetpgrp(fd)
3028         int             fd
3029
3030 SysRet
3031 tcsetpgrp(fd, pgrp_id)
3032         int             fd
3033         pid_t           pgrp_id
3034
3035 void
3036 uname()
3037     PPCODE:
3038 #ifdef HAS_UNAME
3039         struct utsname buf;
3040         if (uname(&buf) >= 0) {
3041             EXTEND(SP, 5);
3042             PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP));
3043             PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP));
3044             PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP));
3045             PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP));
3046             PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP));
3047         }
3048 #else
3049         uname((char *) 0); /* A stub to call not_here(). */
3050 #endif
3051
3052 SysRet
3053 write(fd, buffer, nbytes)
3054         int             fd
3055         char *          buffer
3056         size_t          nbytes
3057
3058 SV *
3059 tmpnam()
3060     PREINIT:
3061         STRLEN i;
3062         int len;
3063     CODE:
3064         RETVAL = newSVpvs("");
3065         SvGROW(RETVAL, L_tmpnam);
3066         /* Yes, we know tmpnam() is bad.  So bad that some compilers
3067          * and linkers warn against using it.  But it is here for
3068          * completeness.  POSIX.pod warns against using it.
3069          *
3070          * Then again, maybe this should be removed at some point.
3071          * No point in enabling dangerous interfaces. */
3072         if (ckWARN_d(WARN_DEPRECATED)) {
3073             HV *warned = get_hv("POSIX::_warned", GV_ADD | GV_ADDMULTI);
3074             if (! hv_exists(warned, (const char *)&PL_op, sizeof(PL_op))) {
3075                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Calling POSIX::tmpnam() is deprecated");
3076                 (void)hv_store(warned, (const char *)&PL_op, sizeof(PL_op), &PL_sv_yes, 0);
3077             }
3078         }
3079         len = strlen(tmpnam(SvPV(RETVAL, i)));
3080         SvCUR_set(RETVAL, len);
3081     OUTPUT:
3082         RETVAL
3083
3084 void
3085 abort()
3086
3087 int
3088 mblen(s, n)
3089         char *          s
3090         size_t          n
3091
3092 size_t
3093 mbstowcs(s, pwcs, n)
3094         wchar_t *       s
3095         char *          pwcs
3096         size_t          n
3097
3098 int
3099 mbtowc(pwc, s, n)
3100         wchar_t *       pwc
3101         char *          s
3102         size_t          n
3103
3104 int
3105 wcstombs(s, pwcs, n)
3106         char *          s
3107         wchar_t *       pwcs
3108         size_t          n
3109
3110 int
3111 wctomb(s, wchar)
3112         char *          s
3113         wchar_t         wchar
3114
3115 int
3116 strcoll(s1, s2)
3117         char *          s1
3118         char *          s2
3119
3120 void
3121 strtod(str)
3122         char *          str
3123     PREINIT:
3124         double num;
3125         char *unparsed;
3126     PPCODE:
3127         STORE_NUMERIC_STANDARD_FORCE_LOCAL();
3128         num = strtod(str, &unparsed);
3129         PUSHs(sv_2mortal(newSVnv(num)));
3130         if (GIMME_V == G_ARRAY) {
3131             EXTEND(SP, 1);
3132             if (unparsed)
3133                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3134             else
3135                 PUSHs(&PL_sv_undef);
3136         }
3137         RESTORE_NUMERIC_STANDARD();
3138
3139 #ifdef HAS_STRTOLD
3140
3141 void
3142 strtold(str)
3143         char *          str
3144     PREINIT:
3145         long double num;
3146         char *unparsed;
3147     PPCODE:
3148         STORE_NUMERIC_STANDARD_FORCE_LOCAL();
3149         num = strtold(str, &unparsed);
3150         PUSHs(sv_2mortal(newSVnv(num)));
3151         if (GIMME_V == G_ARRAY) {
3152             EXTEND(SP, 1);
3153             if (unparsed)
3154                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3155             else
3156                 PUSHs(&PL_sv_undef);
3157         }
3158         RESTORE_NUMERIC_STANDARD();
3159
3160 #endif
3161
3162 void
3163 strtol(str, base = 0)
3164         char *          str
3165         int             base
3166     PREINIT:
3167         long num;
3168         char *unparsed;
3169     PPCODE:
3170         num = strtol(str, &unparsed, base);
3171 #if IVSIZE <= LONGSIZE
3172         if (num < IV_MIN || num > IV_MAX)
3173             PUSHs(sv_2mortal(newSVnv((double)num)));
3174         else
3175 #endif
3176             PUSHs(sv_2mortal(newSViv((IV)num)));
3177         if (GIMME_V == G_ARRAY) {
3178             EXTEND(SP, 1);
3179             if (unparsed)
3180                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3181             else
3182                 PUSHs(&PL_sv_undef);
3183         }
3184
3185 void
3186 strtoul(str, base = 0)
3187         const char *    str
3188         int             base
3189     PREINIT:
3190         unsigned long num;
3191         char *unparsed;
3192     PPCODE:
3193         PERL_UNUSED_VAR(str);
3194         PERL_UNUSED_VAR(base);
3195         num = strtoul(str, &unparsed, base);
3196 #if IVSIZE <= LONGSIZE
3197         if (num > IV_MAX)
3198             PUSHs(sv_2mortal(newSVnv((double)num)));
3199         else
3200 #endif
3201             PUSHs(sv_2mortal(newSViv((IV)num)));
3202         if (GIMME_V == G_ARRAY) {
3203             EXTEND(SP, 1);
3204             if (unparsed)
3205                 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3206             else
3207                 PUSHs(&PL_sv_undef);
3208         }
3209
3210 void
3211 strxfrm(src)
3212         SV *            src
3213     CODE:
3214         {
3215           STRLEN srclen;
3216           STRLEN dstlen;
3217           STRLEN buflen;
3218           char *p = SvPV(src,srclen);
3219           srclen++;
3220           buflen = srclen * 4 + 1;
3221           ST(0) = sv_2mortal(newSV(buflen));
3222           dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)buflen);
3223           if (dstlen >= buflen) {
3224               dstlen++;
3225               SvGROW(ST(0), dstlen);
3226               strxfrm(SvPVX(ST(0)), p, (size_t)dstlen);
3227               dstlen--;
3228           }
3229           SvCUR_set(ST(0), dstlen);
3230             SvPOK_only(ST(0));
3231         }
3232
3233 SysRet
3234 mkfifo(filename, mode)
3235         char *          filename
3236         Mode_t          mode
3237     ALIAS:
3238         access = 1
3239     CODE:
3240         if(ix) {
3241             RETVAL = access(filename, mode);
3242         } else {
3243             TAINT_PROPER("mkfifo");
3244             RETVAL = mkfifo(filename, mode);
3245         }
3246     OUTPUT:
3247         RETVAL
3248
3249 SysRet
3250 tcdrain(fd)
3251         int             fd
3252     ALIAS:
3253         close = 1
3254         dup = 2
3255     CODE:
3256         RETVAL = ix == 1 ? close(fd)
3257             : (ix < 1 ? tcdrain(fd) : dup(fd));
3258     OUTPUT:
3259         RETVAL
3260
3261
3262 SysRet
3263 tcflow(fd, action)
3264         int             fd
3265         int             action
3266     ALIAS:
3267         tcflush = 1
3268         tcsendbreak = 2
3269     CODE:
3270         RETVAL = ix == 1 ? tcflush(fd, action)
3271             : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action));
3272     OUTPUT:
3273         RETVAL
3274
3275 void
3276 asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
3277         int             sec
3278         int             min
3279         int             hour
3280         int             mday
3281         int             mon
3282         int             year
3283         int             wday
3284         int             yday
3285         int             isdst
3286     ALIAS:
3287         mktime = 1
3288     PPCODE:
3289         {
3290             dXSTARG;
3291             struct tm mytm;
3292             init_tm(&mytm);     /* XXX workaround - see init_tm() in core util.c */
3293             mytm.tm_sec = sec;
3294             mytm.tm_min = min;
3295             mytm.tm_hour = hour;
3296             mytm.tm_mday = mday;
3297             mytm.tm_mon = mon;
3298             mytm.tm_year = year;
3299             mytm.tm_wday = wday;
3300             mytm.tm_yday = yday;
3301             mytm.tm_isdst = isdst;
3302             if (ix) {
3303                 const time_t result = mktime(&mytm);
3304                 if (result == (time_t)-1)
3305                     SvOK_off(TARG);
3306                 else if (result == 0)
3307                     sv_setpvn(TARG, "0 but true", 10);
3308                 else
3309                     sv_setiv(TARG, (IV)result);
3310             } else {
3311                 sv_setpv(TARG, asctime(&mytm));
3312             }
3313             ST(0) = TARG;
3314             XSRETURN(1);
3315         }
3316
3317 long
3318 clock()
3319
3320 char *
3321 ctime(time)
3322         Time_t          &time
3323
3324 void
3325 times()
3326         PPCODE:
3327         struct tms tms;
3328         clock_t realtime;
3329         realtime = times( &tms );
3330         EXTEND(SP,5);
3331         PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) );
3332         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) );
3333         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) );
3334         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) );
3335         PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) );
3336
3337 double
3338 difftime(time1, time2)
3339         Time_t          time1
3340         Time_t          time2
3341
3342 #XXX: if $xsubpp::WantOptimize is always the default
3343 #     sv_setpv(TARG, ...) could be used rather than
3344 #     ST(0) = sv_2mortal(newSVpv(...))
3345 void
3346 strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
3347         SV *            fmt
3348         int             sec
3349         int             min
3350         int             hour
3351         int             mday
3352         int             mon
3353         int             year
3354         int             wday
3355         int             yday
3356         int             isdst
3357     CODE:
3358         {
3359             char *buf;
3360             SV *sv;
3361
3362             /* allowing user-supplied (rather than literal) formats
3363              * is normally frowned upon as a potential security risk;
3364              * but this is part of the API so we have to allow it */
3365             GCC_DIAG_IGNORE(-Wformat-nonliteral);
3366             buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst);
3367             GCC_DIAG_RESTORE;
3368             sv = sv_newmortal();
3369             if (buf) {
3370                 STRLEN len = strlen(buf);
3371                 sv_usepvn_flags(sv, buf, len, SV_HAS_TRAILING_NUL);
3372                 if (SvUTF8(fmt)
3373                     || (! is_invariant_string((U8*) buf, len)
3374                         && is_utf8_string((U8*) buf, len)
3375 #ifdef USE_LOCALE_TIME
3376                         && _is_cur_LC_category_utf8(LC_TIME)
3377 #endif
3378                 )) {
3379                     SvUTF8_on(sv);
3380                 }
3381             }
3382             else {  /* We can't distinguish between errors and just an empty
3383                      * return; in all cases just return an empty string */
3384                 SvUPGRADE(sv, SVt_PV);
3385                 SvPV_set(sv, (char *) "");
3386                 SvPOK_on(sv);
3387                 SvCUR_set(sv, 0);
3388                 SvLEN_set(sv, 0);   /* Won't attempt to free the string when sv
3389                                        gets destroyed */
3390             }
3391             ST(0) = sv;
3392         }
3393
3394 void
3395 tzset()
3396   PPCODE:
3397     my_tzset(aTHX);
3398
3399 void
3400 tzname()
3401     PPCODE:
3402         EXTEND(SP,2);
3403         PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP));
3404         PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP));
3405
3406 char *
3407 ctermid(s = 0)
3408         char *          s = 0;
3409     CODE:
3410 #ifdef HAS_CTERMID_R
3411         s = (char *) safemalloc((size_t) L_ctermid);
3412 #endif
3413         RETVAL = ctermid(s);
3414     OUTPUT:
3415         RETVAL
3416     CLEANUP:
3417 #ifdef HAS_CTERMID_R
3418         Safefree(s);
3419 #endif
3420
3421 char *
3422 cuserid(s = 0)
3423         char *          s = 0;
3424     CODE:
3425 #ifdef HAS_CUSERID
3426   RETVAL = cuserid(s);
3427 #else
3428   PERL_UNUSED_VAR(s);
3429   RETVAL = 0;
3430   not_here("cuserid");
3431 #endif
3432     OUTPUT:
3433   RETVAL
3434
3435 SysRetLong
3436 fpathconf(fd, name)
3437         int             fd
3438         int             name
3439
3440 SysRetLong
3441 pathconf(filename, name)
3442         char *          filename
3443         int             name
3444
3445 SysRet
3446 pause()
3447     CLEANUP:
3448     PERL_ASYNC_CHECK();
3449
3450 unsigned int
3451 sleep(seconds)
3452         unsigned int    seconds
3453     CODE:
3454         RETVAL = PerlProc_sleep(seconds);
3455     OUTPUT:
3456         RETVAL
3457
3458 SysRet
3459 setgid(gid)
3460         Gid_t           gid
3461
3462 SysRet
3463 setuid(uid)
3464         Uid_t           uid
3465
3466 SysRetLong
3467 sysconf(name)
3468         int             name
3469
3470 char *
3471 ttyname(fd)
3472         int             fd
3473
3474 void
3475 getcwd()
3476     PPCODE:
3477       {
3478         dXSTARG;
3479         getcwd_sv(TARG);
3480         XSprePUSH; PUSHTARG;
3481       }
3482
3483 SysRet
3484 lchown(uid, gid, path)
3485        Uid_t           uid
3486        Gid_t           gid
3487        char *          path
3488     CODE:
3489 #ifdef HAS_LCHOWN
3490        /* yes, the order of arguments is different,
3491         * but consistent with CORE::chown() */
3492        RETVAL = lchown(path, uid, gid);
3493 #else
3494        PERL_UNUSED_VAR(uid);
3495        PERL_UNUSED_VAR(gid);
3496        PERL_UNUSED_VAR(path);
3497        RETVAL = not_here("lchown");
3498 #endif
3499     OUTPUT:
3500        RETVAL