X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7678a27f4952a056585a8a498c06ed926556563b..7d5966ae3c3b8f0e43fa09554a46cb8de9c98f5f:/ext/POSIX/POSIX.xs diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 8a985bc..1dbcd07 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -1,4 +1,5 @@ #define PERL_EXT_POSIX +#define PERL_EXT #ifdef NETWARE #define _POSIX_ @@ -17,6 +18,9 @@ #define PERLIO_NOT_STDIO 1 #include "perl.h" #include "XSUB.h" + +static int not_here(const char *s); + #if defined(PERL_IMPLICIT_SYS) # undef signal # undef open @@ -31,15 +35,13 @@ #ifdef WIN32 #include #endif -#ifdef I_FLOAT #include -#endif #ifdef I_FENV +#if !(defined(__vax__) && defined(__NetBSD__)) #include #endif -#ifdef I_LIMITS -#include #endif +#include #include #include #ifdef I_PWD @@ -48,15 +50,20 @@ #include #include #include - -#ifdef I_STDDEF #include -#endif #ifdef I_UNISTD #include #endif +#ifdef I_SYS_TIME +# include +#endif + +#ifdef I_SYS_RESOURCE +# include +#endif + #if defined(USE_QUADMATH) && defined(I_QUADMATH) # undef M_E @@ -89,44 +96,63 @@ #else +# ifdef USE_LONG_DOUBLE +# undef M_E +# undef M_LOG2E +# undef M_LOG10E +# undef M_LN2 +# undef M_LN10 +# undef M_PI +# undef M_PI_2 +# undef M_PI_4 +# undef M_1_PI +# undef M_2_PI +# undef M_2_SQRTPI +# undef M_SQRT2 +# undef M_SQRT1_2 +# define FLOAT_C(c) CAT2(c,L) +# else +# define FLOAT_C(c) (c) +# endif + # ifndef M_E -# define M_E 2.71828182845904523536028747135266250 +# define M_E FLOAT_C(2.71828182845904523536028747135266250) # endif # ifndef M_LOG2E -# define M_LOG2E 1.44269504088896340735992468100189214 +# define M_LOG2E FLOAT_C(1.44269504088896340735992468100189214) # endif # ifndef M_LOG10E -# define M_LOG10E 0.434294481903251827651128918916605082 +# define M_LOG10E FLOAT_C(0.434294481903251827651128918916605082) # endif # ifndef M_LN2 -# define M_LN2 0.693147180559945309417232121458176568 +# define M_LN2 FLOAT_C(0.693147180559945309417232121458176568) # endif # ifndef M_LN10 -# define M_LN10 2.30258509299404568401799145468436421 +# define M_LN10 FLOAT_C(2.30258509299404568401799145468436421) # endif # ifndef M_PI -# define M_PI 3.14159265358979323846264338327950288 +# define M_PI FLOAT_C(3.14159265358979323846264338327950288) # endif # ifndef M_PI_2 -# define M_PI_2 1.57079632679489661923132169163975144 +# define M_PI_2 FLOAT_C(1.57079632679489661923132169163975144) # endif # ifndef M_PI_4 -# define M_PI_4 0.785398163397448309615660845819875721 +# define M_PI_4 FLOAT_C(0.785398163397448309615660845819875721) # endif # ifndef M_1_PI -# define M_1_PI 0.318309886183790671537767526745028724 +# define M_1_PI FLOAT_C(0.318309886183790671537767526745028724) # endif # ifndef M_2_PI -# define M_2_PI 0.636619772367581343075535053490057448 +# define M_2_PI FLOAT_C(0.636619772367581343075535053490057448) # endif # ifndef M_2_SQRTPI -# define M_2_SQRTPI 1.12837916709551257389615890312154517 +# define M_2_SQRTPI FLOAT_C(1.12837916709551257389615890312154517) # endif # ifndef M_SQRT2 -# define M_SQRT2 1.41421356237309504880168872420969808 +# define M_SQRT2 FLOAT_C(1.41421356237309504880168872420969808) # endif # ifndef M_SQRT1_2 -# define M_SQRT1_2 0.707106781186547524400844362104849039 +# define M_SQRT1_2 FLOAT_C(0.707106781186547524400844362104849039) # endif #endif @@ -231,10 +257,13 @@ # define c99_log1p log1pq # define c99_log2 log2q /* no logbq */ -/* no llrintq */ -/* no llroundq */ -# define c99_lrint lrintq -# define c99_lround lroundq +# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG +# define c99_lrint llrintq +# define c99_lround llroundq +# else +# define c99_lrint lrintq +# define c99_lround lroundq +# endif # define c99_nan nanq # define c99_nearbyint nearbyintq # define c99_nextafter nextafterq @@ -276,14 +305,14 @@ # define c99_log1p log1pl # define c99_log2 log2l # define c99_logb logbl -# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG -# define c99_lrint llrintl -# else +# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLRINTL) +# define c99_lrint llrintl +# elif defined(HAS_LRINTL) # define c99_lrint lrintl # endif -# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG +# if defined(USE_64_BIT_INT) && QUADKIND == QUAD_IS_LONG_LONG && defined(HAS_LLROUNDL) # define c99_lround llroundl -# else +# elif defined(HAS_LROUNDL) # define c99_lround lroundl # endif # define c99_nan nanl @@ -347,6 +376,45 @@ # define c99_trunc trunc #endif +/* AIX xlc (__IBMC__) really doesn't have the following long double + * math interfaces (no __acoshl128 aka acoshl, etc.), see + * hints/aix.sh. These are in the -lc128 but fail to be found + * during dynamic linking/loading. + * + * XXX1 Better Configure scans + * XXX2 Is this xlc version dependent? */ +#if defined(USE_LONG_DOUBLE) && defined(__IBMC__) +# undef c99_acosh +# undef c99_asinh +# undef c99_atanh +# undef c99_cbrt +# undef c99_copysign +# undef c99_exp2 +# undef c99_expm1 +# undef c99_fdim +# undef c99_fma +# undef c99_fmax +# undef c99_fmin +# undef c99_hypot +# undef c99_ilogb +# undef c99_lrint +# undef c99_lround +# undef c99_log1p +# undef c99_log2 +# undef c99_logb +# undef c99_nan +# undef c99_nearbyint +# undef c99_nextafter +# undef c99_nexttoward +# undef c99_remainder +# undef c99_remquo +# undef c99_rint +# undef c99_round +# undef c99_scalbn +# undef c99_tgamma +# undef c99_trunc +#endif + #ifndef isunordered # ifdef Perl_isnan # define isunordered(x, y) (Perl_isnan(x) || Perl_isnan(y)) @@ -643,7 +711,11 @@ static NV my_expm1(NV x) #ifndef c99_fdim static NV my_fdim(NV x, NV y) { +#ifdef NV_NAN return (Perl_isnan(x) || Perl_isnan(y)) ? NV_NAN : (x > y ? x - y : 0); +#else + return (x > y ? x - y : 0); +#endif } # define c99_fdim my_fdim #endif @@ -659,11 +731,13 @@ static NV my_fma(NV x, NV y, NV z) #ifndef c99_fmax static NV my_fmax(NV x, NV y) { +#ifdef NV_NAN if (Perl_isnan(x)) { return Perl_isnan(y) ? NV_NAN : y; } else if (Perl_isnan(y)) { return x; } +#endif return x > y ? x : y; } # define c99_fmax my_fmax @@ -672,11 +746,13 @@ static NV my_fmax(NV x, NV y) #ifndef c99_fmin static NV my_fmin(NV x, NV y) { +#ifdef NV_NAN if (Perl_isnan(x)) { return Perl_isnan(y) ? NV_NAN : y; } else if (Perl_isnan(y)) { return x; } +#endif return x < y ? x : y; } # define c99_fmin my_fmin @@ -707,8 +783,10 @@ static NV my_hypot(NV x, NV y) x = PERL_ABS(x); /* Take absolute values. */ if (y == 0) return x; +#ifdef NV_INF if (Perl_isnan(y)) return NV_INF; +#endif y = PERL_ABS(y); if (x < y) { /* Swap so that y is less. */ t = x; @@ -729,27 +807,44 @@ static IV my_ilogb(NV x) # define c99_ilogb my_ilogb #endif -/* tgamma and lgamma emulations based on http://www.johndcook.com/cpp_gamma.html, +/* tgamma and lgamma emulations based on + * http://www.johndcook.com/cpp_gamma.html, * code placed in public domain. * * Note that these implementations (neither the johndcook originals * nor these) do NOT set the global signgam variable. This is not * necessarily a bad thing. */ -/* Note that tgamma() and lgamma() depend on each other. */ -#if !defined(c99_tgamma) || !defined(c99_lgamma) +/* Note that the tgamma() and lgamma() implementations + * here depend on each other. */ + +#if !defined(HAS_TGAMMA) || !defined(c99_tgamma) static NV my_tgamma(NV x); +# define c99_tgamma my_tgamma +# define USE_MY_TGAMMA +#endif +#if !defined(HAS_LGAMMA) || !defined(c99_lgamma) static NV my_lgamma(NV x); +# define c99_lgamma my_lgamma +# define USE_MY_LGAMMA #endif -#if !defined(c99_tgamma) || !defined(c99_lgamma) +#ifdef USE_MY_TGAMMA static NV my_tgamma(NV x) { const NV gamma = 0.577215664901532860606512090; /* Euler's gamma constant. */ +#ifdef NV_NAN if (Perl_isnan(x) || x < 0.0) return NV_NAN; +#endif +#ifdef NV_INF if (x == 0.0 || x == NV_INF) +#ifdef DOUBLE_IS_IEEE_FORMAT return x == -0.0 ? -NV_INF : NV_INF; +#else + return NV_INF; +#endif +#endif /* The function domain is split into three intervals: * (0, 0.001), [0.001, 12), and (12, infinity) */ @@ -796,7 +891,7 @@ static NV my_tgamma(NV x) if (x < 1.0) y += 1.0; else { - n = Perl_floor(y) - 1; + n = (int)Perl_floor(y) - 1; y -= n; } z = y - 1; @@ -821,29 +916,38 @@ static NV my_tgamma(NV x) return result; } +#ifdef NV_INF /* Third interval: [12, +Inf) */ - if (x > 171.624) { /* XXX Too low for quad precision */ +#if LDBL_MANT_DIG == 113 /* IEEE quad prec */ + if (x > 1755.548) { + return NV_INF; + } +#else + if (x > 171.624) { return NV_INF; } +#endif +#endif - return Perl_exp(my_lgamma(x)); + return Perl_exp(c99_lgamma(x)); } -# ifndef c99_tgamma -# define c99_tgamma my_tgamma -# endif #endif -#if !defined(c99_lgamma) || !defined(c99_tgamma) +#ifdef USE_MY_LGAMMA static NV my_lgamma(NV x) { +#ifdef NV_NAN if (Perl_isnan(x)) return NV_NAN; +#endif +#ifdef NV_INF if (x <= 0 || x == NV_INF) return NV_INF; +#endif if (x == 1.0 || x == 2.0) return 0; if (x < 12.0) - return Perl_log(PERL_ABS(my_tgamma(x))); + return Perl_log(PERL_ABS(c99_tgamma(x))); /* Abramowitz and Stegun 6.1.41 * Asymptotic series should be good to at least 11 or 12 figures * For error analysis, see Whittiker and Watson @@ -873,9 +977,6 @@ static NV my_lgamma(NV x) return (x - 0.5) * Perl_log(x) - x + half_log_of_two_pi + series; } } -# ifndef c99_lgamma -# define c99_lgamma my_lgamma -# endif #endif #ifndef c99_log1p @@ -883,10 +984,14 @@ static NV my_log1p(NV x) { /* http://www.johndcook.com/cpp_log_one_plus_x.html -- public domain. * Taylor series, the first four terms (the last term quartic). */ +#ifdef NV_NAN if (x < -1.0) return NV_NAN; +#endif +#ifdef NV_INF if (x == -1.0) return -NV_INF; +#endif if (PERL_ABS(x) > 1e-4) return Perl_log(1.0 + x); else @@ -962,7 +1067,7 @@ static NV my_rint(NV x) case FE_TOWARDZERO: return MY_ROUND_TRUNC(x); case FE_DOWNWARD: return MY_ROUND_DOWN(x); case FE_UPWARD: return MY_ROUND_UP(x); - default: return NV_NAN; + default: break; } #elif defined(HAS_FPGETROUND) switch (fpgetround()) { @@ -970,11 +1075,10 @@ static NV my_rint(NV x) case FP_RZ: return MY_ROUND_TRUNC(x); case FP_RM: return MY_ROUND_DOWN(x); case FE_RP: return MY_ROUND_UP(x); - default: return NV_NAN; + default: break; } -#else - return NV_NAN; #endif + not_here("rint"); } #endif @@ -1048,6 +1152,177 @@ static NV my_trunc(NV x) # define c99_trunc my_trunc #endif +#ifdef NV_NAN + +#undef NV_PAYLOAD_DEBUG + +/* NOTE: the NaN payload API implementation is hand-rolled, since the + * APIs are only proposed ones as of June 2015, so very few, if any, + * platforms have implementations yet, so HAS_SETPAYLOAD and such are + * unlikely to be helpful. + * + * XXX - if the core numification wants to actually generate + * the nan payload in "nan(123)", and maybe "nans(456)", for + * signaling payload", this needs to be moved to e.g. numeric.c + * (look for grok_infnan) + * + * Conversely, if the core stringification wants the nan payload + * and/or the nan quiet/signaling distinction, S_getpayload() + * from this file needs to be moved, to e.g. sv.c (look for S_infnan_2pv), + * and the (trivial) functionality of issignaling() copied + * (for generating "NaNS", or maybe even "NaNQ") -- or maybe there + * are too many formatting parameters for simple stringification? + */ + +/* While it might make sense for the payload to be UV or IV, + * to avoid conversion loss, the proposed ISO interfaces use + * a floating point input, which is then truncated to integer, + * and only the integer part being used. This is workable, + * except for: (1) the conversion loss (2) suboptimal for + * 32-bit integer platforms. A workaround API for (2) and + * in general for bit-honesty would be an array of integers + * as the payload... but the proposed C API does nothing of + * the kind. */ +#if NVSIZE == UVSIZE +# define NV_PAYLOAD_TYPE UV +#else +# define NV_PAYLOAD_TYPE NV +#endif + +#if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE) +# define NV_PAYLOAD_SIZEOF_ASSERT(a) \ + STATIC_ASSERT_STMT(sizeof(a) == NVSIZE / 2) +#else +# define NV_PAYLOAD_SIZEOF_ASSERT(a) \ + STATIC_ASSERT_STMT(sizeof(a) == NVSIZE) +#endif + +static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling) +{ + dTHX; + static const U8 m[] = { NV_NAN_PAYLOAD_MASK }; + static const U8 p[] = { NV_NAN_PAYLOAD_PERM }; + UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 }; + int i; + NV_PAYLOAD_SIZEOF_ASSERT(m); + NV_PAYLOAD_SIZEOF_ASSERT(p); + *nvp = NV_NAN; + /* Divide the input into the array in "base unsigned integer" in + * little-endian order. Note that the integer might be smaller than + * an NV (if UV is U32, for example). */ +#if NVSIZE == UVSIZE + a[0] = payload; /* The trivial case. */ +#else + { + NV t1 = c99_trunc(payload); /* towards zero (drop fractional) */ +#ifdef NV_PAYLOAD_DEBUG + Perl_warn(aTHX_ "t1 = %" NVgf " (payload %" NVgf ")\n", t1, payload); +#endif + if (t1 <= UV_MAX) { + a[0] = (UV)t1; /* Fast path, also avoids rounding errors (right?) */ + } else { + /* UVSIZE < NVSIZE or payload > UV_MAX. + * + * This may happen for example if: + * (1) UVSIZE == 32 and common 64-bit double NV + * (32-bit system not using -Duse64bitint) + * (2) UVSIZE == 64 and the x86-style 80-bit long double NV + * (note that here the room for payload is actually the 64 bits) + * (3) UVSIZE == 64 and the 128-bit IEEE 764 quadruple NV + * (112 bits in mantissa, 111 bits room for payload) + * + * NOTE: this is very sensitive to correctly functioning + * fmod()/fmodl(), and correct casting of big-unsigned-integer to NV. + * If these don't work right, especially the low order bits + * are in danger. For example Solaris and AIX seem to have issues + * here, especially if using 32-bit UVs. */ + NV t2; + for (i = 0, t2 = t1; i < (int)C_ARRAY_LENGTH(a); i++) { + a[i] = (UV)Perl_fmod(t2, (NV)UV_MAX); + t2 = Perl_floor(t2 / (NV)UV_MAX); + } + } + } +#endif +#ifdef NV_PAYLOAD_DEBUG + for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) { + Perl_warn(aTHX_ "a[%d] = 0x%" UVxf "\n", i, a[i]); + } +#endif + for (i = 0; i < (int)sizeof(p); i++) { + if (m[i] && p[i] < sizeof(p)) { + U8 s = (p[i] % UVSIZE) << 3; + UV u = a[p[i] / UVSIZE] & ((UV)0xFF << s); + U8 b = (U8)((u >> s) & m[i]); + ((U8 *)(nvp))[i] &= ~m[i]; /* For NaNs with non-zero payload bits. */ + ((U8 *)(nvp))[i] |= b; +#ifdef NV_PAYLOAD_DEBUG + 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); +#endif + a[p[i] / UVSIZE] &= ~u; + } + } + if (signaling) { + NV_NAN_SET_SIGNALING(nvp); + } +#ifdef USE_LONG_DOUBLE +# if LONG_DOUBLEKIND == 3 || LONG_DOUBLEKIND == 4 +# if LONG_DOUBLESIZE > 10 + memset((char *)nvp + 10, '\0', LONG_DOUBLESIZE - 10); /* x86 long double */ +# endif +# endif +#endif + for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) { + if (a[i]) { + Perl_warn(aTHX_ "payload lost bits (%" UVxf ")", a[i]); + break; + } + } +#ifdef NV_PAYLOAD_DEBUG + for (i = 0; i < NVSIZE; i++) { + PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(nvp))[i]); + } + PerlIO_printf(Perl_debug_log, "\n"); +#endif +} + +static NV_PAYLOAD_TYPE S_getpayload(NV nv) +{ + dTHX; + static const U8 m[] = { NV_NAN_PAYLOAD_MASK }; + static const U8 p[] = { NV_NAN_PAYLOAD_PERM }; + UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 }; + int i; + NV payload; + NV_PAYLOAD_SIZEOF_ASSERT(m); + NV_PAYLOAD_SIZEOF_ASSERT(p); + payload = 0; + for (i = 0; i < (int)sizeof(p); i++) { + if (m[i] && p[i] < NVSIZE) { + U8 s = (p[i] % UVSIZE) << 3; + a[p[i] / UVSIZE] |= (UV)(((U8 *)(&nv))[i] & m[i]) << s; + } + } + for (i = (int)C_ARRAY_LENGTH(a) - 1; i >= 0; i--) { +#ifdef NV_PAYLOAD_DEBUG + Perl_warn(aTHX_ "a[%d] = %" UVxf "\n", i, a[i]); +#endif + payload *= UV_MAX; + payload += a[i]; + } +#ifdef NV_PAYLOAD_DEBUG + for (i = 0; i < NVSIZE; i++) { + PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(&nv))[i]); + } + PerlIO_printf(Perl_debug_log, "\n"); +#endif + return payload; +} + +#endif /* #ifdef NV_NAN */ + /* XXX This comment is just to make I_TERMIO and I_SGTTY visible to metaconfig for future extension writers. We don't use them in POSIX. (This is really sneaky :-) --AD @@ -1055,9 +1330,7 @@ static NV my_trunc(NV x) #if defined(I_TERMIOS) #include #endif -#ifdef I_STDLIB #include -#endif #ifndef __ultrix__ #include #endif @@ -1127,11 +1400,13 @@ char *tzname[] = { "" , "" }; # define setuid(a) not_here("setuid") # define setgid(a) not_here("setgid") #endif /* NETWARE */ +#ifndef USE_LONG_DOUBLE # define strtold(s1,s2) not_here("strtold") +#endif /* USE_LONG_DOUBLE */ #else # ifndef HAS_MKFIFO -# if defined(OS2) +# if defined(OS2) || defined(__amigaos4__) # define mkfifo(a,b) not_here("mkfifo") # else /* !( defined OS2 ) */ # ifndef mkfifo @@ -1147,7 +1422,9 @@ char *tzname[] = { "" , "" }; # ifdef HAS_UNAME # include # endif -# include +# ifndef __amigaos4__ +# include +# endif # ifdef I_UTIME # include # endif @@ -1158,6 +1435,8 @@ typedef int SysRet; typedef long SysRetLong; typedef sigset_t* POSIX__SigSet; typedef HV* POSIX__SigAction; +typedef int POSIX__SigNo; +typedef int POSIX__Fd; #ifdef I_TERMIOS typedef struct termios* POSIX__Termios; #else /* Define termios types to int, and call not_here for the functions.*/ @@ -1291,7 +1570,7 @@ struct lconv_offset { size_t offset; }; -const struct lconv_offset lconv_strings[] = { +static const struct lconv_offset lconv_strings[] = { #ifdef USE_LOCALE_NUMERIC {"decimal_point", STRUCT_OFFSET(struct lconv, decimal_point)}, {"thousands_sep", STRUCT_OFFSET(struct lconv, thousands_sep)}, @@ -1319,18 +1598,18 @@ const struct lconv_offset lconv_strings[] = { /* The Linux man pages say these are the field names for the structure * components that are LC_NUMERIC; the rest being LC_MONETARY */ -# define isLC_NUMERIC_STRING(name) (strcmp(name, "decimal_point") \ - || strcmp(name, "thousands_sep") \ +# define isLC_NUMERIC_STRING(name) ( strEQ(name, "decimal_point") \ + || strEQ(name, "thousands_sep") \ \ /* There should be no harm done \ * checking for this, even if \ * NO_LOCALECONV_GROUPING */ \ - || strcmp(name, "grouping")) + || strEQ(name, "grouping")) #else # define isLC_NUMERIC_STRING(name) (0) #endif -const struct lconv_offset lconv_integers[] = { +static const struct lconv_offset lconv_integers[] = { #ifdef USE_LOCALE_MONETARY {"int_frac_digits", STRUCT_OFFSET(struct lconv, int_frac_digits)}, {"frac_digits", STRUCT_OFFSET(struct lconv, frac_digits)}, @@ -1413,8 +1692,10 @@ restore_sigmask(pTHX_ SV *osset_sv) * supposed to return -1 from sigaction unless the disposition * was unaffected. */ +#if !(defined(__amigaos4__) && defined(__NEWLIB__)) sigset_t *ossetp = (sigset_t *) SvPV_nolen( osset_sv ); (void)sigprocmask(SIG_SETMASK, ossetp, (sigset_t *)0); +#endif } static void * @@ -1422,6 +1703,11 @@ allocate_struct(pTHX_ SV *rv, const STRLEN size, const char *packname) { SV *const t = newSVrv(rv, packname); void *const p = sv_grow(t, size + 1); + /* Ensure at least one use of not_here() to avoid "defined but not + * used" warning. This is not at all related to allocate_struct(); I + * just needed somewhere to dump it - DAPM */ + if (0) { not_here(""); } + SvCUR_set(t, size); SvPOK_on(t); return p; @@ -1506,7 +1792,7 @@ fix_win32_tzenv(void) perl_tz_env = ""; if (crt_tz_env == NULL) crt_tz_env = ""; - if (strcmp(perl_tz_env, crt_tz_env) != 0) { + if (strNE(perl_tz_env, crt_tz_env)) { newenv = (char*)malloc((strlen(perl_tz_env) + 4) * sizeof(char)); if (newenv != NULL) { sprintf(newenv, "TZ=%s", perl_tz_env); @@ -1537,103 +1823,6 @@ my_tzset(pTHX) tzset(); } -typedef int (*isfunc_t)(int); -typedef void (*any_dptr_t)(void *); - -/* This needs to be ALIASed in a custom way, hence can't easily be defined as - a regular XSUB. */ -static XSPROTO(is_common); /* prototype to pass -Wmissing-prototypes */ -static XSPROTO(is_common) -{ - dXSARGS; - - if (items != 1) - croak_xs_usage(cv, "charstring"); - - { - dXSTARG; - STRLEN len; - /*int RETVAL = 0; YYY means uncomment this to return false on an - * empty string input */ - int RETVAL; - unsigned char *s = (unsigned char *) SvPV(ST(0), len); - unsigned char *e = s + len; - isfunc_t isfunc = (isfunc_t) XSANY.any_dptr; - - if (ckWARN_d(WARN_DEPRECATED)) { - - /* Warn exactly once for each lexical place this function is - * called. See thread at - * http://markmail.org/thread/jhqcag5njmx7jpyu */ - - HV *warned = get_hv("POSIX::_warned", GV_ADD | GV_ADDMULTI); - if (! hv_exists(warned, (const char *)&PL_op, sizeof(PL_op))) { - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), - "Calling POSIX::%"HEKf"() is deprecated", - HEKfARG(GvNAME_HEK(CvGV(cv)))); - hv_store(warned, (const char *)&PL_op, sizeof(PL_op), &PL_sv_yes, 0); - } - } - - /*if (e > s) { YYY */ - for (RETVAL = 1; RETVAL && s < e; s++) - if (!isfunc(*s)) - RETVAL = 0; - /*} YYY */ - XSprePUSH; - PUSHi((IV)RETVAL); - } - XSRETURN(1); -} - -MODULE = POSIX PACKAGE = POSIX - -BOOT: -{ - CV *cv; - const char *file = __FILE__; - - - /* silence compiler warning about not_here() defined but not used */ - if (0) not_here(""); - - /* Ensure we get the function, not a macro implementation. Like the C89 - standard says we can... */ -#undef isalnum - cv = newXS("POSIX::isalnum", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isalnum; -#undef isalpha - cv = newXS("POSIX::isalpha", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isalpha; -#undef iscntrl - cv = newXS("POSIX::iscntrl", is_common, file); - XSANY.any_dptr = (any_dptr_t) &iscntrl; -#undef isdigit - cv = newXS("POSIX::isdigit", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isdigit; -#undef isgraph - cv = newXS("POSIX::isgraph", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isgraph; -#undef islower - cv = newXS("POSIX::islower", is_common, file); - XSANY.any_dptr = (any_dptr_t) &islower; -#undef isprint - cv = newXS("POSIX::isprint", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isprint; -#undef ispunct - cv = newXS("POSIX::ispunct", is_common, file); - XSANY.any_dptr = (any_dptr_t) &ispunct; -#undef isspace - cv = newXS("POSIX::isspace", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isspace; -#undef isupper - cv = newXS("POSIX::isupper", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isupper; -#undef isxdigit - cv = newXS("POSIX::isxdigit", is_common, file); - XSANY.any_dptr = (any_dptr_t) &isxdigit; -} - MODULE = SigSet PACKAGE = POSIX::SigSet PREFIX = sig void @@ -1655,7 +1844,7 @@ new(packname = "POSIX::SigSet", ...) SysRet addset(sigset, sig) POSIX::SigSet sigset - int sig + POSIX::SigNo sig ALIAS: delset = 1 CODE: @@ -1676,7 +1865,7 @@ emptyset(sigset) int sigismember(sigset, sig) POSIX::SigSet sigset - int sig + POSIX::SigNo sig MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf @@ -1702,7 +1891,7 @@ new(packname = "POSIX::Termios", ...) SysRet getattr(termios_ref, fd = 0) POSIX::Termios termios_ref - int fd + POSIX::Fd fd CODE: RETVAL = tcgetattr(fd, termios_ref); OUTPUT: @@ -1718,14 +1907,19 @@ getattr(termios_ref, fd = 0) SysRet setattr(termios_ref, fd = 0, optional_actions = DEF_SETATTR_ACTION) POSIX::Termios termios_ref - int fd + POSIX::Fd fd int optional_actions CODE: /* The second argument to the call is mandatory, but we'd like to give it a useful default. 0 isn't valid on all operating systems - on - Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same - values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF. */ - RETVAL = tcsetattr(fd, optional_actions, termios_ref); + Solaris (at least) TCSANOW, TCSADRAIN and TCSAFLUSH have the same + values as the equivalent ioctls, TCSETS, TCSETSW and TCSETSF. */ + if (optional_actions < 0) { + SETERRNO(EINVAL, LIB_INVARG); + RETVAL = -1; + } else { + RETVAL = tcsetattr(fd, optional_actions, termios_ref); + } OUTPUT: RETVAL @@ -1905,7 +2099,7 @@ WEXITSTATUS(status) #endif break; default: - Perl_croak(aTHX_ "Illegal alias %d for POSIX::W*", (int)ix); + croak("Illegal alias %d for POSIX::W*", (int)ix); } OUTPUT: RETVAL @@ -1930,61 +2124,107 @@ localeconv() localeconv(); /* A stub to call not_here(). */ #else struct lconv *lcbuf; +# if defined(USE_ITHREADS) \ + && defined(HAS_POSIX_2008_LOCALE) \ + && defined(HAS_LOCALECONV_L) /* Prefer this thread-safe version */ + bool do_free = FALSE; + locale_t cur = uselocale((locale_t) 0); +# endif + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; /* localeconv() deals with both LC_NUMERIC and LC_MONETARY, but * LC_MONETARY is already in the correct locale */ - STORE_NUMERIC_STANDARD_FORCE_LOCAL(); +# ifdef USE_LOCALE_MONETARY + + const bool is_monetary_utf8 = _is_cur_LC_category_utf8(LC_MONETARY); +# endif +# ifdef USE_LOCALE_NUMERIC + + bool is_numeric_utf8; + + STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); + + is_numeric_utf8 = _is_cur_LC_category_utf8(LC_NUMERIC); +# endif RETVAL = newHV(); sv_2mortal((SV*)RETVAL); - if ((lcbuf = localeconv())) { +# if defined(USE_ITHREADS) \ + && defined(HAS_POSIX_2008_LOCALE) \ + && defined(HAS_LOCALECONV_L) + + if (cur == LC_GLOBAL_LOCALE) { + cur = duplocale(LC_GLOBAL_LOCALE); + do_free = TRUE; + } + + lcbuf = localeconv_l(cur); +# else + LOCALE_LOCK; /* Prevent interference with other threads using + localeconv() */ + + lcbuf = localeconv(); +# endif + if (lcbuf) { const struct lconv_offset *strings = lconv_strings; const struct lconv_offset *integers = lconv_integers; const char *ptr = (const char *) lcbuf; - do { + while (strings->name) { /* This string may be controlled by either LC_NUMERIC, or * LC_MONETARY */ - bool is_utf8_locale -#if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY) - = _is_cur_LC_category_utf8((isLC_NUMERIC_STRING(strings->name)) - ? LC_NUMERIC - : LC_MONETARY); -#elif defined(USE_LOCALE_NUMERIC) - = _is_cur_LC_category_utf8(LC_NUMERIC); -#elif defined(USE_LOCALE_MONETARY) - = _is_cur_LC_category_utf8(LC_MONETARY); -#else - = FALSE; -#endif + const bool is_utf8_locale = +# if defined(USE_LOCALE_NUMERIC) && defined(USE_LOCALE_MONETARY) + (isLC_NUMERIC_STRING(strings->name)) + ? is_numeric_utf8 + : is_monetary_utf8; +# elif defined(USE_LOCALE_NUMERIC) + is_numeric_utf8; +# elif defined(USE_LOCALE_MONETARY) + is_monetary_utf8; +# else + FALSE; +# endif const char *value = *((const char **)(ptr + strings->offset)); if (value && *value) { + const STRLEN value_len = strlen(value); + + /* We mark it as UTF-8 if a utf8 locale and is valid and + * variant under UTF-8 */ + const bool is_utf8 = is_utf8_locale + && is_utf8_non_invariant_string( + (U8*) value, + value_len); (void) hv_store(RETVAL, - strings->name, - strlen(strings->name), - newSVpvn_utf8(value, - strlen(value), - - /* We mark it as UTF-8 if a utf8 locale - * and is valid, non-ascii UTF-8 */ - is_utf8_locale - && ! is_ascii_string((U8 *) value, 0) - && is_utf8_string((U8 *) value, 0)), - 0); - } - } while ((++strings)->name); - - do { + strings->name, + strlen(strings->name), + newSVpvn_utf8(value, value_len, is_utf8), + 0); + } + strings++; + } + + while (integers->name) { const char value = *((const char *)(ptr + integers->offset)); if (value != CHAR_MAX) (void) hv_store(RETVAL, integers->name, strlen(integers->name), newSViv(value), 0); - } while ((++integers)->name); + integers++; + } } - RESTORE_NUMERIC_STANDARD(); +# if defined(USE_ITHREADS) \ + && defined(HAS_POSIX_2008_LOCALE) \ + && defined(HAS_LOCALECONV_L) + if (do_free) { + freelocale(cur); + } +# else + LOCALE_UNLOCK; +# endif + RESTORE_LC_NUMERIC(); #endif /* HAS_LOCALECONV */ OUTPUT: RETVAL @@ -1996,104 +2236,18 @@ setlocale(category, locale = 0) PREINIT: char * retval; CODE: -#ifdef USE_LOCALE_NUMERIC - /* A 0 (or NULL) locale means only query what the current one is. We - * have the LC_NUMERIC name saved, because we are normally switched - * into the C locale for it. Switch back so an LC_ALL query will yield - * the correct results; all other categories don't require special - * handling */ - if (locale == 0) { - if (category == LC_NUMERIC) { - XSRETURN_PV(PL_numeric_name); - } -# ifdef LC_ALL - else if (category == LC_ALL) { - SET_NUMERIC_LOCAL(); - } -# endif - } -#endif -#ifdef WIN32 /* Use wrapper on Windows */ - retval = Perl_my_setlocale(aTHX_ category, locale); -#else - retval = setlocale(category, locale); -#endif - if (! retval) { - /* Should never happen that a query would return an error, but be - * sure and reset to C locale */ - if (locale == 0) { - SET_NUMERIC_STANDARD(); - } + retval = Perl_setlocale(category, locale); + if (! retval) { /* Should never happen that a query would return an + * error, but be sure */ XSRETURN_UNDEF; } - /* Save retval since subsequent setlocale() calls may overwrite it. */ - retval = savepv(retval); + /* Make sure the returned copy gets cleaned up */ + SAVEFREEPV(retval); - /* For locale == 0, we may have switched to NUMERIC_LOCAL. Switch back - * */ - if (locale == 0) { - SET_NUMERIC_STANDARD(); - XSRETURN_PV(retval); - } - else { - RETVAL = retval; -#ifdef USE_LOCALE_CTYPE - if (category == LC_CTYPE -#ifdef LC_ALL - || category == LC_ALL -#endif - ) - { - char *newctype; -#ifdef LC_ALL - if (category == LC_ALL) - newctype = setlocale(LC_CTYPE, NULL); - else -#endif - newctype = RETVAL; - new_ctype(newctype); - } -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - if (category == LC_COLLATE -#ifdef LC_ALL - || category == LC_ALL -#endif - ) - { - char *newcoll; -#ifdef LC_ALL - if (category == LC_ALL) - newcoll = setlocale(LC_COLLATE, NULL); - else -#endif - newcoll = RETVAL; - new_collate(newcoll); - } -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - if (category == LC_NUMERIC -#ifdef LC_ALL - || category == LC_ALL -#endif - ) - { - char *newnum; -#ifdef LC_ALL - if (category == LC_ALL) - newnum = setlocale(LC_NUMERIC, NULL); - else -#endif - newnum = RETVAL; - new_numeric(newnum); - } -#endif /* USE_LOCALE_NUMERIC */ - } + RETVAL = retval; OUTPUT: RETVAL - CLEANUP: - Safefree(RETVAL); NV acos(x) @@ -2130,7 +2284,12 @@ acos(x) y0 = 29 y1 = 30 CODE: + PERL_UNUSED_VAR(x); +#ifdef NV_NAN RETVAL = NV_NAN; +#else + RETVAL = 0; +#endif switch (ix) { case 0: RETVAL = Perl_acos(x); /* C89 math */ @@ -2250,6 +2409,8 @@ acos(x) case 20: #ifdef c99_logb RETVAL = c99_logb(x); +#elif defined(c99_log2) && FLT_RADIX == 2 + RETVAL = Perl_floor(c99_log2(PERL_ABS(x))); #else not_here("logb"); #endif @@ -2351,6 +2512,7 @@ fesetround(x) default: RETVAL = -1; break; } #else + PERL_UNUSED_VAR(x); RETVAL = -1; not_here("fesetround"); #endif @@ -2370,6 +2532,7 @@ fpclassify(x) lround = 7 signbit = 8 CODE: + PERL_UNUSED_VAR(x); RETVAL = -1; switch (ix) { case 0: @@ -2421,7 +2584,12 @@ fpclassify(x) #ifdef Perl_signbit RETVAL = Perl_signbit(x); #else - RETVAL = (x < 0) || (x == -0.0); + RETVAL = (x < 0); +#ifdef DOUBLE_IS_IEEE_FORMAT + if (x == -0.0) { + RETVAL = TRUE; + } +#endif #endif break; } @@ -2429,6 +2597,65 @@ fpclassify(x) RETVAL NV +getpayload(nv) + NV nv + CODE: +#ifdef DOUBLE_HAS_NAN + RETVAL = S_getpayload(nv); +#else + PERL_UNUSED_VAR(nv); + RETVAL = 0.0; + not_here("getpayload"); +#endif + OUTPUT: + RETVAL + +void +setpayload(nv, payload) + NV nv + NV payload + CODE: +#ifdef DOUBLE_HAS_NAN + S_setpayload(&nv, payload, FALSE); +#else + PERL_UNUSED_VAR(nv); + PERL_UNUSED_VAR(payload); + not_here("setpayload"); +#endif + OUTPUT: + nv + +void +setpayloadsig(nv, payload) + NV nv + NV payload + CODE: +#ifdef DOUBLE_HAS_NAN + nv = NV_NAN; + S_setpayload(&nv, payload, TRUE); +#else + PERL_UNUSED_VAR(nv); + PERL_UNUSED_VAR(payload); + not_here("setpayloadsig"); +#endif + OUTPUT: + nv + +int +issignaling(nv) + NV nv + CODE: +#ifdef DOUBLE_HAS_NAN + RETVAL = Perl_isnan(nv) && NV_NAN_IS_SIGNALING(&nv); +#else + PERL_UNUSED_VAR(nv); + RETVAL = 0.0; + not_here("issignaling"); +#endif + OUTPUT: + RETVAL + +NV copysign(x,y) NV x NV y @@ -2448,7 +2675,13 @@ copysign(x,y) nexttoward = 13 remainder = 14 CODE: + PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(y); +#ifdef NV_NAN RETVAL = NV_NAN; +#else + RETVAL = 0; +#endif switch (ix) { case 0: #ifdef c99_copysign @@ -2547,9 +2780,9 @@ copysign(x,y) case 14: default: #ifdef c99_remainder - RETVAL = c99_remainder(x, y); + RETVAL = c99_remainder(x, y); #else - not_here("remainder"); + not_here("remainder"); #endif break; } @@ -2589,6 +2822,8 @@ remquo(x,y) PUSHs(sv_2mortal(newSVnv(c99_remquo(x,y,&intvar)))); PUSHs(sv_2mortal(newSVnv(intvar))); #else + PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(y); not_here("remquo"); #endif @@ -2600,6 +2835,8 @@ scalbn(x,y) #ifdef c99_scalbn RETVAL = c99_scalbn(x, y); #else + PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(y); RETVAL = NV_NAN; not_here("scalbn"); #endif @@ -2614,20 +2851,42 @@ fma(x,y,z) CODE: #ifdef c99_fma RETVAL = c99_fma(x, y, z); +#else + PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(y); + PERL_UNUSED_VAR(z); + not_here("fma"); #endif OUTPUT: RETVAL NV -nan(s = 0) - char* s; +nan(payload = 0) + NV payload CODE: -#ifdef c99_nan - RETVAL = c99_nan(s ? s : ""); -#elif defined(NV_NAN) - /* XXX if s != NULL, warn about unused argument, - * or implement the nan payload setting. */ - RETVAL = NV_NAN; +#ifdef NV_NAN + /* If no payload given, just return the default NaN. + * This makes a difference in platforms where the default + * NaN is not all zeros. */ + if (items == 0) { + RETVAL = NV_NAN; + } else { + S_setpayload(&RETVAL, payload, FALSE); + } +#elif defined(c99_nan) + { + STRLEN elen = my_snprintf(PL_efloatbuf, PL_efloatsize, "%g", payload); + if ((IV)elen == -1) { +#ifdef NV_NAN + RETVAL = NV_NAN; +#else + RETVAL = 0.0; + not_here("nan"); +#endif + } else { + RETVAL = c99_nan(PL_efloatbuf); + } + } #else not_here("nan"); #endif @@ -2641,21 +2900,29 @@ jn(x,y) ALIAS: yn = 1 CODE: +#ifdef NV_NAN RETVAL = NV_NAN; +#else + RETVAL = 0; +#endif switch (ix) { case 0: #ifdef bessel_jn - RETVAL = bessel_jn(x, y); + RETVAL = bessel_jn(x, y); #else - not_here("jn"); + PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(y); + not_here("jn"); #endif break; case 1: default: #ifdef bessel_yn - RETVAL = bessel_yn(x, y); + RETVAL = bessel_yn(x, y); #else - not_here("yn"); + PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(y); + not_here("yn"); #endif break; } @@ -2668,10 +2935,10 @@ sigaction(sig, optaction, oldaction = 0) SV * optaction POSIX::SigAction oldaction CODE: -#if defined(WIN32) || defined(NETWARE) +#if defined(WIN32) || defined(NETWARE) || (defined(__amigaos4__) && defined(__NEWLIB__)) RETVAL = not_here("sigaction"); #else -# This code is really grody because we're trying to make the signal +# This code is really grody because we are trying to make the signal # interface look beautiful, which is hard. { @@ -2695,7 +2962,7 @@ sigaction(sig, optaction, oldaction = 0) const char *s = SvPVX_const(ST(0)); int i = whichsig(s); - if (i < 0 && memEQ(s, "SIG", 3)) + if (i < 0 && memBEGINs(s, SvCUR(ST(0)), "SIG")) i = whichsig(s + 3); if (i < 0) { if (ckWARN(WARN_SIGNAL)) @@ -2858,7 +3125,11 @@ sigpending(sigset) ALIAS: sigsuspend = 1 CODE: +#ifdef __amigaos4__ + RETVAL = not_here("sigpending"); +#else RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset); +#endif OUTPUT: RETVAL CLEANUP: @@ -2895,26 +3166,34 @@ dup2(fd1, fd2) int fd1 int fd2 CODE: + if (fd1 >= 0 && fd2 >= 0) { #ifdef WIN32 - /* RT #98912 - More Microsoft muppetry - failing to actually implemented - the well known documented POSIX behaviour for a POSIX API. - http://msdn.microsoft.com/en-us/library/8syseb29.aspx */ - RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2; + /* RT #98912 - More Microsoft muppetry - failing to + actually implemented the well known documented POSIX + behaviour for a POSIX API. + http://msdn.microsoft.com/en-us/library/8syseb29.aspx */ + RETVAL = dup2(fd1, fd2) == -1 ? -1 : fd2; #else - RETVAL = dup2(fd1, fd2); + RETVAL = dup2(fd1, fd2); #endif + } else { + SETERRNO(EBADF,RMS_IFI); + RETVAL = -1; + } OUTPUT: RETVAL SV * lseek(fd, offset, whence) - int fd + POSIX::Fd fd Off_t offset int whence CODE: - Off_t pos = PerlLIO_lseek(fd, offset, whence); - RETVAL = sizeof(Off_t) > sizeof(IV) - ? newSVnv((NV)pos) : newSViv((IV)pos); + { + Off_t pos = PerlLIO_lseek(fd, offset, whence); + RETVAL = sizeof(Off_t) > sizeof(IV) + ? newSVnv((NV)pos) : newSViv((IV)pos); + } OUTPUT: RETVAL @@ -2945,7 +3224,7 @@ read(fd, buffer, nbytes) PREINIT: SV *sv_buffer = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1); INPUT: - int fd + POSIX::Fd fd size_t nbytes char * buffer = sv_grow( sv_buffer, nbytes+1 ); CLEANUP: @@ -2966,11 +3245,11 @@ setsid() pid_t tcgetpgrp(fd) - int fd + POSIX::Fd fd SysRet tcsetpgrp(fd, pgrp_id) - int fd + POSIX::Fd fd pid_t pgrp_id void @@ -2992,43 +3271,34 @@ uname() SysRet write(fd, buffer, nbytes) - int fd + POSIX::Fd fd char * buffer size_t nbytes -SV * -tmpnam() - PREINIT: - STRLEN i; - int len; - CODE: - RETVAL = newSVpvs(""); - SvGROW(RETVAL, L_tmpnam); - /* Yes, we know tmpnam() is bad. So bad that some compilers - * and linkers warn against using it. But it is here for - * completeness. POSIX.pod warns against using it. - * - * Then again, maybe this should be removed at some point. - * No point in enabling dangerous interfaces. */ - if (ckWARN_d(WARN_DEPRECATED)) { - HV *warned = get_hv("POSIX::_warned", GV_ADD | GV_ADDMULTI); - if (! hv_exists(warned, (const char *)&PL_op, sizeof(PL_op))) { - Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Calling POSIX::tmpnam() is deprecated"); - hv_store(warned, (const char *)&PL_op, sizeof(PL_op), &PL_sv_yes, 0); - } - } - len = strlen(tmpnam(SvPV(RETVAL, i))); - SvCUR_set(RETVAL, len); - OUTPUT: - RETVAL - void abort() +#ifdef I_WCHAR +# include +#endif + int mblen(s, n) char * s size_t n + PREINIT: +#if defined(USE_ITHREADS) && defined(HAS_MBRLEN) + mbstate_t ps; +#endif + CODE: +#if defined(USE_ITHREADS) && defined(HAS_MBRLEN) + PERL_UNUSED_RESULT(mbrlen(NULL, 0, &ps)); /* Initialize state */ + RETVAL = mbrlen(s, n, &ps); /* Prefer reentrant version */ +#else + RETVAL = mblen(s, n); +#endif + OUTPUT: + RETVAL size_t mbstowcs(s, pwcs, n) @@ -3041,6 +3311,21 @@ mbtowc(pwc, s, n) wchar_t * pwc char * s size_t n + PREINIT: +#if defined(USE_ITHREADS) && defined(HAS_MBRTOWC) + mbstate_t ps; +#endif + CODE: +#if defined(USE_ITHREADS) && defined(HAS_MBRTOWC) + memset(&ps, 0, sizeof(ps));; + PERL_UNUSED_RESULT(mbrtowc(pwc, NULL, 0, &ps));/* Reset any shift state */ + errno = 0; + RETVAL = mbrtowc(pwc, s, n, &ps); /* Prefer reentrant version */ +#else + RETVAL = mbtowc(pwc, s, n); +#endif + OUTPUT: + RETVAL int wcstombs(s, pwcs, n) @@ -3065,17 +3350,18 @@ strtod(str) double num; char *unparsed; PPCODE: - STORE_NUMERIC_STANDARD_FORCE_LOCAL(); + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); num = strtod(str, &unparsed); + RESTORE_LC_NUMERIC(); PUSHs(sv_2mortal(newSVnv(num))); - if (GIMME == G_ARRAY) { + if (GIMME_V == G_ARRAY) { EXTEND(SP, 1); if (unparsed) PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); else PUSHs(&PL_sv_undef); } - RESTORE_NUMERIC_STANDARD(); #ifdef HAS_STRTOLD @@ -3086,17 +3372,18 @@ strtold(str) long double num; char *unparsed; PPCODE: - STORE_NUMERIC_STANDARD_FORCE_LOCAL(); + DECLARATION_FOR_LC_NUMERIC_MANIPULATION; + STORE_LC_NUMERIC_FORCE_TO_UNDERLYING(); num = strtold(str, &unparsed); + RESTORE_LC_NUMERIC(); PUSHs(sv_2mortal(newSVnv(num))); - if (GIMME == G_ARRAY) { + if (GIMME_V == G_ARRAY) { EXTEND(SP, 1); if (unparsed) PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); else PUSHs(&PL_sv_undef); } - RESTORE_NUMERIC_STANDARD(); #endif @@ -3108,20 +3395,29 @@ strtol(str, base = 0) long num; char *unparsed; PPCODE: - num = strtol(str, &unparsed, base); -#if IVSIZE <= LONGSIZE - if (num < IV_MIN || num > IV_MAX) - PUSHs(sv_2mortal(newSVnv((double)num))); - else -#endif - PUSHs(sv_2mortal(newSViv((IV)num))); - if (GIMME == G_ARRAY) { - EXTEND(SP, 1); - if (unparsed) - PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); - else - PUSHs(&PL_sv_undef); - } + if (base == 0 || (base >= 2 && base <= 36)) { + num = strtol(str, &unparsed, base); +#if IVSIZE < LONGSIZE + if (num < IV_MIN || num > IV_MAX) + PUSHs(sv_2mortal(newSVnv((double)num))); + else +#endif + PUSHs(sv_2mortal(newSViv((IV)num))); + if (GIMME_V == G_ARRAY) { + EXTEND(SP, 1); + if (unparsed) + PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); + else + PUSHs(&PL_sv_undef); + } + } else { + SETERRNO(EINVAL, LIB_INVARG); + PUSHs(&PL_sv_undef); + if (GIMME_V == G_ARRAY) { + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + } + } void strtoul(str, base = 0) @@ -3129,22 +3425,33 @@ strtoul(str, base = 0) int base PREINIT: unsigned long num; - char *unparsed; + char *unparsed = NULL; PPCODE: - num = strtoul(str, &unparsed, base); + PERL_UNUSED_VAR(str); + PERL_UNUSED_VAR(base); + if (base == 0 || (base >= 2 && base <= 36)) { + num = strtoul(str, &unparsed, base); #if IVSIZE <= LONGSIZE - if (num > IV_MAX) - PUSHs(sv_2mortal(newSVnv((double)num))); - else -#endif - PUSHs(sv_2mortal(newSViv((IV)num))); - if (GIMME == G_ARRAY) { - EXTEND(SP, 1); - if (unparsed) - PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); - else - PUSHs(&PL_sv_undef); - } + if (num > IV_MAX) + PUSHs(sv_2mortal(newSVnv((double)num))); + else +#endif + PUSHs(sv_2mortal(newSViv((IV)num))); + if (GIMME_V == G_ARRAY) { + EXTEND(SP, 1); + if (unparsed) + PUSHs(sv_2mortal(newSViv(strlen(unparsed)))); + else + PUSHs(&PL_sv_undef); + } + } else { + SETERRNO(EINVAL, LIB_INVARG); + PUSHs(&PL_sv_undef); + if (GIMME_V == G_ARRAY) { + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + } + } void strxfrm(src) @@ -3187,27 +3494,37 @@ mkfifo(filename, mode) SysRet tcdrain(fd) - int fd + POSIX::Fd fd ALIAS: close = 1 dup = 2 CODE: - RETVAL = ix == 1 ? close(fd) - : (ix < 1 ? tcdrain(fd) : dup(fd)); + if (fd >= 0) { + RETVAL = ix == 1 ? close(fd) + : (ix < 1 ? tcdrain(fd) : dup(fd)); + } else { + SETERRNO(EBADF,RMS_IFI); + RETVAL = -1; + } OUTPUT: RETVAL SysRet tcflow(fd, action) - int fd + POSIX::Fd fd int action ALIAS: tcflush = 1 tcsendbreak = 2 CODE: - RETVAL = ix == 1 ? tcflush(fd, action) - : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action)); + if (action >= 0) { + RETVAL = ix == 1 ? tcflush(fd, action) + : (ix < 1 ? tcflow(fd, action) : tcsendbreak(fd, action)); + } else { + SETERRNO(EINVAL,LIB_INVARG); + RETVAL = -1; + } OUTPUT: RETVAL @@ -3243,7 +3560,7 @@ asctime(sec, min, hour, mday, mon, year, wday = 0, yday = 0, isdst = -1) if (result == (time_t)-1) SvOK_off(TARG); else if (result == 0) - sv_setpvn(TARG, "0 but true", 10); + sv_setpvs(TARG, "0 but true"); else sv_setiv(TARG, (IV)result); } else { @@ -3301,18 +3618,23 @@ strftime(fmt, sec, min, hour, mday, mon, year, wday = -1, yday = -1, isdst = -1) /* allowing user-supplied (rather than literal) formats * is normally frowned upon as a potential security risk; * but this is part of the API so we have to allow it */ - GCC_DIAG_IGNORE(-Wformat-nonliteral); + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); buf = my_strftime(SvPV_nolen(fmt), sec, min, hour, mday, mon, year, wday, yday, isdst); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; sv = sv_newmortal(); if (buf) { STRLEN len = strlen(buf); sv_usepvn_flags(sv, buf, len, SV_HAS_TRAILING_NUL); - if (SvUTF8(fmt) - || (! is_ascii_string((U8*) buf, len) - && is_utf8_string((U8*) buf, len) + if ( SvUTF8(fmt) + || ( is_utf8_non_invariant_string((U8*) buf, len) #ifdef USE_LOCALE_TIME && _is_cur_LC_category_utf8(LC_TIME) +#else /* If can't check directly, at least can see if script is consistent, + under UTF-8, which gives us an extra measure of confidence. */ + + && isSCRIPT_RUN((const U8 *) buf, buf + len, + TRUE, /* Means assume UTF-8 */ + NULL) #endif )) { SvUTF8_on(sv); @@ -3364,6 +3686,7 @@ cuserid(s = 0) #ifdef HAS_CUSERID RETVAL = cuserid(s); #else + PERL_UNUSED_VAR(s); RETVAL = 0; not_here("cuserid"); #endif @@ -3372,7 +3695,7 @@ cuserid(s = 0) SysRetLong fpathconf(fd, name) - int fd + POSIX::Fd fd int name SysRetLong @@ -3407,7 +3730,7 @@ sysconf(name) char * ttyname(fd) - int fd + POSIX::Fd fd void getcwd() @@ -3429,6 +3752,9 @@ lchown(uid, gid, path) * but consistent with CORE::chown() */ RETVAL = lchown(path, uid, gid); #else + PERL_UNUSED_VAR(uid); + PERL_UNUSED_VAR(gid); + PERL_UNUSED_VAR(path); RETVAL = not_here("lchown"); #endif OUTPUT: