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