#define PERL_EXT_POSIX
+#define PERL_EXT
#ifdef NETWARE
#define _POSIX_
#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
#ifdef WIN32
#include <sys/errno2.h>
#endif
-#ifdef I_FLOAT
#include <float.h>
-#endif
#ifdef I_FENV
+#if !(defined(__vax__) && defined(__NetBSD__))
#include <fenv.h>
#endif
-#ifdef I_LIMITS
-#include <limits.h>
#endif
+#include <limits.h>
#include <locale.h>
#include <math.h>
#ifdef I_PWD
#include <setjmp.h>
#include <signal.h>
#include <stdarg.h>
-
-#ifdef I_STDDEF
#include <stddef.h>
-#endif
#ifdef I_UNISTD
#include <unistd.h>
#endif
+#ifdef I_SYS_TIME
+# include <sys/time.h>
+#endif
+
+#ifdef I_SYS_RESOURCE
+# include <sys/resource.h>
+#endif
+
+/* Cygwin's stdio.h doesn't make cuserid() visible with -D_GNU_SOURCE,
+ unlike Linux.
+*/
+#ifdef __CYGWIN__
+# undef HAS_CUSERID
+#endif
+
#if defined(USE_QUADMATH) && defined(I_QUADMATH)
# undef M_E
# define c99_ilogb ilogbq
# define c99_lgamma lgammaq
# define c99_log1p log1pq
-# define c99_llrint llrintq
# define c99_log2 log2q
/* no logbq */
-# define c99_lround 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
# undef c99_trunc
#endif
+/* The cc with NetBSD 8.0 and 9.0 claims to be a C11 hosted compiler,
+ * but doesn't define several functions required by C99, let alone C11.
+ * http://gnats.netbsd.org/53234
+ */
+#if defined(USE_LONG_DOUBLE) && defined(__NetBSD__) \
+ && !defined(NETBSD_HAVE_FIXED_LONG_DOUBLE_MATH)
+# undef c99_expm1
+# undef c99_lgamma
+# undef c99_log1p
+# undef c99_log2
+# undef c99_nexttoward
+# undef c99_remainder
+# undef c99_remquo
+# undef c99_tgamma
+#endif
+
#ifndef isunordered
# ifdef Perl_isnan
# define isunordered(x, y) (Perl_isnan(x) || Perl_isnan(y))
# undef c99_trunc
#endif
-#ifdef WIN32
+#ifdef _MSC_VER
/* Some APIs exist under Win32 with "underbar" names. */
# undef c99_hypot
#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
#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
#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
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;
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) */
return result;
}
+#ifdef NV_INF
/* Third interval: [12, +Inf) */
#if LDBL_MANT_DIG == 113 /* IEEE quad prec */
if (x > 1755.548) {
return NV_INF;
}
#endif
+#endif
return Perl_exp(c99_lgamma(x));
}
#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)
{
/* 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
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()) {
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");
+ NOT_REACHED; /* NOTREACHED */
}
#endif
# 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 *= (NV) 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
#if defined(I_TERMIOS)
#include <termios.h>
#endif
-#ifdef I_STDLIB
#include <stdlib.h>
-#endif
#ifndef __ultrix__
#include <string.h>
#endif
#else
# ifndef HAS_MKFIFO
-# if defined(OS2)
+# if defined(OS2) || defined(__amigaos4__)
# define mkfifo(a,b) not_here("mkfifo")
# else /* !( defined OS2 ) */
# ifndef mkfifo
# ifdef HAS_UNAME
# include <sys/utsname.h>
# endif
-# include <sys/wait.h>
+# ifndef __amigaos4__
+# include <sys/wait.h>
+# endif
# ifdef I_UTIME
# include <utime.h>
# endif
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.*/
#define waitpid(a,b,c) not_here("waitpid")
#endif
-#ifndef HAS_MBLEN
-#ifndef mblen
+#if ! defined(HAS_MBLEN) && ! defined(HAS_MBRLEN)
#define mblen(a,b) not_here("mblen")
#endif
-#endif
-#ifndef HAS_MBSTOWCS
-#define mbstowcs(s, pwcs, n) not_here("mbstowcs")
-#endif
-#ifndef HAS_MBTOWC
+#if ! defined(HAS_MBTOWC) && ! defined(HAS_MBRTOWC)
#define mbtowc(pwc, s, n) not_here("mbtowc")
#endif
-#ifndef HAS_WCSTOMBS
-#define wcstombs(s, pwcs, n) not_here("wcstombs")
-#endif
-#ifndef HAS_WCTOMB
-#define wctomb(s, wchar) not_here("wcstombs")
+#if ! defined(HAS_WCTOMB) && ! defined(HAS_WCRTOMB)
+#define wctomb(s, wchar) not_here("wctomb")
#endif
#if !defined(HAS_MBLEN) && !defined(HAS_MBSTOWCS) && !defined(HAS_MBTOWC) && !defined(HAS_WCSTOMBS) && !defined(HAS_WCTOMB)
/* If we don't have these functions, then we wouldn't have gotten a typedef
#endif
#endif
-#ifndef HAS_LOCALECONV
+#if ! defined(HAS_LOCALECONV) && ! defined(HAS_LOCALECONV_L)
# define localeconv() not_here("localeconv")
#else
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)},
/* 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)},
* 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 *
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;
* "write through" environment changes to the process environment.
*
* (c) Even the primary Perl interpreter won't update the CRT copy of the
- * the environment, only the Win32API copy (it calls win32_putenv()).
+ * environment, only the Win32API copy (it calls win32_putenv()).
*
* As with CPerlHost::Getenv() and CPerlHost::Putenv() themselves, it makes
* sense to only update the process environment when inside the main
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);
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))));
- (void)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
sizeof(sigset_t),
packname);
sigemptyset(s);
- for (i = 1; i < items; i++)
- sigaddset(s, SvIV(ST(i)));
+ for (i = 1; i < items; i++) {
+ IV sig = SvIV(ST(i));
+ if (sigaddset(s, sig) < 0)
+ croak("POSIX::Sigset->new: failed to add signal %" IVdf, sig);
+ }
XSRETURN(1);
}
SysRet
addset(sigset, sig)
POSIX::SigSet sigset
- int sig
+ POSIX::SigNo sig
ALIAS:
delset = 1
CODE:
int
sigismember(sigset, sig)
POSIX::SigSet sigset
- int sig
+ POSIX::SigNo sig
MODULE = Termios PACKAGE = POSIX::Termios PREFIX = cf
SysRet
getattr(termios_ref, fd = 0)
POSIX::Termios termios_ref
- int fd
+ POSIX::Fd fd
CODE:
RETVAL = tcgetattr(fd, termios_ref);
OUTPUT:
RETVAL
-# If we define TCSANOW here then both a found and not found constant sub
-# are created causing a Constant subroutine TCSANOW redefined warning
+ # If we define TCSANOW here then both a found and not found constant sub
+ # are created causing a Constant subroutine TCSANOW redefined warning
+
#ifndef TCSANOW
# define DEF_SETATTR_ACTION 0
#else
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
#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
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 = NULL;
+# elif defined(TS_W32_BROKEN_LOCALECONV)
+ const char * save_global;
+ const char * save_thread;
+# 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) \
+ && defined(HAS_DUPLOCALE)
+
+ cur = uselocale((locale_t) 0);
+ if (cur == LC_GLOBAL_LOCALE) {
+ cur = duplocale(LC_GLOBAL_LOCALE);
+ do_free = TRUE;
+ }
+
+ lcbuf = localeconv_l(cur);
+# else
+ LOCALE_LOCK_V; /* Prevent interference with other threads using
+ localeconv() */
+# ifdef TS_W32_BROKEN_LOCALECONV
+ /* This is a workaround for a Windows bug prior to VS 15, in which
+ * localeconv only looks at the global locale. We toggle to the global
+ * locale; populate the return; then toggle back. We have to use
+ * LC_ALL instead of the individual ones because of another bug in
+ * Windows */
+
+ save_thread = savepv(Perl_setlocale(LC_NUMERIC, NULL));
+
+ _configthreadlocale(_DISABLE_PER_THREAD_LOCALE);
+
+ save_global = savepv(Perl_setlocale(LC_ALL, NULL));
+
+ Perl_setlocale(LC_ALL, save_thread);
+# endif
+ 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;
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 and variant under UTF-8 */
- is_utf8_locale
- && ! is_invariant_string((U8 *) value, 0)
- && is_utf8_string((U8 *) value, 0)),
- 0);
- }
+ strings->name,
+ strlen(strings->name),
+ newSVpvn_utf8(value, value_len, is_utf8),
+ 0);
+ }
strings++;
}
integers++;
}
}
- RESTORE_NUMERIC_STANDARD();
+# if defined(USE_ITHREADS) \
+ && defined(HAS_POSIX_2008_LOCALE) \
+ && defined(HAS_LOCALECONV_L)
+ if (do_free) {
+ freelocale(cur);
+ }
+# else
+# ifdef TS_W32_BROKEN_LOCALECONV
+ Perl_setlocale(LC_ALL, save_global);
+
+ _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
+
+ Perl_setlocale(LC_ALL, save_thread);
+
+ Safefree(save_global);
+ Safefree(save_thread);
+# endif
+ LOCALE_UNLOCK_V;
+# endif
+ RESTORE_LC_NUMERIC();
#endif /* HAS_LOCALECONV */
OUTPUT:
RETVAL
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 = (char *) Perl_setlocale(category, locale);
+ if (! retval) {
XSRETURN_UNDEF;
}
- /* Save retval since subsequent setlocale() calls may overwrite it. */
- retval = savepv(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)
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 */
#endif
break;
case 17:
- RETVAL = log10(x); /* C89 math */
+ RETVAL = Perl_log10(x); /* C89 math */
break;
case 18:
#ifdef c99_log1p
#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;
}
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
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
ldexp(x,exp)
NV x
int exp
+ CODE:
+ RETVAL = Perl_ldexp(x, exp);
+ OUTPUT:
+ RETVAL
void
modf(x)
NV z
CODE:
#ifdef c99_fma
+ RETVAL = c99_fma(x, y, z);
+#else
PERL_UNUSED_VAR(x);
PERL_UNUSED_VAR(y);
PERL_UNUSED_VAR(z);
- RETVAL = c99_fma(x, y, z);
+ not_here("fma");
#endif
OUTPUT:
RETVAL
NV
-nan(s = 0)
- char* s;
+nan(payload = 0)
+ NV payload
CODE:
- PERL_UNUSED_VAR(s);
-#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. */
- /* NVSIZE == 8: the NaN "header" (the exponent) is 0x7FF (the 0x800
- * is the sign bit, which should be irrelevant for NaN, so really
- * also 0xFFF), leaving 64 - 12 = 52 bits for the NaN payload
- * (6.5 bytes, note about infinities below).
- *
- * (USE_LONG_DOUBLE and)
- * LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN:
- * the NaN "header" is still 0x7FF, leaving 80 - 12 = 68 bits
- * for the payload (8.5 bytes, note about infinities below).
- *
- * doubledouble? aargh. Maybe like doubles, 52 + 52 = 104 bits?
- *
- * NVSIZE == 16:
- * the NaN "header" is still 0x7FF, leaving 128 - 12 = 116 bits
- * for the payload (14.5 bytes, note about infinities below)
- *
- * Which ones of the NaNs are 'signaling' and which are 'quiet',
- * depends. In the IEEE-754 1985, nothing was specified. But the
- * majority of companies decided that the MSB of the mantissa was
- * the bit for 'quiet'. (Only PA-RISC and MIPS were different,
- * using the MSB as 'signaling'.) The IEEE-754 2008 *recommended*
- * (but did not dictate) the MSB as the 'quiet' bit.
- *
- * In other words, on most platforms, and for 64-bit doubles:
- * [7FF8000000000000, 7FFFFFFFFFFFFFFF] quiet
- * [FFF8000000000000, FFFFFFFFFFFFFFFF] quiet
- * [7FF0000000000001, 7FF7FFFFFFFFFFFF] signaling
- * [FFF0000000000001, FFF7FFFFFFFFFFFF] signaling
- *
- * The C99 nan() is supposed to generate *quiet* NaNs.
- *
- * Note the asymmetry:
- * The 7FF0000000000000 is positive infinity,
- * the FFF0000000000000 is negative infinity.
- */
- 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
ALIAS:
yn = 1
CODE:
- PERL_UNUSED_VAR(x);
- PERL_UNUSED_VAR(y);
+#ifdef NV_NAN
RETVAL = NV_NAN;
+#else
+ RETVAL = 0;
+#endif
switch (ix) {
case 0:
#ifdef bessel_jn
RETVAL = bessel_jn(x, y);
#else
+ PERL_UNUSED_VAR(x);
+ PERL_UNUSED_VAR(y);
not_here("jn");
#endif
break;
#ifdef bessel_yn
RETVAL = bessel_yn(x, y);
#else
+ PERL_UNUSED_VAR(x);
+ PERL_UNUSED_VAR(y);
not_here("yn");
#endif
break;
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.
{
- dVAR;
POSIX__SigAction action;
GV *siggv = gv_fetchpvs("SIG", GV_ADD, SVt_PVHV);
struct sigaction act;
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))
/* Remember old disposition if desired. */
if (oldaction) {
+ int safe;
+
svp = hv_fetchs(oldaction, "HANDLER", TRUE);
if(!svp)
croak("Can't supply an oldaction without a HANDLER");
svp = hv_fetchs(oldaction, "FLAGS", TRUE);
sv_setiv(*svp, oact.sa_flags);
- /* Get back whether the old handler used safe signals. */
+ /* Get back whether the old handler used safe signals;
+ * i.e. it used Perl_csighandler[13] rather than
+ * Perl_sighandler[13]
+ */
+ safe =
+#ifdef SA_SIGINFO
+ (oact.sa_flags & SA_SIGINFO)
+ ? ( oact.sa_sigaction == PL_csighandler3p
+#ifdef PERL_USE_3ARG_SIGHANDLER
+ || oact.sa_sigaction == PL_csighandlerp
+#endif
+ )
+ :
+#endif
+ ( oact.sa_handler == PL_csighandler1p
+#ifndef PERL_USE_3ARG_SIGHANDLER
+ || oact.sa_handler == PL_csighandlerp
+#endif
+ );
+
svp = hv_fetchs(oldaction, "SAFE", TRUE);
- sv_setiv(*svp,
- /* compare incompatible pointers by casting to integer */
- PTR2nat(oact.sa_handler) == PTR2nat(PL_csighandlerp));
+ sv_setiv(*svp, safe);
}
if (action) {
+ int safe;
+
+ /* Set up any desired flags. */
+ svp = hv_fetchs(action, "FLAGS", FALSE);
+ act.sa_flags = svp ? SvIV(*svp) : 0;
+
/* Safe signals use "csighandler", which vectors through the
PL_sighandlerp pointer when it's safe to do so.
(BTW, "csighandler" is very different from "sighandler".) */
svp = hv_fetchs(action, "SAFE", FALSE);
- act.sa_handler =
- DPTR2FPTR(
- void (*)(int),
- (*svp && SvTRUE(*svp))
- ? PL_csighandlerp : PL_sighandlerp
- );
+ safe = *svp && SvTRUE(*svp);
+#ifdef SA_SIGINFO
+ if (act.sa_flags & SA_SIGINFO) {
+ /* 3-arg handler */
+ act.sa_sigaction =
+ safe ? PL_csighandler3p : PL_sighandler3p;
+ }
+ else
+#endif
+ {
+ /* 1-arg handler */
+ act.sa_handler =
+ safe ? PL_csighandler1p : PL_sighandler1p;
+ }
/* Vector new Perl handler through %SIG.
(The core signal handlers read %SIG to dispatch.) */
else
sigemptyset(& act.sa_mask);
- /* Set up any desired flags. */
- svp = hv_fetchs(action, "FLAGS", FALSE);
- act.sa_flags = svp ? SvIV(*svp) : 0;
-
/* Don't worry about cleaning up *sigsvp if this fails,
* because that means we tried to disposition a
* nonblockable signal, in which case *sigsvp is
ALIAS:
sigsuspend = 1
CODE:
+#ifdef __amigaos4__
+ RETVAL = not_here("sigpending");
+#else
RETVAL = ix ? sigsuspend(sigset) : sigpending(sigset);
+#endif
OUTPUT:
RETVAL
CLEANUP:
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
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:
pid_t
tcgetpgrp(fd)
- int fd
+ POSIX::Fd fd
SysRet
tcsetpgrp(fd, pgrp_id)
- int fd
+ POSIX::Fd fd
pid_t pgrp_id
void
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");
- (void)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()
+#if defined(HAS_MBRLEN) && (defined(USE_ITHREADS) || ! defined(HAS_MBLEN))
+# define USE_MBRLEN
+#else
+# undef USE_MBRLEN
+#endif
+
int
-mblen(s, n)
- char * s
+mblen(s, n = ~0)
+ SV * s
size_t n
+ CODE:
+ errno = 0;
-size_t
-mbstowcs(s, pwcs, n)
- wchar_t * s
- char * pwcs
- size_t n
+ SvGETMAGIC(s);
+ if (! SvOK(s)) {
+#ifdef USE_MBRLEN
+ /* Initialize the shift state in PL_mbrlen_ps. The Standard says
+ * that should be all zeros. */
+ memzero(&PL_mbrlen_ps, sizeof(PL_mbrlen_ps));
+ RETVAL = 0;
+#else
+ LOCALE_LOCK;
+ RETVAL = mblen(NULL, 0);
+ LOCALE_UNLOCK;
+#endif
+ }
+ else { /* Not resetting state */
+ SV * byte_s = sv_2mortal(newSVsv_nomg(s));
+ if (! sv_utf8_downgrade_nomg(byte_s, TRUE)) {
+ SETERRNO(EINVAL, LIB_INVARG);
+ RETVAL = -1;
+ }
+ else {
+ size_t len;
+ char * string = SvPV(byte_s, len);
+ if (n < len) len = n;
+#ifdef USE_MBRLEN
+ RETVAL = (SSize_t) mbrlen(string, len, &PL_mbrlen_ps);
+ if (RETVAL < 0) RETVAL = -1; /* Use mblen() ret code for
+ transparency */
+#else
+ /* Locking prevents races, but locales can be switched out
+ * without locking, so this isn't a cure all */
+ LOCALE_LOCK;
+ RETVAL = mblen(string, len);
+ LOCALE_UNLOCK;
+#endif
+ }
+ }
+ OUTPUT:
+ RETVAL
-int
-mbtowc(pwc, s, n)
- wchar_t * pwc
- char * s
- size_t n
+#if defined(HAS_MBRTOWC) && (defined(USE_ITHREADS) || ! defined(HAS_MBTOWC))
+# define USE_MBRTOWC
+#else
+# undef USE_MBRTOWC
+#endif
int
-wcstombs(s, pwcs, n)
- char * s
- wchar_t * pwcs
+mbtowc(pwc, s, n = ~0)
+ SV * pwc
+ SV * s
size_t n
+ CODE:
+ errno = 0;
+ SvGETMAGIC(s);
+ if (! SvOK(s)) { /* Initialize state */
+#ifdef USE_MBRTOWC
+ /* Initialize the shift state to all zeros in PL_mbrtowc_ps. */
+ memzero(&PL_mbrtowc_ps, sizeof(PL_mbrtowc_ps));
+ RETVAL = 0;
+#else
+ LOCALE_LOCK;
+ RETVAL = mbtowc(NULL, NULL, 0);
+ LOCALE_UNLOCK;
+#endif
+ }
+ else { /* Not resetting state */
+ wchar_t wc;
+ SV * byte_s = sv_2mortal(newSVsv_nomg(s));
+ if (! sv_utf8_downgrade_nomg(byte_s, TRUE)) {
+ SETERRNO(EINVAL, LIB_INVARG);
+ RETVAL = -1;
+ }
+ else {
+ size_t len;
+ char * string = SvPV(byte_s, len);
+ if (n < len) len = n;
+#ifdef USE_MBRTOWC
+ RETVAL = (SSize_t) mbrtowc(&wc, string, len, &PL_mbrtowc_ps);
+#else
+ /* Locking prevents races, but locales can be switched out
+ * without locking, so this isn't a cure all */
+ LOCALE_LOCK;
+ RETVAL = mbtowc(&wc, string, len);
+ LOCALE_UNLOCK;
+#endif
+ if (RETVAL >= 0) {
+ sv_setiv_mg(pwc, wc);
+ }
+ else { /* Use mbtowc() ret code for transparency */
+ RETVAL = -1;
+ }
+ }
+ }
+ OUTPUT:
+ RETVAL
+
+#if defined(HAS_WCRTOMB) && (defined(USE_ITHREADS) || ! defined(HAS_WCTOMB))
+# define USE_WCRTOMB
+#else
+# undef USE_WCRTOMB
+#endif
int
wctomb(s, wchar)
- char * s
+ SV * s
wchar_t wchar
+ CODE:
+ errno = 0;
+ SvGETMAGIC(s);
+ if (s == &PL_sv_undef) {
+#ifdef USE_WCRTOMB
+ /* The man pages khw looked at are in agreement that this works.
+ * But probably memzero would too */
+ RETVAL = wcrtomb(NULL, L'\0', &PL_wcrtomb_ps);
+#else
+ LOCALE_LOCK;
+ RETVAL = wctomb(NULL, L'\0');
+ LOCALE_UNLOCK;
+#endif
+ }
+ else { /* Not resetting state */
+ char buffer[MB_LEN_MAX];
+#ifdef USE_WCRTOMB
+ RETVAL = wcrtomb(buffer, wchar, &PL_wcrtomb_ps);
+#else
+ /* Locking prevents races, but locales can be switched out without
+ * locking, so this isn't a cure all */
+ LOCALE_LOCK;
+ RETVAL = wctomb(buffer, wchar);
+ LOCALE_UNLOCK;
+#endif
+ if (RETVAL >= 0) {
+ sv_setpvn_mg(s, buffer, RETVAL);
+ }
+ }
+ OUTPUT:
+ RETVAL
int
strcoll(s1, s2)
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_V == G_ARRAY) {
EXTEND(SP, 1);
else
PUSHs(&PL_sv_undef);
}
- RESTORE_NUMERIC_STANDARD();
#ifdef HAS_STRTOLD
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_V == G_ARRAY) {
EXTEND(SP, 1);
else
PUSHs(&PL_sv_undef);
}
- RESTORE_NUMERIC_STANDARD();
#endif
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_V == G_ARRAY) {
- EXTEND(SP, 1);
- if (unparsed)
- PUSHs(sv_2mortal(newSViv(strlen(unparsed))));
- else
- PUSHs(&PL_sv_undef);
- }
+ if (base == 0 || inRANGE(base, 2, 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)
int base
PREINIT:
unsigned long num;
- char *unparsed;
+ char *unparsed = NULL;
PPCODE:
PERL_UNUSED_VAR(str);
PERL_UNUSED_VAR(base);
- num = strtoul(str, &unparsed, base);
+ if (base == 0 || inRANGE(base, 2, 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_V == 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)
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
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 {
/* 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_invariant_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,
+ (const U8 *) buf + len,
+ TRUE) /* Means assume UTF-8 */
#endif
)) {
SvUTF8_on(sv);
ctermid(s = 0)
char * s = 0;
CODE:
-#ifdef HAS_CTERMID_R
+#ifdef I_TERMIOS
+ /* On some systems L_ctermid is a #define; but not all; this code works
+ * for all cases (so far...) */
s = (char *) safemalloc((size_t) L_ctermid);
#endif
RETVAL = ctermid(s);
OUTPUT:
RETVAL
CLEANUP:
-#ifdef HAS_CTERMID_R
+#ifdef I_TERMIOS
Safefree(s);
#endif
SysRetLong
fpathconf(fd, name)
- int fd
+ POSIX::Fd fd
int name
SysRetLong
char *
ttyname(fd)
- int fd
+ POSIX::Fd fd
void
getcwd()
https://perl5.git.perl.org / perl5.git / blobdiff