6 * Ideally this should be somewhere down in the includes
7 * but putting it in other places is giving compiler errors.
8 * Also here I am unable to check for HAS_UNAME since it wouldn't have
9 * yet come into the file at this stage - sgp 18th Oct 2000
11 #include <sys/utsname.h>
14 #define PERL_NO_GET_CONTEXT
17 #define PERLIO_NOT_STDIO 1
21 static int not_here(const char *s);
23 #if defined(PERL_IMPLICIT_SYS)
27 # define open PerlLIO_open3
30 #ifdef I_DIRENT /* XXX maybe better to just rely on perl.h? */
35 #include <sys/errno2.h>
41 #if !(defined(__vax__) && defined(__NetBSD__))
65 #if defined(USE_QUADMATH) && defined(I_QUADMATH)
82 # define M_LOG2E M_LOG2Eq
83 # define M_LOG10E M_LOG10Eq
85 # define M_LN10 M_LN10q
87 # define M_PI_2 M_PI_2q
88 # define M_PI_4 M_PI_4q
89 # define M_1_PI M_1_PIq
90 # define M_2_PI M_2_PIq
91 # define M_2_SQRTPI M_2_SQRTPIq
92 # define M_SQRT2 M_SQRT2q
93 # define M_SQRT1_2 M_SQRT1_2q
97 # ifdef USE_LONG_DOUBLE
111 # define FLOAT_C(c) CAT2(c,L)
113 # define FLOAT_C(c) (c)
117 # define M_E FLOAT_C(2.71828182845904523536028747135266250)
120 # define M_LOG2E FLOAT_C(1.44269504088896340735992468100189214)
123 # define M_LOG10E FLOAT_C(0.434294481903251827651128918916605082)
126 # define M_LN2 FLOAT_C(0.693147180559945309417232121458176568)
129 # define M_LN10 FLOAT_C(2.30258509299404568401799145468436421)
132 # define M_PI FLOAT_C(3.14159265358979323846264338327950288)
135 # define M_PI_2 FLOAT_C(1.57079632679489661923132169163975144)
138 # define M_PI_4 FLOAT_C(0.785398163397448309615660845819875721)
141 # define M_1_PI FLOAT_C(0.318309886183790671537767526745028724)
144 # define M_2_PI FLOAT_C(0.636619772367581343075535053490057448)
147 # define M_2_SQRTPI FLOAT_C(1.12837916709551257389615890312154517)
150 # define M_SQRT2 FLOAT_C(1.41421356237309504880168872420969808)
153 # define M_SQRT1_2 FLOAT_C(0.707106781186547524400844362104849039)
158 #if !defined(INFINITY) && defined(NV_INF)
159 # define INFINITY NV_INF
162 #if !defined(NAN) && defined(NV_NAN)
166 #if !defined(Inf) && defined(NV_INF)
170 #if !defined(NaN) && defined(NV_NAN)
174 /* We will have an emulation. */
176 # define FP_INFINITE 0
179 # define FP_SUBNORMAL 3
183 /* We will have an emulation. */
185 # define FE_TOWARDZERO 0
186 # define FE_TONEAREST 1
188 # define FE_DOWNWARD 3
193 acos asin atan atan2 ceil cos cosh exp fabs floor fmod frexp ldexp
194 log log10 modf pow sin sinh sqrt tan tanh
196 * Implemented in core:
198 atan2 cos exp log pow sin sqrt
202 acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma fmax
203 fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal isinf
204 isless islessequal islessgreater isnan isnormal isunordered lgamma
205 log1p log2 logb lrint lround nan nearbyint nextafter nexttoward remainder
206 remquo rint round scalbn signbit tgamma trunc
209 http://pubs.opengroup.org/onlinepubs/009695399/basedefs/math.h.html
211 * Berkeley/SVID extensions:
215 * Configure already (5.21.5) scans for:
217 copysign*l* fpclassify isfinite isinf isnan isnan*l* ilogb*l* signbit scalbn*l*
219 * For floating-point round mode (which matters for e.g. lrint and rint)
221 fegetround fesetround
225 /* XXX Constant FP_FAST_FMA (if true, FMA is faster) */
227 /* XXX Add ldiv(), lldiv()? It's C99, but from stdlib.h, not math.h */
229 /* XXX Beware old gamma() -- one cannot know whether that is the
230 * gamma or the log of gamma, that's why the new tgamma and lgamma.
231 * Though also remember lgamma_r. */
233 /* Certain AIX releases have the C99 math, but not in long double.
234 * The <math.h> has them, e.g. __expl128, but no library has them!
236 * Also see the comments in hints/aix.sh about long doubles. */
238 #if defined(USE_QUADMATH) && defined(I_QUADMATH)
239 # define c99_acosh acoshq
240 # define c99_asinh asinhq
241 # define c99_atanh atanhq
242 # define c99_cbrt cbrtq
243 # define c99_copysign copysignq
244 # define c99_erf erfq
245 # define c99_erfc erfcq
247 # define c99_expm1 expm1q
248 # define c99_fdim fdimq
249 # define c99_fma fmaq
250 # define c99_fmax fmaxq
251 # define c99_fmin fminq
252 # define c99_hypot hypotq
253 # define c99_ilogb ilogbq
254 # define c99_lgamma lgammaq
255 # define c99_log1p log1pq
256 # define c99_log2 log2q
258 # if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG
259 # define c99_lrint llrintq
260 # define c99_lround llroundq
262 # define c99_lrint lrintq
263 # define c99_lround lroundq
265 # define c99_nan nanq
266 # define c99_nearbyint nearbyintq
267 # define c99_nextafter nextafterq
269 # define c99_remainder remainderq
270 # define c99_remquo remquoq
271 # define c99_rint rintq
272 # define c99_round roundq
273 # define c99_scalbn scalbnq
274 # define c99_signbit signbitq
275 # define c99_tgamma tgammaq
276 # define c99_trunc truncq
277 # define bessel_j0 j0q
278 # define bessel_j1 j1q
279 # define bessel_jn jnq
280 # define bessel_y0 y0q
281 # define bessel_y1 y1q
282 # define bessel_yn ynq
283 #elif defined(USE_LONG_DOUBLE) && \
284 (defined(HAS_FREXPL) || defined(HAS_ILOGBL)) && defined(HAS_SQRTL)
285 /* Use some of the Configure scans for long double math functions
286 * as the canary for all the C99 *l variants being defined. */
287 # define c99_acosh acoshl
288 # define c99_asinh asinhl
289 # define c99_atanh atanhl
290 # define c99_cbrt cbrtl
291 # define c99_copysign copysignl
292 # define c99_erf erfl
293 # define c99_erfc erfcl
294 # define c99_exp2 exp2l
295 # define c99_expm1 expm1l
296 # define c99_fdim fdiml
297 # define c99_fma fmal
298 # define c99_fmax fmaxl
299 # define c99_fmin fminl
300 # define c99_hypot hypotl
301 # define c99_ilogb ilogbl
302 # define c99_lgamma lgammal
303 # define c99_log1p log1pl
304 # define c99_log2 log2l
305 # define c99_logb logbl
306 # if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLRINTL)
307 # define c99_lrint llrintl
308 # elif defined(HAS_LRINTL)
309 # define c99_lrint lrintl
311 # if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLROUNDL)
312 # define c99_lround llroundl
313 # elif defined(HAS_LROUNDL)
314 # define c99_lround lroundl
316 # define c99_nan nanl
317 # define c99_nearbyint nearbyintl
318 # define c99_nextafter nextafterl
319 # define c99_nexttoward nexttowardl
320 # define c99_remainder remainderl
321 # define c99_remquo remquol
322 # define c99_rint rintl
323 # define c99_round roundl
324 # define c99_scalbn scalbnl
325 # ifdef HAS_SIGNBIT /* possibly bad assumption */
326 # define c99_signbit signbitl
328 # define c99_tgamma tgammal
329 # define c99_trunc truncl
331 # define c99_acosh acosh
332 # define c99_asinh asinh
333 # define c99_atanh atanh
334 # define c99_cbrt cbrt
335 # define c99_copysign copysign
337 # define c99_erfc erfc
338 # define c99_exp2 exp2
339 # define c99_expm1 expm1
340 # define c99_fdim fdim
342 # define c99_fmax fmax
343 # define c99_fmin fmin
344 # define c99_hypot hypot
345 # define c99_ilogb ilogb
346 # define c99_lgamma lgamma
347 # define c99_log1p log1p
348 # define c99_log2 log2
349 # define c99_logb logb
350 # if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLRINT)
351 # define c99_lrint llrint
353 # define c99_lrint lrint
355 # if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLROUND)
356 # define c99_lround llround
358 # define c99_lround lround
361 # define c99_nearbyint nearbyint
362 # define c99_nextafter nextafter
363 # define c99_nexttoward nexttoward
364 # define c99_remainder remainder
365 # define c99_remquo remquo
366 # define c99_rint rint
367 # define c99_round round
368 # define c99_scalbn scalbn
369 /* We already define Perl_signbit in perl.h. */
371 # define c99_signbit signbit
373 # define c99_tgamma tgamma
374 # define c99_trunc trunc
377 /* AIX xlc (__IBMC__) really doesn't have the following long double
378 * math interfaces (no __acoshl128 aka acoshl, etc.), see
379 * hints/aix.sh. These are in the -lc128 but fail to be found
380 * during dynamic linking/loading.
382 * XXX1 Better Configure scans
383 * XXX2 Is this xlc version dependent? */
384 #if defined(USE_LONG_DOUBLE) && defined(__IBMC__)
404 # undef c99_nearbyint
405 # undef c99_nextafter
406 # undef c99_nexttoward
407 # undef c99_remainder
418 # define isunordered(x, y) (Perl_isnan(x) || Perl_isnan(y))
419 # elif defined(HAS_UNORDERED)
420 # define isunordered(x, y) unordered(x, y)
424 /* XXX these isgreater/isnormal/isunordered macros definitions should
425 * be moved further in the file to be part of the emulations, so that
426 * platforms can e.g. #undef c99_isunordered and have it work like
427 * it does for the other interfaces. */
429 #if !defined(isgreater) && defined(isunordered)
430 # define isgreater(x, y) (!isunordered((x), (y)) && (x) > (y))
431 # define isgreaterequal(x, y) (!isunordered((x), (y)) && (x) >= (y))
432 # define isless(x, y) (!isunordered((x), (y)) && (x) < (y))
433 # define islessequal(x, y) (!isunordered((x), (y)) && (x) <= (y))
434 # define islessgreater(x, y) (!isunordered((x), (y)) && \
435 ((x) > (y) || (y) > (x)))
438 /* Check both the Configure symbol and the macro-ness (like C99 promises). */
439 #if defined(HAS_FPCLASSIFY) && defined(fpclassify)
440 # define c99_fpclassify fpclassify
442 /* Like isnormal(), the isfinite(), isinf(), and isnan() are also C99
443 and also (sizeof-arg-aware) macros, but they are already well taken
444 care of by Configure et al, and defined in perl.h as
445 Perl_isfinite(), Perl_isinf(), and Perl_isnan(). */
447 # define c99_isnormal isnormal
449 #ifdef isgreater /* canary for all the C99 is*<cmp>* macros. */
450 # define c99_isgreater isgreater
451 # define c99_isgreaterequal isgreaterequal
452 # define c99_isless isless
453 # define c99_islessequal islessequal
454 # define c99_islessgreater islessgreater
455 # define c99_isunordered isunordered
458 /* The Great Wall of Undef where according to the definedness of HAS_FOO symbols
459 * the corresponding c99_foo wrappers are undefined. This list doesn't include
460 * the isfoo() interfaces because they are either type-aware macros, or dealt
461 * separately, already in perl.h */
502 #ifndef HAS_FPCLASSIFY
503 # undef c99_fpclassify
532 #ifndef HAS_NEARBYINT
533 # undef c99_nearbyint
535 #ifndef HAS_NEXTAFTER
536 # undef c99_nextafter
538 #ifndef HAS_NEXTTOWARD
539 # undef c99_nexttoward
541 #ifndef HAS_REMAINDER
542 # undef c99_remainder
568 /* Some APIs exist under Win32 with "underbar" names. */
571 # undef c99_nextafter
572 # define c99_hypot _hypot
573 # define c99_logb _logb
574 # define c99_nextafter _nextafter
576 # define bessel_j0 _j0
577 # define bessel_j1 _j1
578 # define bessel_jn _jn
579 # define bessel_y0 _y0
580 # define bessel_y1 _y1
581 # define bessel_yn _yn
585 /* The Bessel functions: BSD, SVID, XPG4, and POSIX. But not C99. */
586 #if defined(HAS_J0) && !defined(bessel_j0)
587 # if defined(USE_LONG_DOUBLE) && defined(HAS_J0L)
588 # define bessel_j0 j0l
589 # define bessel_j1 j1l
590 # define bessel_jn jnl
591 # define bessel_y0 y0l
592 # define bessel_y1 y1l
593 # define bessel_yn ynl
595 # define bessel_j0 j0
596 # define bessel_j1 j1
597 # define bessel_jn jn
598 # define bessel_y0 y0
599 # define bessel_y1 y1
600 # define bessel_yn yn
604 /* Emulations for missing math APIs.
606 * Keep in mind that the point of many of these functions is that
607 * they, if available, are supposed to give more precise/more
608 * numerically stable results.
610 * See e.g. http://www.johndcook.com/math_h.html
614 static NV my_acosh(NV x)
616 return Perl_log(x + Perl_sqrt(x * x - 1));
618 # define c99_acosh my_acosh
622 static NV my_asinh(NV x)
624 return Perl_log(x + Perl_sqrt(x * x + 1));
626 # define c99_asinh my_asinh
630 static NV my_atanh(NV x)
632 return (Perl_log(1 + x) - Perl_log(1 - x)) / 2;
634 # define c99_atanh my_atanh
638 static NV my_cbrt(NV x)
640 static const NV one_third = (NV)1.0/3;
641 return x >= 0.0 ? Perl_pow(x, one_third) : -Perl_pow(-x, one_third);
643 # define c99_cbrt my_cbrt
647 static NV my_copysign(NV x, NV y)
649 return y >= 0 ? (x < 0 ? -x : x) : (x < 0 ? x : -x);
651 # define c99_copysign my_copysign
654 /* XXX cosh (though c89) */
657 static NV my_erf(NV x)
659 /* http://www.johndcook.com/cpp_erf.html -- public domain */
661 NV a2 = -0.284496736;
663 NV a4 = -1.453152027;
667 int sign = x < 0 ? -1 : 1; /* Save the sign. */
670 /* Abramowitz and Stegun formula 7.1.26 */
671 t = 1.0 / (1.0 + p * x);
672 y = 1.0 - (((((a5*t + a4)*t) + a3)*t + a2)*t + a1) * t * Perl_exp(-x*x);
676 # define c99_erf my_erf
680 static NV my_erfc(NV x) {
681 /* This is not necessarily numerically stable, but better than nothing. */
682 return 1.0 - c99_erf(x);
684 # define c99_erfc my_erfc
688 static NV my_exp2(NV x)
690 return Perl_pow((NV)2.0, x);
692 # define c99_exp2 my_exp2
696 static NV my_expm1(NV x)
698 if (PERL_ABS(x) < 1e-5)
699 /* http://www.johndcook.com/cpp_expm1.html -- public domain.
700 * Taylor series, the first four terms (the last term quartic). */
701 /* Probably not enough for long doubles. */
702 return x * (1.0 + x * (1/2.0 + x * (1/6.0 + x/24.0)));
704 return Perl_exp(x) - 1;
706 # define c99_expm1 my_expm1
710 static NV my_fdim(NV x, NV y)
713 return (Perl_isnan(x) || Perl_isnan(y)) ? NV_NAN : (x > y ? x - y : 0);
715 return (x > y ? x - y : 0);
718 # define c99_fdim my_fdim
722 static NV my_fma(NV x, NV y, NV z)
726 # define c99_fma my_fma
730 static NV my_fmax(NV x, NV y)
734 return Perl_isnan(y) ? NV_NAN : y;
735 } else if (Perl_isnan(y)) {
739 return x > y ? x : y;
741 # define c99_fmax my_fmax
745 static NV my_fmin(NV x, NV y)
749 return Perl_isnan(y) ? NV_NAN : y;
750 } else if (Perl_isnan(y)) {
754 return x < y ? x : y;
756 # define c99_fmin my_fmin
759 #ifndef c99_fpclassify
761 static IV my_fpclassify(NV x)
763 #ifdef Perl_fp_class_inf
764 if (Perl_fp_class_inf(x)) return FP_INFINITE;
765 if (Perl_fp_class_nan(x)) return FP_NAN;
766 if (Perl_fp_class_norm(x)) return FP_NORMAL;
767 if (Perl_fp_class_denorm(x)) return FP_SUBNORMAL;
768 if (Perl_fp_class_zero(x)) return FP_ZERO;
769 # define c99_fpclassify my_fpclassify
777 static NV my_hypot(NV x, NV y)
779 /* http://en.wikipedia.org/wiki/Hypot */
781 x = PERL_ABS(x); /* Take absolute values. */
789 if (x < y) { /* Swap so that y is less. */
795 return x * Perl_sqrt(1.0 + t * t);
797 # define c99_hypot my_hypot
801 static IV my_ilogb(NV x)
803 return (IV)(Perl_log(x) * M_LOG2E);
805 # define c99_ilogb my_ilogb
808 /* tgamma and lgamma emulations based on
809 * http://www.johndcook.com/cpp_gamma.html,
810 * code placed in public domain.
812 * Note that these implementations (neither the johndcook originals
813 * nor these) do NOT set the global signgam variable. This is not
814 * necessarily a bad thing. */
816 /* Note that the tgamma() and lgamma() implementations
817 * here depend on each other. */
819 #if !defined(HAS_TGAMMA) || !defined(c99_tgamma)
820 static NV my_tgamma(NV x);
821 # define c99_tgamma my_tgamma
822 # define USE_MY_TGAMMA
824 #if !defined(HAS_LGAMMA) || !defined(c99_lgamma)
825 static NV my_lgamma(NV x);
826 # define c99_lgamma my_lgamma
827 # define USE_MY_LGAMMA
831 static NV my_tgamma(NV x)
833 const NV gamma = 0.577215664901532860606512090; /* Euler's gamma constant. */
835 if (Perl_isnan(x) || x < 0.0)
839 if (x == 0.0 || x == NV_INF)
840 return x == -0.0 ? -NV_INF : NV_INF;
843 /* The function domain is split into three intervals:
844 * (0, 0.001), [0.001, 12), and (12, infinity) */
846 /* First interval: (0, 0.001)
847 * For small values, 1/tgamma(x) has power series x + gamma x^2,
848 * so in this range, 1/tgamma(x) = x + gamma x^2 with error on the order of x^3.
849 * The relative error over this interval is less than 6e-7. */
851 return 1.0 / (x * (1.0 + gamma * x));
853 /* Second interval: [0.001, 12) */
855 double y = x; /* Working copy. */
857 /* Numerator coefficients for approximation over the interval (1,2) */
858 static const NV p[] = {
859 -1.71618513886549492533811E+0,
860 2.47656508055759199108314E+1,
861 -3.79804256470945635097577E+2,
862 6.29331155312818442661052E+2,
863 8.66966202790413211295064E+2,
864 -3.14512729688483675254357E+4,
865 -3.61444134186911729807069E+4,
866 6.64561438202405440627855E+4
868 /* Denominator coefficients for approximation over the interval (1, 2) */
869 static const NV q[] = {
870 -3.08402300119738975254353E+1,
871 3.15350626979604161529144E+2,
872 -1.01515636749021914166146E+3,
873 -3.10777167157231109440444E+3,
874 2.25381184209801510330112E+4,
875 4.75584627752788110767815E+3,
876 -1.34659959864969306392456E+5,
877 -1.15132259675553483497211E+5
888 n = (int)Perl_floor(y) - 1;
892 for (i = 0; i < 8; i++) {
893 num = (num + p[i]) * z;
894 den = den * z + q[i];
896 result = num / den + 1.0;
899 /* Use the identity tgamma(z) = tgamma(z+1)/z
900 * The variable "result" now holds tgamma of the original y + 1
901 * Thus we use y - 1 to get back the original y. */
905 /* Use the identity tgamma(z+n) = z*(z+1)* ... *(z+n-1)*tgamma(z) */
906 for (i = 0; i < n; i++)
914 /* Third interval: [12, +Inf) */
915 #if LDBL_MANT_DIG == 113 /* IEEE quad prec */
926 return Perl_exp(c99_lgamma(x));
931 static NV my_lgamma(NV x)
938 if (x <= 0 || x == NV_INF)
941 if (x == 1.0 || x == 2.0)
944 return Perl_log(PERL_ABS(c99_tgamma(x)));
945 /* Abramowitz and Stegun 6.1.41
946 * Asymptotic series should be good to at least 11 or 12 figures
947 * For error analysis, see Whittiker and Watson
948 * A Course in Modern Analysis (1927), page 252 */
950 static const NV c[8] = {
960 NV z = 1.0 / (x * x);
962 static const NV half_log_of_two_pi =
963 0.91893853320467274178032973640562;
966 for (i = 6; i >= 0; i--) {
971 return (x - 0.5) * Perl_log(x) - x + half_log_of_two_pi + series;
977 static NV my_log1p(NV x)
979 /* http://www.johndcook.com/cpp_log_one_plus_x.html -- public domain.
980 * Taylor series, the first four terms (the last term quartic). */
989 if (PERL_ABS(x) > 1e-4)
990 return Perl_log(1.0 + x);
992 /* Probably not enough for long doubles. */
993 return x * (1.0 + x * (-1/2.0 + x * (1/3.0 - x/4.0)));
995 # define c99_log1p my_log1p
999 static NV my_log2(NV x)
1001 return Perl_log(x) * M_LOG2E;
1003 # define c99_log2 my_log2
1008 /* XXX nexttoward */
1010 static int my_fegetround()
1012 #ifdef HAS_FEGETROUND
1013 return fegetround();
1014 #elif defined(HAS_FPGETROUND)
1015 switch (fpgetround()) {
1016 case FP_RN: return FE_TONEAREST;
1017 case FP_RZ: return FE_TOWARDZERO;
1018 case FP_RM: return FE_DOWNWARD;
1019 case FP_RP: return FE_UPWARD;
1022 #elif defined(FLT_ROUNDS)
1023 switch (FLT_ROUNDS) {
1024 case 0: return FE_TOWARDZERO;
1025 case 1: return FE_TONEAREST;
1026 case 2: return FE_UPWARD;
1027 case 3: return FE_DOWNWARD;
1030 #elif defined(__osf__) /* Tru64 */
1031 switch (read_rnd()) {
1032 case FP_RND_RN: return FE_TONEAREST;
1033 case FP_RND_RZ: return FE_TOWARDZERO;
1034 case FP_RND_RM: return FE_DOWNWARD;
1035 case FP_RND_RP: return FE_UPWARD;
1043 /* Toward closest integer. */
1044 #define MY_ROUND_NEAREST(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x) - 0.5)))
1047 #define MY_ROUND_TRUNC(x) ((NV)((IV)(x)))
1049 /* Toward minus infinity. */
1050 #define MY_ROUND_DOWN(x) ((NV)((IV)((x) >= 0.0 ? (x) : (x) - 0.5)))
1052 /* Toward plus infinity. */
1053 #define MY_ROUND_UP(x) ((NV)((IV)((x) >= 0.0 ? (x) + 0.5 : (x))))
1055 #if (!defined(c99_nearbyint) || !defined(c99_lrint)) && defined(FE_TONEAREST)
1056 static NV my_rint(NV x)
1059 switch (my_fegetround()) {
1060 case FE_TONEAREST: return MY_ROUND_NEAREST(x);
1061 case FE_TOWARDZERO: return MY_ROUND_TRUNC(x);
1062 case FE_DOWNWARD: return MY_ROUND_DOWN(x);
1063 case FE_UPWARD: return MY_ROUND_UP(x);
1066 #elif defined(HAS_FPGETROUND)
1067 switch (fpgetround()) {
1068 case FP_RN: return MY_ROUND_NEAREST(x);
1069 case FP_RZ: return MY_ROUND_TRUNC(x);
1070 case FP_RM: return MY_ROUND_DOWN(x);
1071 case FE_RP: return MY_ROUND_UP(x);
1079 /* XXX nearbyint() and rint() are not really identical -- but the difference
1080 * is messy: nearbyint is defined NOT to raise FE_INEXACT floating point
1081 * exceptions, while rint() is defined to MAYBE raise them. At the moment
1082 * Perl is blissfully unaware of such fine detail of floating point. */
1083 #ifndef c99_nearbyint
1084 # ifdef FE_TONEAREST
1085 # define c99_nearbyrint my_rint
1090 # ifdef FE_TONEAREST
1091 static IV my_lrint(NV x)
1093 return (IV)my_rint(x);
1095 # define c99_lrint my_lrint
1100 static IV my_lround(NV x)
1102 return (IV)MY_ROUND_NEAREST(x);
1104 # define c99_lround my_lround
1112 # ifdef FE_TONEAREST
1113 # define c99_rint my_rint
1118 static NV my_round(NV x)
1120 return MY_ROUND_NEAREST(x);
1122 # define c99_round my_round
1126 # if defined(Perl_ldexp) && FLT_RADIX == 2
1127 static NV my_scalbn(NV x, int y)
1129 return Perl_ldexp(x, y);
1131 # define c99_scalbn my_scalbn
1135 /* XXX sinh (though c89) */
1137 /* tgamma -- see lgamma */
1139 /* XXX tanh (though c89) */
1142 static NV my_trunc(NV x)
1144 return MY_ROUND_TRUNC(x);
1146 # define c99_trunc my_trunc
1151 #undef NV_PAYLOAD_DEBUG
1153 /* NOTE: the NaN payload API implementation is hand-rolled, since the
1154 * APIs are only proposed ones as of June 2015, so very few, if any,
1155 * platforms have implementations yet, so HAS_SETPAYLOAD and such are
1156 * unlikely to be helpful.
1158 * XXX - if the core numification wants to actually generate
1159 * the nan payload in "nan(123)", and maybe "nans(456)", for
1160 * signaling payload", this needs to be moved to e.g. numeric.c
1161 * (look for grok_infnan)
1163 * Conversely, if the core stringification wants the nan payload
1164 * and/or the nan quiet/signaling distinction, S_getpayload()
1165 * from this file needs to be moved, to e.g. sv.c (look for S_infnan_2pv),
1166 * and the (trivial) functionality of issignaling() copied
1167 * (for generating "NaNS", or maybe even "NaNQ") -- or maybe there
1168 * are too many formatting parameters for simple stringification?
1171 /* While it might make sense for the payload to be UV or IV,
1172 * to avoid conversion loss, the proposed ISO interfaces use
1173 * a floating point input, which is then truncated to integer,
1174 * and only the integer part being used. This is workable,
1175 * except for: (1) the conversion loss (2) suboptimal for
1176 * 32-bit integer platforms. A workaround API for (2) and
1177 * in general for bit-honesty would be an array of integers
1178 * as the payload... but the proposed C API does nothing of
1180 #if NVSIZE == UVSIZE
1181 # define NV_PAYLOAD_TYPE UV
1183 # define NV_PAYLOAD_TYPE NV
1186 #if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE)
1187 # define NV_PAYLOAD_SIZEOF_ASSERT(a) \
1188 STATIC_ASSERT_STMT(sizeof(a) == NVSIZE / 2)
1190 # define NV_PAYLOAD_SIZEOF_ASSERT(a) \
1191 STATIC_ASSERT_STMT(sizeof(a) == NVSIZE)
1194 static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling)
1197 static const U8 m[] = { NV_NAN_PAYLOAD_MASK };
1198 static const U8 p[] = { NV_NAN_PAYLOAD_PERM };
1199 UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 };
1201 NV_PAYLOAD_SIZEOF_ASSERT(m);
1202 NV_PAYLOAD_SIZEOF_ASSERT(p);
1204 /* Divide the input into the array in "base unsigned integer" in
1205 * little-endian order. Note that the integer might be smaller than
1206 * an NV (if UV is U32, for example). */
1207 #if NVSIZE == UVSIZE
1208 a[0] = payload; /* The trivial case. */
1211 NV t1 = c99_trunc(payload); /* towards zero (drop fractional) */
1212 #ifdef NV_PAYLOAD_DEBUG
1213 Perl_warn(aTHX_ "t1 = %"NVgf" (payload %"NVgf")\n", t1, payload);
1216 a[0] = (UV)t1; /* Fast path, also avoids rounding errors (right?) */
1218 /* UVSIZE < NVSIZE or payload > UV_MAX.
1220 * This may happen for example if:
1221 * (1) UVSIZE == 32 and common 64-bit double NV
1222 * (32-bit system not using -Duse64bitint)
1223 * (2) UVSIZE == 64 and the x86-style 80-bit long double NV
1224 * (note that here the room for payload is actually the 64 bits)
1225 * (3) UVSIZE == 64 and the 128-bit IEEE 764 quadruple NV
1226 * (112 bits in mantissa, 111 bits room for payload)
1228 * NOTE: this is very sensitive to correctly functioning
1229 * fmod()/fmodl(), and correct casting of big-unsigned-integer to NV.
1230 * If these don't work right, especially the low order bits
1231 * are in danger. For example Solaris and AIX seem to have issues
1232 * here, especially if using 32-bit UVs. */
1234 for (i = 0, t2 = t1; i < (int)C_ARRAY_LENGTH(a); i++) {
1235 a[i] = (UV)Perl_fmod(t2, (NV)UV_MAX);
1236 t2 = Perl_floor(t2 / (NV)UV_MAX);
1241 #ifdef NV_PAYLOAD_DEBUG
1242 for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) {
1243 Perl_warn(aTHX_ "a[%d] = 0x%"UVxf"\n", i, a[i]);
1246 for (i = 0; i < (int)sizeof(p); i++) {
1247 if (m[i] && p[i] < sizeof(p)) {
1248 U8 s = (p[i] % UVSIZE) << 3;
1249 UV u = a[p[i] / UVSIZE] & ((UV)0xFF << s);
1250 U8 b = (U8)((u >> s) & m[i]);
1251 ((U8 *)(nvp))[i] &= ~m[i]; /* For NaNs with non-zero payload bits. */
1252 ((U8 *)(nvp))[i] |= b;
1253 #ifdef NV_PAYLOAD_DEBUG
1254 Perl_warn(aTHX_ "set p[%2d] = %02x (i = %d, m = %02x, s = %2d, b = %02x, u = %08"UVxf")\n", i, ((U8 *)(nvp))[i], i, m[i], s, b, u);
1256 a[p[i] / UVSIZE] &= ~u;
1260 NV_NAN_SET_SIGNALING(nvp);
1262 #ifdef USE_LONG_DOUBLE
1263 # if LONG_DOUBLEKIND == 3 || LONG_DOUBLEKIND == 4
1264 # if LONG_DOUBLESIZE > 10
1265 memset((char *)nvp + 10, '\0', LONG_DOUBLESIZE - 10); /* x86 long double */
1269 for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) {
1271 Perl_warn(aTHX_ "payload lost bits (%"UVxf")", a[i]);
1275 #ifdef NV_PAYLOAD_DEBUG
1276 for (i = 0; i < NVSIZE; i++) {
1277 PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(nvp))[i]);
1279 PerlIO_printf(Perl_debug_log, "\n");
1283 static NV_PAYLOAD_TYPE S_getpayload(NV nv)
1286 static const U8 m[] = { NV_NAN_PAYLOAD_MASK };
1287 static const U8 p[] = { NV_NAN_PAYLOAD_PERM };
1288 UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 };
1291 NV_PAYLOAD_SIZEOF_ASSERT(m);
1292 NV_PAYLOAD_SIZEOF_ASSERT(p);
1294 for (i = 0; i < (int)sizeof(p); i++) {
1295 if (m[i] && p[i] < NVSIZE) {
1296 U8 s = (p[i] % UVSIZE) << 3;
1297 a[p[i] / UVSIZE] |= (UV)(((U8 *)(&nv))[i] & m[i]) << s;
1300 for (i = (int)C_ARRAY_LENGTH(a) - 1; i >= 0; i--) {
1301 #ifdef NV_PAYLOAD_DEBUG
1302 Perl_warn(aTHX_ "a[%d] = %"UVxf"\n", i, a[i]);
1307 #ifdef NV_PAYLOAD_DEBUG
1308 for (i = 0; i < NVSIZE; i++) {
1309 PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(&nv))[i]);
1311 PerlIO_printf(Perl_debug_log, "\n");
1316 #endif /* #ifdef NV_NAN */
1318 /* XXX This comment is just to make I_TERMIO and I_SGTTY visible to
1319 metaconfig for future extension writers. We don't use them in POSIX.
1320 (This is really sneaky :-) --AD
1322 #if defined(I_TERMIOS)
1323 #include <termios.h>
1331 #include <sys/stat.h>
1332 #include <sys/types.h>
1340 # if !defined(WIN32) && !defined(__CYGWIN__) && !defined(NETWARE) && !defined(__UWIN__)
1341 extern char *tzname[];
1344 #if !defined(WIN32) && !defined(__UWIN__) || (defined(__MINGW32__) && !defined(tzname))
1345 char *tzname[] = { "" , "" };
1349 #if defined(__VMS) && !defined(__POSIX_SOURCE)
1351 # include <utsname.h>
1354 # define mkfifo(a,b) (not_here("mkfifo"),-1)
1356 /* The POSIX notion of ttyname() is better served by getname() under VMS */
1357 static char ttnambuf[64];
1358 # define ttyname(fd) (isatty(fd) > 0 ? getname(fd,ttnambuf,0) : NULL)
1361 #if defined (__CYGWIN__)
1362 # define tzname _tzname
1364 #if defined (WIN32) || defined (NETWARE)
1366 # define mkfifo(a,b) not_here("mkfifo")
1367 # define ttyname(a) (char*)not_here("ttyname")
1368 # define sigset_t long
1371 # define mode_t short
1374 # define mode_t short
1376 # define tzset() not_here("tzset")
1378 # ifndef _POSIX_OPEN_MAX
1379 # define _POSIX_OPEN_MAX FOPEN_MAX /* XXX bogus ? */
1382 # define sigaction(a,b,c) not_here("sigaction")
1383 # define sigpending(a) not_here("sigpending")
1384 # define sigprocmask(a,b,c) not_here("sigprocmask")
1385 # define sigsuspend(a) not_here("sigsuspend")
1386 # define sigemptyset(a) not_here("sigemptyset")
1387 # define sigaddset(a,b) not_here("sigaddset")
1388 # define sigdelset(a,b) not_here("sigdelset")
1389 # define sigfillset(a) not_here("sigfillset")
1390 # define sigismember(a,b) not_here("sigismember")
1394 # define setuid(a) not_here("setuid")
1395 # define setgid(a) not_here("setgid")
1396 #endif /* NETWARE */
1397 #ifndef USE_LONG_DOUBLE
1398 # define strtold(s1,s2) not_here("strtold")
1399 #endif /* USE_LONG_DOUBLE */
1403 # if defined(OS2) || defined(__amigaos4__)
1404 # define mkfifo(a,b) not_here("mkfifo")
1405 # else /* !( defined OS2 ) */
1407 # define mkfifo(path, mode) (mknod((path), (mode) | S_IFIFO, 0))
1410 # endif /* !HAS_MKFIFO */
1415 # include <sys/times.h>
1417 # include <sys/utsname.h>
1419 # ifndef __amigaos4__
1420 # include <sys/wait.h>
1425 #endif /* WIN32 || NETWARE */
1429 typedef long SysRetLong;
1430 typedef sigset_t* POSIX__SigSet;
1431 typedef HV* POSIX__SigAction;
1432 typedef int POSIX__SigNo;
1433 typedef int POSIX__Fd;
1435 typedef struct termios* POSIX__Termios;
1436 #else /* Define termios types to int, and call not_here for the functions.*/
1437 #define POSIX__Termios int
1439 #define tcflag_t int
1441 #define cfgetispeed(x) not_here("cfgetispeed")
1442 #define cfgetospeed(x) not_here("cfgetospeed")
1443 #define tcdrain(x) not_here("tcdrain")
1444 #define tcflush(x,y) not_here("tcflush")
1445 #define tcsendbreak(x,y) not_here("tcsendbreak")
1446 #define cfsetispeed(x,y) not_here("cfsetispeed")
1447 #define cfsetospeed(x,y) not_here("cfsetospeed")
1448 #define ctermid(x) (char *) not_here("ctermid")
1449 #define tcflow(x,y) not_here("tcflow")
1450 #define tcgetattr(x,y) not_here("tcgetattr")
1451 #define tcsetattr(x,y,z) not_here("tcsetattr")
1454 /* Possibly needed prototypes */
1457 double strtod (const char *, char **);
1458 long strtol (const char *, char **, int);
1459 unsigned long strtoul (const char *, char **, int);
1461 long double strtold (const char *, char **);
1466 #ifndef HAS_DIFFTIME
1468 #define difftime(a,b) not_here("difftime")
1471 #ifndef HAS_FPATHCONF
1472 #define fpathconf(f,n) (SysRetLong) not_here("fpathconf")
1475 #define mktime(a) not_here("mktime")
1478 #define nice(a) not_here("nice")
1480 #ifndef HAS_PATHCONF
1481 #define pathconf(f,n) (SysRetLong) not_here("pathconf")
1484 #define sysconf(n) (SysRetLong) not_here("sysconf")
1486 #ifndef HAS_READLINK
1487 #define readlink(a,b,c) not_here("readlink")
1490 #define setpgid(a,b) not_here("setpgid")
1493 #define setsid() not_here("setsid")
1496 #define strcoll(s1,s2) not_here("strcoll")
1499 #define strtod(s1,s2) not_here("strtod")
1502 #define strtold(s1,s2) not_here("strtold")
1505 #define strtol(s1,s2,b) not_here("strtol")
1508 #define strtoul(s1,s2,b) not_here("strtoul")
1511 #define strxfrm(s1,s2,n) not_here("strxfrm")
1513 #ifndef HAS_TCGETPGRP
1514 #define tcgetpgrp(a) not_here("tcgetpgrp")
1516 #ifndef HAS_TCSETPGRP
1517 #define tcsetpgrp(a,b) not_here("tcsetpgrp")
1521 #define times(a) not_here("times")
1522 #endif /* NETWARE */
1525 #define uname(a) not_here("uname")
1528 #define waitpid(a,b,c) not_here("waitpid")
1533 #define mblen(a,b) not_here("mblen")
1536 #ifndef HAS_MBSTOWCS
1537 #define mbstowcs(s, pwcs, n) not_here("mbstowcs")
1540 #define mbtowc(pwc, s, n) not_here("mbtowc")
1542 #ifndef HAS_WCSTOMBS
1543 #define wcstombs(s, pwcs, n) not_here("wcstombs")
1546 #define wctomb(s, wchar) not_here("wcstombs")
1548 #if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB)
1549 /* If we don't have these functions, then we wouldn't have gotten a typedef
1550 for wchar_t, the wide character type. Defining wchar_t allows the
1551 functions referencing it to compile. Its actual type is then meaningless,
1552 since without the above functions, all sections using it end up calling
1553 not_here() and croak. --Kaveh Ghazi (ghazi@noc.rutgers.edu) 9/18/94. */
1555 #define wchar_t char
1559 #ifndef HAS_LOCALECONV
1560 # define localeconv() not_here("localeconv")
1562 struct lconv_offset {
1567 static const struct lconv_offset lconv_strings[] = {
1568 #ifdef USE_LOCALE_NUMERIC
1569 {"decimal_point", STRUCT_OFFSET(struct lconv, decimal_point)},
1570 {"thousands_sep", STRUCT_OFFSET(struct lconv, thousands_sep)},
1571 # ifndef NO_LOCALECONV_GROUPING
1572 {"grouping", STRUCT_OFFSET(struct lconv, grouping)},
1575 #ifdef USE_LOCALE_MONETARY
1576 {"int_curr_symbol", STRUCT_OFFSET(struct lconv, int_curr_symbol)},
1577 {"currency_symbol", STRUCT_OFFSET(struct lconv, currency_symbol)},
1578 {"mon_decimal_point", STRUCT_OFFSET(struct lconv, mon_decimal_point)},
1579 # ifndef NO_LOCALECONV_MON_THOUSANDS_SEP
1580 {"mon_thousands_sep", STRUCT_OFFSET(struct lconv, mon_thousands_sep)},
1582 # ifndef NO_LOCALECONV_MON_GROUPING
1583 {"mon_grouping", STRUCT_OFFSET(struct lconv, mon_grouping)},
1585 {"positive_sign", STRUCT_OFFSET(struct lconv, positive_sign)},
1586 {"negative_sign", STRUCT_OFFSET(struct lconv, negative_sign)},
1591 #ifdef USE_LOCALE_NUMERIC
1593 /* The Linux man pages say these are the field names for the structure
1594 * components that are LC_NUMERIC; the rest being LC_MONETARY */
1595 # define isLC_NUMERIC_STRING(name) (strEQ(name, "decimal_point") \
1596 || strEQ(name, "thousands_sep") \
1598 /* There should be no harm done \
1599 * checking for this, even if \
1600 * NO_LOCALECONV_GROUPING */ \
1601 || strEQ(name, "grouping"))
1603 # define isLC_NUMERIC_STRING(name) (0)
1606 static const struct lconv_offset lconv_integers[] = {
1607 #ifdef USE_LOCALE_MONETARY
1608 {"int_frac_digits", STRUCT_OFFSET(struct lconv, int_frac_digits)},
1609 {"frac_digits", STRUCT_OFFSET(struct lconv, frac_digits)},
1610 {"p_cs_precedes", STRUCT_OFFSET(struct lconv, p_cs_precedes)},
1611 {"p_sep_by_space", STRUCT_OFFSET(struct lconv, p_sep_by_space)},
1612 {"n_cs_precedes", STRUCT_OFFSET(struct lconv, n_cs_precedes)},
1613 {"n_sep_by_space", STRUCT_OFFSET(struct lconv, n_sep_by_space)},
1614 {"p_sign_posn", STRUCT_OFFSET(struct lconv, p_sign_posn)},
1615 {"n_sign_posn", STRUCT_OFFSET(struct lconv, n_sign_posn)},
1616 #ifdef HAS_LC_MONETARY_2008
1617 {"int_p_cs_precedes", STRUCT_OFFSET(struct lconv, int_p_cs_precedes)},
1618 {"int_p_sep_by_space", STRUCT_OFFSET(struct lconv, int_p_sep_by_space)},
1619 {"int_n_cs_precedes", STRUCT_OFFSET(struct lconv, int_n_cs_precedes)},
1620 {"int_n_sep_by_space", STRUCT_OFFSET(struct lconv, int_n_sep_by_space)},
1621 {"int_p_sign_posn", STRUCT_OFFSET(struct lconv, int_p_sign_posn)},
1622 {"int_n_sign_posn", STRUCT_OFFSET(struct lconv, int_n_sign_posn)},
1628 #endif /* HAS_LOCALECONV */
1630 #ifdef HAS_LONG_DOUBLE
1631 # if LONG_DOUBLESIZE > NVSIZE
1632 # undef HAS_LONG_DOUBLE /* XXX until we figure out how to use them */
1636 #ifndef HAS_LONG_DOUBLE
1648 /* Background: in most systems the low byte of the wait status
1649 * is the signal (the lowest 7 bits) and the coredump flag is
1650 * the eight bit, and the second lowest byte is the exit status.
1651 * BeOS bucks the trend and has the bytes in different order.
1652 * See beos/beos.c for how the reality is bent even in BeOS
1653 * to follow the traditional. However, to make the POSIX
1654 * wait W*() macros to work in BeOS, we need to unbend the
1655 * reality back in place. --jhi */
1656 /* In actual fact the code below is to blame here. Perl has an internal
1657 * representation of the exit status ($?), which it re-composes from the
1658 * OS's representation using the W*() POSIX macros. The code below
1659 * incorrectly uses the W*() macros on the internal representation,
1660 * which fails for OSs that have a different representation (namely BeOS
1661 * and Haiku). WMUNGE() is a hack that converts the internal
1662 * representation into the OS specific one, so that the W*() macros work
1663 * as expected. The better solution would be not to use the W*() macros
1664 * in the first place, though. -- Ingo Weinhold
1666 #if defined(__HAIKU__)
1667 # define WMUNGE(x) (((x) & 0xFF00) >> 8 | ((x) & 0x00FF) << 8)
1669 # define WMUNGE(x) (x)
1673 not_here(const char *s)
1675 croak("POSIX::%s not implemented on this architecture", s);
1679 #include "const-c.inc"
1682 restore_sigmask(pTHX_ SV *osset_sv)
1684 /* Fortunately, restoring the signal mask can't fail, because
1685 * there's nothing we can do about it if it does -- we're not
1686 * supposed to return -1 from sigaction unless the disposition
1689 #if !(defined(__amigaos4__) && defined(__NEWLIB__))
1690 sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv );
1691 (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0);
1696 allocate_struct(pTHX_ SV *rv, const STRLEN size, const char *packname) {
1697 SV *const t = newSVrv(rv, packname);
1698 void *const p = sv_grow(t, size + 1);
1700 /* Ensure at least one use of not_here() to avoid "defined but not
1701 * used" warning. This is not at all related to allocate_struct(); I
1702 * just needed somewhere to dump it - DAPM */
1703 if (0) { not_here(""); }
1713 * (1) The CRT maintains its own copy of the environment, separate from
1714 * the Win32API copy.
1716 * (2) CRT getenv() retrieves from this copy. CRT putenv() updates this
1717 * copy, and then calls SetEnvironmentVariableA() to update the Win32API
1720 * (3) win32_getenv() and win32_putenv() call GetEnvironmentVariableA() and
1721 * SetEnvironmentVariableA() directly, bypassing the CRT copy of the
1724 * (4) The CRT strftime() "%Z" implementation calls __tzset(). That
1725 * calls CRT tzset(), but only the first time it is called, and in turn
1726 * that uses CRT getenv("TZ") to retrieve the timezone info from the CRT
1727 * local copy of the environment and hence gets the original setting as
1728 * perl never updates the CRT copy when assigning to $ENV{TZ}.
1730 * Therefore, we need to retrieve the value of $ENV{TZ} and call CRT
1731 * putenv() to update the CRT copy of the environment (if it is different)
1732 * whenever we're about to call tzset().
1734 * In addition to all that, when perl is built with PERL_IMPLICIT_SYS
1737 * (a) Each interpreter has its own copy of the environment inside the
1738 * perlhost structure. That allows applications that host multiple
1739 * independent Perl interpreters to isolate environment changes from
1740 * each other. (This is similar to how the perlhost mechanism keeps a
1741 * separate working directory for each Perl interpreter, so that calling
1742 * chdir() will not affect other interpreters.)
1744 * (b) Only the first Perl interpreter instantiated within a process will
1745 * "write through" environment changes to the process environment.
1747 * (c) Even the primary Perl interpreter won't update the CRT copy of the
1748 * the environment, only the Win32API copy (it calls win32_putenv()).
1750 * As with CPerlHost::Getenv() and CPerlHost::Putenv() themselves, it makes
1751 * sense to only update the process environment when inside the main
1752 * interpreter, but we don't have access to CPerlHost's m_bTopLevel member
1753 * from here so we'll just have to check PL_curinterp instead.
1755 * Therefore, we can simply #undef getenv() and putenv() so that those names
1756 * always refer to the CRT functions, and explicitly call win32_getenv() to
1757 * access perl's %ENV.
1759 * We also #undef malloc() and free() to be sure we are using the CRT
1760 * functions otherwise under PERL_IMPLICIT_SYS they are redefined to calls
1761 * into VMem::Malloc() and VMem::Free() and all allocations will be freed
1762 * when the Perl interpreter is being destroyed so we'd end up with a pointer
1763 * into deallocated memory in environ[] if a program embedding a Perl
1764 * interpreter continues to operate even after the main Perl interpreter has
1767 * Note that we don't free() the malloc()ed memory unless and until we call
1768 * malloc() again ourselves because the CRT putenv() function simply puts its
1769 * pointer argument into the environ[] array (it doesn't make a copy of it)
1770 * so this memory must otherwise be leaked.
1779 fix_win32_tzenv(void)
1781 static char* oldenv = NULL;
1783 const char* perl_tz_env = win32_getenv("TZ");
1784 const char* crt_tz_env = getenv("TZ");
1785 if (perl_tz_env == NULL)
1787 if (crt_tz_env == NULL)
1789 if (strcmp(perl_tz_env, crt_tz_env) != 0) {
1790 newenv = (char*)malloc((strlen(perl_tz_env) + 4) * sizeof(char));
1791 if (newenv != NULL) {
1792 sprintf(newenv, "TZ=%s", perl_tz_env);
1804 * my_tzset - wrapper to tzset() with a fix to make it work (better) on Win32.
1805 * This code is duplicated in the Time-Piece module, so any changes made here
1806 * should be made there too.
1812 #if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
1813 if (PL_curinterp == aTHX)
1820 MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig
1823 new(packname = "POSIX::SigSet", ...)
1824 const char * packname
1829 = (sigset_t *) allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
1833 for (i = 1; i < items; i++)
1834 sigaddset(s, SvIV(ST(i)));
1840 POSIX::SigSet sigset
1845 RETVAL = ix ? sigdelset(sigset, sig) : sigaddset(sigset, sig);
1851 POSIX::SigSet sigset
1855 RETVAL = ix ? sigfillset(sigset) : sigemptyset(sigset);
1860 sigismember(sigset, sig)
1861 POSIX::SigSet sigset
1864 MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf
1867 new(packname = "POSIX::Termios", ...)
1868 const char * packname
1872 void *const p = allocate_struct(aTHX_ (ST(0) = sv_newmortal()),
1873 sizeof(struct termios), packname);
1874 /* The previous implementation stored a pointer to an uninitialised
1875 struct termios. Seems safer to initialise it, particularly as
1876 this implementation exposes the struct to prying from perl-space.
1878 memset(p, 0, 1 + sizeof(struct termios));
1881 not_here("termios");
1886 getattr(termios_ref, fd = 0)
1887 POSIX::Termios termios_ref
1890 RETVAL = tcgetattr(fd, termios_ref);
1894 # If we define TCSANOW here then both a found and not found constant sub
1895 # are created causing a Constant subroutine TCSANOW redefined warning
1897 # define DEF_SETATTR_ACTION 0
1899 # define DEF_SETATTR_ACTION TCSANOW
1902 setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION)
1903 POSIX::Termios termios_ref
1905 int optional_actions
1907 /* The second argument to the call is mandatory, but we'd like to give
1908 it a useful default. 0 isn't valid on all operating systems - on
1909 Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same
1910 values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF. */
1911 if (optional_actions < 0) {
1912 SETERRNO(EINVAL, LIB_INVARG);
1915 RETVAL = tcsetattr(fd, optional_actions, termios_ref);
1921 getispeed(termios_ref)
1922 POSIX::Termios termios_ref
1926 RETVAL = ix ? cfgetospeed(termios_ref) : cfgetispeed(termios_ref);
1931 getiflag(termios_ref)
1932 POSIX::Termios termios_ref
1938 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
1941 RETVAL = termios_ref->c_iflag;
1944 RETVAL = termios_ref->c_oflag;
1947 RETVAL = termios_ref->c_cflag;
1950 RETVAL = termios_ref->c_lflag;
1953 RETVAL = 0; /* silence compiler warning */
1956 not_here(GvNAME(CvGV(cv)));
1963 getcc(termios_ref, ccix)
1964 POSIX::Termios termios_ref
1967 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
1969 croak("Bad getcc subscript");
1970 RETVAL = termios_ref->c_cc[ccix];
1979 setispeed(termios_ref, speed)
1980 POSIX::Termios termios_ref
1986 ? cfsetospeed(termios_ref, speed) : cfsetispeed(termios_ref, speed);
1991 setiflag(termios_ref, flag)
1992 POSIX::Termios termios_ref
1999 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2002 termios_ref->c_iflag = flag;
2005 termios_ref->c_oflag = flag;
2008 termios_ref->c_cflag = flag;
2011 termios_ref->c_lflag = flag;
2015 not_here(GvNAME(CvGV(cv)));
2019 setcc(termios_ref, ccix, cc)
2020 POSIX::Termios termios_ref
2024 #ifdef I_TERMIOS /* References a termios structure member so ifdef it out. */
2026 croak("Bad setcc subscript");
2027 termios_ref->c_cc[ccix] = cc;
2033 MODULE = POSIX PACKAGE = POSIX
2035 INCLUDE: const-xs.inc
2041 POSIX::WIFEXITED = 1
2042 POSIX::WIFSIGNALED = 2
2043 POSIX::WIFSTOPPED = 3
2047 #if !defined(WEXITSTATUS) || !defined(WIFEXITED) || !defined(WIFSIGNALED) \
2048 || !defined(WIFSTOPPED) || !defined(WSTOPSIG) || !defined(WTERMSIG)
2049 RETVAL = 0; /* Silence compilers that notice this, but don't realise
2050 that not_here() can't return. */
2055 RETVAL = WEXITSTATUS(WMUNGE(status));
2057 not_here("WEXITSTATUS");
2062 RETVAL = WIFEXITED(WMUNGE(status));
2064 not_here("WIFEXITED");
2069 RETVAL = WIFSIGNALED(WMUNGE(status));
2071 not_here("WIFSIGNALED");
2076 RETVAL = WIFSTOPPED(WMUNGE(status));
2078 not_here("WIFSTOPPED");
2083 RETVAL = WSTOPSIG(WMUNGE(status));
2085 not_here("WSTOPSIG");
2090 RETVAL = WTERMSIG(WMUNGE(status));
2092 not_here("WTERMSIG");
2096 croak("Illegal alias %d for POSIX::W*", (int)ix);
2102 open(filename, flags = O_RDONLY, mode = 0666)
2107 if (flags & (O_APPEND|O_CREAT|O_TRUNC|O_RDWR|O_WRONLY|O_EXCL))
2108 TAINT_PROPER("open");
2109 RETVAL = open(filename, flags, mode);
2117 #ifndef HAS_LOCALECONV
2118 localeconv(); /* A stub to call not_here(). */
2120 struct lconv *lcbuf;
2122 /* localeconv() deals with both LC_NUMERIC and LC_MONETARY, but
2123 * LC_MONETARY is already in the correct locale */
2124 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
2125 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
2128 sv_2mortal((SV*)RETVAL);
2129 if ((lcbuf = localeconv())) {
2130 const struct lconv_offset *strings = lconv_strings;
2131 const struct lconv_offset *integers = lconv_integers;
2132 const char *ptr = (const char *) lcbuf;
2134 while (strings->name) {
2135 /* This string may be controlled by either LC_NUMERIC, or
2138 #if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY)
2139 = _is_cur_LC_category_utf8((isLC_NUMERIC_STRING(strings->name))
2142 #elif defined(USE_LOCALE_NUMERIC)
2143 = _is_cur_LC_category_utf8(LC_NUMERIC);
2144 #elif defined(USE_LOCALE_MONETARY)
2145 = _is_cur_LC_category_utf8(LC_MONETARY);
2150 const char *value = *((const char **)(ptr + strings->offset));
2152 if (value && *value) {
2153 (void) hv_store(RETVAL,
2155 strlen(strings->name),
2160 /* We mark it as UTF-8 if a utf8 locale and is
2161 * valid and variant under UTF-8 */
2163 && ! is_utf8_invariant_string((U8 *) value, 0)
2164 && is_utf8_string((U8 *) value, 0)),
2170 while (integers->name) {
2171 const char value = *((const char *)(ptr + integers->offset));
2173 if (value != CHAR_MAX)
2174 (void) hv_store(RETVAL, integers->name,
2175 strlen(integers->name), newSViv(value), 0);
2179 RESTORE_LC_NUMERIC_STANDARD();
2180 #endif /* HAS_LOCALECONV */
2185 setlocale(category, locale = 0)
2191 #ifdef USE_LOCALE_NUMERIC
2192 /* A 0 (or NULL) locale means only query what the current one is. We
2193 * have the LC_NUMERIC name saved, because we are normally switched
2194 * into the C locale for it. Switch back so an LC_ALL query will yield
2195 * the correct results; all other categories don't require special
2198 if (category == LC_NUMERIC) {
2199 XSRETURN_PV(PL_numeric_name);
2202 else if (category == LC_ALL) {
2203 SET_NUMERIC_UNDERLYING();
2208 #ifdef WIN32 /* Use wrapper on Windows */
2209 retval = Perl_my_setlocale(aTHX_ category, locale);
2211 retval = setlocale(category, locale);
2213 DEBUG_L(PerlIO_printf(Perl_debug_log,
2214 "%s:%d: %s\n", __FILE__, __LINE__,
2215 _setlocale_debug_string(category, locale, retval)));
2217 /* Should never happen that a query would return an error, but be
2218 * sure and reset to C locale */
2220 SET_NUMERIC_STANDARD();
2225 /* Save retval since subsequent setlocale() calls may overwrite it. */
2226 retval = savepv(retval);
2229 /* For locale == 0, we may have switched to NUMERIC_UNDERLYING. Switch
2232 SET_NUMERIC_STANDARD();
2233 XSRETURN_PV(retval);
2237 #ifdef USE_LOCALE_CTYPE
2238 if (category == LC_CTYPE
2240 || category == LC_ALL
2246 if (category == LC_ALL) {
2247 newctype = setlocale(LC_CTYPE, NULL);
2248 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2249 "%s:%d: %s\n", __FILE__, __LINE__,
2250 _setlocale_debug_string(LC_CTYPE, NULL, newctype)));
2255 new_ctype(newctype);
2257 #endif /* USE_LOCALE_CTYPE */
2258 #ifdef USE_LOCALE_COLLATE
2259 if (category == LC_COLLATE
2261 || category == LC_ALL
2267 if (category == LC_ALL) {
2268 newcoll = setlocale(LC_COLLATE, NULL);
2269 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2270 "%s:%d: %s\n", __FILE__, __LINE__,
2271 _setlocale_debug_string(LC_COLLATE, NULL, newcoll)));
2276 new_collate(newcoll);
2278 #endif /* USE_LOCALE_COLLATE */
2279 #ifdef USE_LOCALE_NUMERIC
2280 if (category == LC_NUMERIC
2282 || category == LC_ALL
2288 if (category == LC_ALL) {
2289 newnum = setlocale(LC_NUMERIC, NULL);
2290 DEBUG_Lv(PerlIO_printf(Perl_debug_log,
2291 "%s:%d: %s\n", __FILE__, __LINE__,
2292 _setlocale_debug_string(LC_NUMERIC, NULL, newnum)));
2297 new_numeric(newnum);
2299 #endif /* USE_LOCALE_NUMERIC */
2347 RETVAL = Perl_acos(x); /* C89 math */
2351 RETVAL = c99_acosh(x);
2357 RETVAL = Perl_asin(x); /* C89 math */
2361 RETVAL = c99_asinh(x);
2367 RETVAL = Perl_atan(x); /* C89 math */
2371 RETVAL = c99_atanh(x);
2378 RETVAL = c99_cbrt(x);
2384 RETVAL = Perl_ceil(x); /* C89 math */
2387 RETVAL = Perl_cosh(x); /* C89 math */
2391 RETVAL = c99_erf(x);
2398 RETVAL = c99_erfc(x);
2405 RETVAL = c99_exp2(x);
2412 RETVAL = c99_expm1(x);
2418 RETVAL = Perl_floor(x); /* C89 math */
2422 RETVAL = bessel_j0(x);
2429 RETVAL = bessel_j1(x);
2435 /* XXX Note: the lgamma modifies a global variable (signgam),
2436 * which is evil. Some platforms have lgamma_r, which has
2437 * extra output parameter instead of the global variable. */
2439 RETVAL = c99_lgamma(x);
2445 RETVAL = log10(x); /* C89 math */
2449 RETVAL = c99_log1p(x);
2456 RETVAL = c99_log2(x);
2463 RETVAL = c99_logb(x);
2464 #elif defined(c99_log2) && FLT_RADIX == 2
2465 RETVAL = Perl_floor(c99_log2(PERL_ABS(x)));
2471 #ifdef c99_nearbyint
2472 RETVAL = c99_nearbyint(x);
2474 not_here("nearbyint");
2479 RETVAL = c99_rint(x);
2486 RETVAL = c99_round(x);
2492 RETVAL = Perl_sinh(x); /* C89 math */
2495 RETVAL = Perl_tan(x); /* C89 math */
2498 RETVAL = Perl_tanh(x); /* C89 math */
2502 RETVAL = c99_tgamma(x);
2509 RETVAL = c99_trunc(x);
2516 RETVAL = bessel_y0(x);
2524 RETVAL = bessel_y1(x);
2535 #ifdef HAS_FEGETROUND
2536 RETVAL = my_fegetround();
2539 not_here("fegetround");
2548 #ifdef HAS_FEGETROUND /* canary for fesetround */
2549 RETVAL = fesetround(x);
2550 #elif defined(HAS_FPGETROUND) /* canary for fpsetround */
2552 case FE_TONEAREST: RETVAL = fpsetround(FP_RN); break;
2553 case FE_TOWARDZERO: RETVAL = fpsetround(FP_RZ); break;
2554 case FE_DOWNWARD: RETVAL = fpsetround(FP_RM); break;
2555 case FE_UPWARD: RETVAL = fpsetround(FP_RP); break;
2556 default: RETVAL = -1; break;
2558 #elif defined(__osf__) /* Tru64 */
2560 case FE_TONEAREST: RETVAL = write_rnd(FP_RND_RN); break;
2561 case FE_TOWARDZERO: RETVAL = write_rnd(FP_RND_RZ); break;
2562 case FE_DOWNWARD: RETVAL = write_rnd(FP_RND_RM); break;
2563 case FE_UPWARD: RETVAL = write_rnd(FP_RND_RP); break;
2564 default: RETVAL = -1; break;
2569 not_here("fesetround");
2591 #ifdef c99_fpclassify
2592 RETVAL = c99_fpclassify(x);
2594 not_here("fpclassify");
2599 RETVAL = c99_ilogb(x);
2605 RETVAL = Perl_isfinite(x);
2608 RETVAL = Perl_isinf(x);
2611 RETVAL = Perl_isnan(x);
2615 RETVAL = c99_isnormal(x);
2617 not_here("isnormal");
2622 RETVAL = c99_lrint(x);
2629 RETVAL = c99_lround(x);
2637 RETVAL = Perl_signbit(x);
2640 #ifdef DOUBLE_IS_IEEE_FORMAT
2655 #ifdef DOUBLE_HAS_NAN
2656 RETVAL = S_getpayload(nv);
2658 PERL_UNUSED_VAR(nv);
2659 not_here("getpayload");
2665 setpayload(nv, payload)
2669 #ifdef DOUBLE_HAS_NAN
2670 S_setpayload(&nv, payload, FALSE);
2672 PERL_UNUSED_VAR(nv);
2673 PERL_UNUSED_VAR(payload);
2674 not_here("setpayload");
2680 setpayloadsig(nv, payload)
2684 #ifdef DOUBLE_HAS_NAN
2686 S_setpayload(&nv, payload, TRUE);
2688 PERL_UNUSED_VAR(nv);
2689 PERL_UNUSED_VAR(payload);
2690 not_here("setpayloadsig");
2699 #ifdef DOUBLE_HAS_NAN
2700 RETVAL = Perl_isnan(nv) && NV_NAN_IS_SIGNALING(&nv);
2702 PERL_UNUSED_VAR(nv);
2703 not_here("issignaling");
2738 RETVAL = c99_copysign(x, y);
2740 not_here("copysign");
2745 RETVAL = c99_fdim(x, y);
2752 RETVAL = c99_fmax(x, y);
2759 RETVAL = c99_fmin(x, y);
2765 RETVAL = Perl_fmod(x, y); /* C89 math */
2769 RETVAL = c99_hypot(x, y);
2775 #ifdef c99_isgreater
2776 RETVAL = c99_isgreater(x, y);
2778 not_here("isgreater");
2782 #ifdef c99_isgreaterequal
2783 RETVAL = c99_isgreaterequal(x, y);
2785 not_here("isgreaterequal");
2790 RETVAL = c99_isless(x, y);
2796 #ifdef c99_islessequal
2797 RETVAL = c99_islessequal(x, y);
2799 not_here("islessequal");
2803 #ifdef c99_islessgreater
2804 RETVAL = c99_islessgreater(x, y);
2806 not_here("islessgreater");
2810 #ifdef c99_isunordered
2811 RETVAL = c99_isunordered(x, y);
2813 not_here("isunordered");
2817 #ifdef c99_nextafter
2818 RETVAL = c99_nextafter(x, y);
2820 not_here("nextafter");
2824 #ifdef c99_nexttoward
2825 RETVAL = c99_nexttoward(x, y);
2827 not_here("nexttoward");
2832 #ifdef c99_remainder
2833 RETVAL = c99_remainder(x, y);
2835 not_here("remainder");
2847 /* (We already know stack is long enough.) */
2848 PUSHs(sv_2mortal(newSVnv(Perl_frexp(x,&expvar)))); /* C89 math */
2849 PUSHs(sv_2mortal(newSViv(expvar)));
2861 /* (We already know stack is long enough.) */
2862 PUSHs(sv_2mortal(newSVnv(Perl_modf(x,&intvar)))); /* C89 math */
2863 PUSHs(sv_2mortal(newSVnv(intvar)));
2872 PUSHs(sv_2mortal(newSVnv(c99_remquo(x,y,&intvar))));
2873 PUSHs(sv_2mortal(newSVnv(intvar)));
2886 RETVAL = c99_scalbn(x, y);
2903 RETVAL = c99_fma(x, y, z);
2918 /* If no payload given, just return the default NaN.
2919 * This makes a difference in platforms where the default
2920 * NaN is not all zeros. */
2924 S_setpayload(&RETVAL, payload, FALSE);
2926 #elif defined(c99_nan)
2928 STRLEN elen = my_snprintf(PL_efloatbuf, PL_efloatsize, "%g", payload);
2929 if ((IV)elen == -1) {
2936 RETVAL = c99_nan(PL_efloatbuf);
2960 RETVAL = bessel_jn(x, y);
2970 RETVAL = bessel_yn(x, y);
2982 sigaction(sig, optaction, oldaction = 0)
2985 POSIX::SigAction oldaction
2987 #if defined(WIN32) || defined(NETWARE) || (defined(__amigaos4__) && defined(__NEWLIB__))
2988 RETVAL = not_here("sigaction");
2990 # This code is really grody because we are trying to make the signal
2991 # interface look beautiful, which is hard.
2995 POSIX__SigAction action;
2996 GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV);
2997 struct sigaction act;
2998 struct sigaction oact;
3002 POSIX__SigSet sigset;
3007 croak("Negative signals are not allowed");
3010 if (sig == 0 && SvPOK(ST(0))) {
3011 const char *s = SvPVX_const(ST(0));
3012 int i = whichsig(s);
3014 if (i < 0 && _memEQs(s, "SIG"))
3015 i = whichsig(s + 3);
3017 if (ckWARN(WARN_SIGNAL))
3018 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
3019 "No such signal: SIG%s", s);
3026 if (sig > NSIG) { /* NSIG - 1 is still okay. */
3027 Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
3028 "No such signal: %d", sig);
3032 sigsvp = hv_fetch(GvHVn(siggv),
3034 strlen(PL_sig_name[sig]),
3037 /* Check optaction and set action */
3038 if(SvTRUE(optaction)) {
3039 if(sv_isa(optaction, "POSIX::SigAction"))
3040 action = (HV*)SvRV(optaction);
3042 croak("action is not of type POSIX::SigAction");
3048 /* sigaction() is supposed to look atomic. In particular, any
3049 * signal handler invoked during a sigaction() call should
3050 * see either the old or the new disposition, and not something
3051 * in between. We use sigprocmask() to make it so.
3054 RETVAL=sigprocmask(SIG_BLOCK, &sset, &osset);
3058 /* Restore signal mask no matter how we exit this block. */
3059 osset_sv = newSVpvn((char *)(&osset), sizeof(sigset_t));
3060 SAVEFREESV( osset_sv );
3061 SAVEDESTRUCTOR_X(restore_sigmask, osset_sv);
3063 RETVAL=-1; /* In case both oldaction and action are 0. */
3065 /* Remember old disposition if desired. */
3067 svp = hv_fetchs(oldaction, "HANDLER", TRUE);
3069 croak("Can't supply an oldaction without a HANDLER");
3070 if(SvTRUE(*sigsvp)) { /* TBD: what if "0"? */
3071 sv_setsv(*svp, *sigsvp);
3074 sv_setpvs(*svp, "DEFAULT");
3076 RETVAL = sigaction(sig, (struct sigaction *)0, & oact);
3081 /* Get back the mask. */
3082 svp = hv_fetchs(oldaction, "MASK", TRUE);
3083 if (sv_isa(*svp, "POSIX::SigSet")) {
3084 sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
3087 sigset = (sigset_t *) allocate_struct(aTHX_ *svp,
3091 *sigset = oact.sa_mask;
3093 /* Get back the flags. */
3094 svp = hv_fetchs(oldaction, "FLAGS", TRUE);
3095 sv_setiv(*svp, oact.sa_flags);
3097 /* Get back whether the old handler used safe signals. */
3098 svp = hv_fetchs(oldaction, "SAFE", TRUE);
3100 /* compare incompatible pointers by casting to integer */
3101 PTR2nat(oact.sa_handler) == PTR2nat(PL_csighandlerp));
3105 /* Safe signals use "csighandler", which vectors through the
3106 PL_sighandlerp pointer when it's safe to do so.
3107 (BTW, "csighandler" is very different from "sighandler".) */
3108 svp = hv_fetchs(action, "SAFE", FALSE);
3112 (*svp && SvTRUE(*svp))
3113 ? PL_csighandlerp : PL_sighandlerp
3116 /* Vector new Perl handler through %SIG.
3117 (The core signal handlers read %SIG to dispatch.) */
3118 svp = hv_fetchs(action, "HANDLER", FALSE);
3120 croak("Can't supply an action without a HANDLER");
3121 sv_setsv(*sigsvp, *svp);
3123 /* This call actually calls sigaction() with almost the
3124 right settings, including appropriate interpretation
3125 of DEFAULT and IGNORE. However, why are we doing
3126 this when we're about to do it again just below? XXX */
3127 SvSETMAGIC(*sigsvp);
3129 /* And here again we duplicate -- DEFAULT/IGNORE checking. */
3131 const char *s=SvPVX_const(*svp);
3132 if(strEQ(s,"IGNORE")) {
3133 act.sa_handler = SIG_IGN;
3135 else if(strEQ(s,"DEFAULT")) {
3136 act.sa_handler = SIG_DFL;
3140 /* Set up any desired mask. */
3141 svp = hv_fetchs(action, "MASK", FALSE);
3142 if (svp && sv_isa(*svp, "POSIX::SigSet")) {
3143 sigset = (sigset_t *) SvPV_nolen(SvRV(*svp));
3144 act.sa_mask = *sigset;
3147 sigemptyset(& act.sa_mask);
3149 /* Set up any desired flags. */
3150 svp = hv_fetchs(action, "FLAGS", FALSE);
3151 act.sa_flags = svp ? SvIV(*svp) : 0;
3153 /* Don't worry about cleaning up *sigsvp if this fails,
3154 * because that means we tried to disposition a
3155 * nonblockable signal, in which case *sigsvp is
3156 * essentially meaningless anyway.
3158 RETVAL = sigaction(sig, & act, (struct sigaction *)0);
3173 POSIX::SigSet sigset
3178 RETVAL = not_here("sigpending");
3180 RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
3188 sigprocmask(how, sigset, oldsigset = 0)
3190 POSIX::SigSet sigset = NO_INIT
3191 POSIX::SigSet oldsigset = NO_INIT
3193 if (! SvOK(ST(1))) {
3195 } else if (sv_isa(ST(1), "POSIX::SigSet")) {
3196 sigset = (sigset_t *) SvPV_nolen(SvRV(ST(1)));
3198 croak("sigset is not of type POSIX::SigSet");
3201 if (items < 3 || ! SvOK(ST(2))) {
3203 } else if (sv_isa(ST(2), "POSIX::SigSet")) {
3204 oldsigset = (sigset_t *) SvPV_nolen(SvRV(ST(2)));
3206 croak("oldsigset is not of type POSIX::SigSet");
3218 if (fd1 >= 0 && fd2 >= 0) {
3220 /* RT #98912 - More Microsoft muppetry - failing to
3221 actually implemented the well known documented POSIX
3222 behaviour for a POSIX API.
3223 http://msdn.microsoft.com/en-us/library/8syseb29.aspx */
3224 RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2;
3226 RETVAL = dup2(fd1, fd2);
3229 SETERRNO(EBADF,RMS_IFI);
3236 lseek(fd, offset, whence)
3242 Off_t pos = PerlLIO_lseek(fd, offset, whence);
3243 RETVAL = sizeof(Off_t) > sizeof(IV)
3244 ? newSVnv((NV)pos) : newSViv((IV)pos);
3254 if ((incr = nice(incr)) != -1 || errno == 0) {
3256 XPUSHs(newSVpvs_flags("0 but true", SVs_TEMP));
3258 XPUSHs(sv_2mortal(newSViv(incr)));
3265 if (pipe(fds) != -1) {
3267 PUSHs(sv_2mortal(newSViv(fds[0])));
3268 PUSHs(sv_2mortal(newSViv(fds[1])));
3272 read(fd, buffer, nbytes)
3274 SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
3278 char * buffer = sv_grow( sv_buffer, nbytes+1 );
3281 SvCUR_set(sv_buffer, RETVAL);
3282 SvPOK_only(sv_buffer);
3283 *SvEND(sv_buffer) = '\0';
3284 SvTAINTED_on(sv_buffer);
3300 tcsetpgrp(fd, pgrp_id)
3309 if (uname(&buf) >= 0) {
3311 PUSHs(newSVpvn_flags(buf.sysname, strlen(buf.sysname), SVs_TEMP));
3312 PUSHs(newSVpvn_flags(buf.nodename, strlen(buf.nodename), SVs_TEMP));
3313 PUSHs(newSVpvn_flags(buf.release, strlen(buf.release), SVs_TEMP));
3314 PUSHs(newSVpvn_flags(buf.version, strlen(buf.version), SVs_TEMP));
3315 PUSHs(newSVpvn_flags(buf.machine, strlen(buf.machine), SVs_TEMP));
3318 uname((char *) 0); /* A stub to call not_here(). */
3322 write(fd, buffer, nbytes)
3336 mbstowcs(s, pwcs, n)
3348 wcstombs(s, pwcs, n)
3370 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3371 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
3372 num = strtod(str, &unparsed);
3373 PUSHs(sv_2mortal(newSVnv(num)));
3374 if (GIMME_V == G_ARRAY) {
3377 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3379 PUSHs(&PL_sv_undef);
3381 RESTORE_LC_NUMERIC_STANDARD();
3392 DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
3393 STORE_LC_NUMERIC_FORCE_TO_UNDERLYING();
3394 num = strtold(str, &unparsed);
3395 PUSHs(sv_2mortal(newSVnv(num)));
3396 if (GIMME_V == G_ARRAY) {
3399 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3401 PUSHs(&PL_sv_undef);
3403 RESTORE_LC_NUMERIC_STANDARD();
3408 strtol(str, base = 0)
3415 if (base == 0 || (base >= 2 && base <= 36)) {
3416 num = strtol(str, &unparsed, base);
3417 #if IVSIZE < LONGSIZE
3418 if (num < IV_MIN || num > IV_MAX)
3419 PUSHs(sv_2mortal(newSVnv((double)num)));
3422 PUSHs(sv_2mortal(newSViv((IV)num)));
3423 if (GIMME_V == G_ARRAY) {
3426 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3428 PUSHs(&PL_sv_undef);
3431 SETERRNO(EINVAL, LIB_INVARG);
3432 PUSHs(&PL_sv_undef);
3433 if (GIMME_V == G_ARRAY) {
3435 PUSHs(&PL_sv_undef);
3440 strtoul(str, base = 0)
3447 PERL_UNUSED_VAR(str);
3448 PERL_UNUSED_VAR(base);
3449 if (base == 0 || (base >= 2 && base <= 36)) {
3450 num = strtoul(str, &unparsed, base);
3451 #if IVSIZE <= LONGSIZE
3453 PUSHs(sv_2mortal(newSVnv((double)num)));
3456 PUSHs(sv_2mortal(newSViv((IV)num)));
3457 if (GIMME_V == G_ARRAY) {
3460 PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
3462 PUSHs(&PL_sv_undef);
3465 SETERRNO(EINVAL, LIB_INVARG);
3466 PUSHs(&PL_sv_undef);
3467 if (GIMME_V == G_ARRAY) {
3469 PUSHs(&PL_sv_undef);
3481 char *p = SvPV(src,srclen);
3483 buflen = srclen * 4 + 1;
3484 ST(0) = sv_2mortal(newSV(buflen));
3485 dstlen = strxfrm(SvPVX(ST(0)), p, (size_t)buflen);
3486 if (dstlen >= buflen) {
3488 SvGROW(ST(0), dstlen);
3489 strxfrm(SvPVX(ST(0)), p, (size_t)dstlen);
3492 SvCUR_set(ST(0), dstlen);
3497 mkfifo(filename, mode)
3504 RETVAL = access(filename, mode);
3506 TAINT_PROPER("mkfifo");
3507 RETVAL = mkfifo(filename, mode);
3520 RETVAL = ix == 1 ? close(fd)
3521 : (ix < 1 ? tcdrain(fd) : dup(fd));
3523 SETERRNO(EBADF,RMS_IFI);
3539 RETVAL = ix == 1 ? tcflush(fd, action)
3540 : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action));
3542 SETERRNO(EINVAL,LIB_INVARG);
3549 asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1)
3565 init_tm(&mytm); /* XXX workaround - see init_tm() in core util.c */
3568 mytm.tm_hour = hour;
3569 mytm.tm_mday = mday;
3571 mytm.tm_year = year;
3572 mytm.tm_wday = wday;
3573 mytm.tm_yday = yday;
3574 mytm.tm_isdst = isdst;
3576 const time_t result = mktime(&mytm);
3577 if (result == (time_t)-1)
3579 else if (result == 0)
3580 sv_setpvs(TARG, "0 but true");
3582 sv_setiv(TARG, (IV)result);
3584 sv_setpv(TARG, asctime(&mytm));
3602 realtime = times( &tms );
3604 PUSHs( sv_2mortal( newSViv( (IV) realtime ) ) );
3605 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_utime ) ) );
3606 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_stime ) ) );
3607 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cutime ) ) );
3608 PUSHs( sv_2mortal( newSViv( (IV) tms.tms_cstime ) ) );
3611 difftime(time1, time2)
3615 #XXX: if $xsubpp::WantOptimize is always the default
3616 # sv_setpv(TARG, ...) could be used rather than
3617 # ST(0) = sv_2mortal(newSVpv(...))
3619 strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1)
3635 /* allowing user-supplied (rather than literal) formats
3636 * is normally frowned upon as a potential security risk;
3637 * but this is part of the API so we have to allow it */
3638 GCC_DIAG_IGNORE(-Wformat-nonliteral);
3639 buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst);
3641 sv = sv_newmortal();
3643 STRLEN len = strlen(buf);
3644 sv_usepvn_flags(sv, buf, len, SV_HAS_TRAILING_NUL);
3646 || (! is_utf8_invariant_string((U8*) buf, len)
3647 && is_utf8_string((U8*) buf, len)
3648 #ifdef USE_LOCALE_TIME
3649 && _is_cur_LC_category_utf8(LC_TIME)
3655 else { /* We can't distinguish between errors and just an empty
3656 * return; in all cases just return an empty string */
3657 SvUPGRADE(sv, SVt_PV);
3658 SvPV_set(sv, (char *) "");
3661 SvLEN_set(sv, 0); /* Won't attempt to free the string when sv
3676 PUSHs(newSVpvn_flags(tzname[0], strlen(tzname[0]), SVs_TEMP));
3677 PUSHs(newSVpvn_flags(tzname[1], strlen(tzname[1]), SVs_TEMP));
3683 #ifdef HAS_CTERMID_R
3684 s = (char *) safemalloc((size_t) L_ctermid);
3686 RETVAL = ctermid(s);
3690 #ifdef HAS_CTERMID_R
3699 RETVAL = cuserid(s);
3703 not_here("cuserid");
3714 pathconf(filename, name)
3725 unsigned int seconds
3727 RETVAL = PerlProc_sleep(seconds);
3753 XSprePUSH; PUSHTARG;
3757 lchown(uid, gid, path)
3763 /* yes, the order of arguments is different,
3764 * but consistent with CORE::chown() */
3765 RETVAL = lchown(path, uid, gid);
3767 PERL_UNUSED_VAR(uid);
3768 PERL_UNUSED_VAR(gid);
3769 PERL_UNUSED_VAR(path);
3770 RETVAL = not_here("lchown");
https://perl5.git.perl.org / perl5.git / blob