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