summaryrefslogtreecommitdiffstats
path: root/gnu/usr.bin/perl/ext/POSIX
diff options
context:
space:
mode:
authorafresh1 <afresh1@openbsd.org>2019-02-13 21:15:00 +0000
committerafresh1 <afresh1@openbsd.org>2019-02-13 21:15:00 +0000
commit9f11ffb7133c203312a01e4b986886bc88c7d74b (patch)
tree6618511204c614b20256e4ef9dea39a7b311d638 /gnu/usr.bin/perl/ext/POSIX
parentImport perl-5.28.1 (diff)
downloadwireguard-openbsd-9f11ffb7133c203312a01e4b986886bc88c7d74b.tar.xz
wireguard-openbsd-9f11ffb7133c203312a01e4b986886bc88c7d74b.zip
Fix merge issues, remove excess files - match perl-5.28.1 dist
looking good sthen@, Great! bluhm@
Diffstat (limited to 'gnu/usr.bin/perl/ext/POSIX')
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/Makefile.PL29
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/POSIX.xs464
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pm164
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pod93
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/t/export.t60
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/t/math.t186
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/t/posix.t123
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/t/sigaction.t10
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/t/time.t2
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/t/wrappers.t7
10 files changed, 670 insertions, 468 deletions
diff --git a/gnu/usr.bin/perl/ext/POSIX/Makefile.PL b/gnu/usr.bin/perl/ext/POSIX/Makefile.PL
index 5a65173958f..5d5c009c3c9 100644
--- a/gnu/usr.bin/perl/ext/POSIX/Makefile.PL
+++ b/gnu/usr.bin/perl/ext/POSIX/Makefile.PL
@@ -20,6 +20,9 @@ if ($^O eq 'solaris') {
if ($^O eq 'aix' && $Config{uselongdouble}) {
push @libs, qw(c128);
}
+if ($^O eq 'cygwin' && $Config{usequadmath}) {
+ push @libs, qw(quadmath);
+}
WriteMakefile(
NAME => 'POSIX',
@libs ? ( 'LIBS' => [ join(" ", map { "-l$_" } @libs) ] ) : (),
@@ -47,8 +50,9 @@ my @names =
ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIME ETIMEDOUT ETOOMANYREFS ETXTBSY
EUSERS EWOULDBLOCK EXDEV FILENAME_MAX F_OK HUPCL ICANON ICRNL IEXTEN
IGNBRK IGNCR IGNPAR INLCR INPCK INT_MAX INT_MIN ISIG ISTRIP IXOFF IXON
- LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME
- LINK_MAX LONG_MAX LONG_MIN L_ctermid L_cuserid L_tmpnam MAX_CANON
+ LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION LC_MEASUREMENT
+ LC_MESSAGES LC_MONETARY LC_NUMERIC LC_PAPER LC_TELEPHONE LC_TIME
+ LINK_MAX LONG_MAX LONG_MIN L_ctermid L_cuserid MAX_CANON
MAX_INPUT MB_LEN_MAX MSG_CTRUNC MSG_DONTROUTE MSG_EOR MSG_OOB MSG_PEEK
MSG_TRUNC MSG_WAITALL NAME_MAX NCCS NGROUPS_MAX NOFLSH OPEN_MAX OPOST
PARENB PARMRK PARODD PATH_MAX PIPE_BUF RAND_MAX R_OK SCHAR_MAX
@@ -66,7 +70,8 @@ my @names =
_SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL _SC_NGROUPS_MAX
_SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS _SC_STREAM_MAX _SC_TZNAME_MAX
_SC_VERSION EAI_AGAIN EAI_BADFLAGS EAI_FAIL EAI_FAMILY EAI_MEMORY EAI_NONAME
- EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM EAI_OVERFLOW),
+ EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM EAI_OVERFLOW
+ PRIO_PROCESS PRIO_PGRP PRIO_USER),
{name=>"CLK_TCK", not_constant=>1},
{name=>"MB_CUR_MAX", not_constant=>1},
{name=>"EXIT_FAILURE", default=>["IV", "1"]},
@@ -74,8 +79,6 @@ my @names =
{name=>"SIG_DFL", value=>"PTR2IV(SIG_DFL)", not_constant=>1},
{name=>"SIG_ERR", value=>"PTR2IV(SIG_ERR)", not_constant=>1},
{name=>"SIG_IGN", value=>"PTR2IV(SIG_IGN)", not_constant=>1},
- # L_tmpnam[e] was a typo--retained for compatibility
- {name=>"L_tmpname", value=>"L_tmpnam"},
{name=>"NULL", value=>"0"},
{name=>"_POSIX_JOB_CONTROL", type=>"YES", default=>["IV", "0"]},
{name=>"_POSIX_SAVED_IDS", type=>"YES", default=>["IV", "0"]},
@@ -94,11 +97,17 @@ END
#endif
'});
-push @names,
- {name=>"INFINITY", type=>"NV", value=>"NV_INF", not_constant=>1},
- {name=>"NAN", type=>"NV", value=>"NV_NAN", not_constant=>1},
- {name=>"Inf", type=>"NV", value=>"NV_INF", not_constant=>1},
- {name=>"NaN", type=>"NV", value=>"NV_NAN", not_constant=>1};
+if ($Config{d_double_has_inf}) {
+ push @names,
+ {name=>"INFINITY", type=>"NV", value=>"NV_INF", not_constant=>1},
+ {name=>"Inf", type=>"NV", value=>"NV_INF", not_constant=>1},
+}
+
+if ($Config{d_double_has_nan}) {
+ push @names,
+ {name=>"NAN", type=>"NV", value=>"NV_NAN", not_constant=>1},
+ {name=>"NaN", type=>"NV", value=>"NV_NAN", not_constant=>1};
+}
push @names, {name=>$_, type=>"UV"}
foreach (qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND
diff --git a/gnu/usr.bin/perl/ext/POSIX/POSIX.xs b/gnu/usr.bin/perl/ext/POSIX/POSIX.xs
index 5a82b8182ce..74973058417 100644
--- a/gnu/usr.bin/perl/ext/POSIX/POSIX.xs
+++ b/gnu/usr.bin/perl/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 <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
@@ -48,15 +50,20 @@
#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
+
#if defined(USE_QUADMATH) && defined(I_QUADMATH)
# undef M_E
@@ -704,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
@@ -720,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
@@ -733,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
@@ -768,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;
@@ -816,10 +833,18 @@ static NV my_lgamma(NV 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) */
@@ -891,6 +916,7 @@ static NV my_tgamma(NV x)
return result;
}
+#ifdef NV_INF
/* Third interval: [12, +Inf) */
#if LDBL_MANT_DIG == 113 /* IEEE quad prec */
if (x > 1755.548) {
@@ -901,6 +927,7 @@ static NV my_tgamma(NV x)
return NV_INF;
}
#endif
+#endif
return Perl_exp(c99_lgamma(x));
}
@@ -909,10 +936,14 @@ static NV my_tgamma(NV 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)
@@ -953,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
@@ -1032,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()) {
@@ -1040,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
@@ -1118,6 +1152,8 @@ 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
@@ -1154,9 +1190,11 @@ static NV my_trunc(NV x)
#endif
#if defined(USE_LONG_DOUBLE) && defined(LONGDOUBLE_DOUBLEDOUBLE)
-# define NV_PAYLOAD_SIZEOF_ASSERT(a) assert(sizeof(a) == NVSIZE / 2)
+# define NV_PAYLOAD_SIZEOF_ASSERT(a) \
+ STATIC_ASSERT_STMT(sizeof(a) == NVSIZE / 2)
#else
-# define NV_PAYLOAD_SIZEOF_ASSERT(a) assert(sizeof(a) == NVSIZE)
+# 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)
@@ -1178,7 +1216,7 @@ static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling)
{
NV t1 = c99_trunc(payload); /* towards zero (drop fractional) */
#ifdef NV_PAYLOAD_DEBUG
- Perl_warn(aTHX_ "t1 = %"NVgf" (payload %"NVgf")\n", t1, payload);
+ 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?) */
@@ -1208,7 +1246,7 @@ static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling)
#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]);
+ Perl_warn(aTHX_ "a[%d] = 0x%" UVxf "\n", i, a[i]);
}
#endif
for (i = 0; i < (int)sizeof(p); i++) {
@@ -1219,7 +1257,9 @@ static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling)
((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);
+ 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;
}
@@ -1236,7 +1276,7 @@ static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling)
#endif
for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) {
if (a[i]) {
- Perl_warn(aTHX_ "payload lost bits (%"UVxf")", a[i]);
+ Perl_warn(aTHX_ "payload lost bits (%" UVxf ")", a[i]);
break;
}
}
@@ -1267,7 +1307,7 @@ static NV_PAYLOAD_TYPE S_getpayload(NV nv)
}
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]);
+ Perl_warn(aTHX_ "a[%d] = %" UVxf "\n", i, a[i]);
#endif
payload *= UV_MAX;
payload += a[i];
@@ -1281,6 +1321,8 @@ static NV_PAYLOAD_TYPE S_getpayload(NV nv)
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
@@ -1288,9 +1330,7 @@ static NV_PAYLOAD_TYPE S_getpayload(NV nv)
#if defined(I_TERMIOS)
#include <termios.h>
#endif
-#ifdef I_STDLIB
#include <stdlib.h>
-#endif
#ifndef __ultrix__
#include <string.h>
#endif
@@ -1558,8 +1598,8 @@ static 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) (strEQ(name, "decimal_point") \
- || strEQ(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 \
@@ -1663,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;
@@ -1747,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);
@@ -1852,8 +1897,9 @@ getattr(termios_ref, fd = 0)
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
@@ -2079,15 +2125,67 @@ 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 = 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 */
- DECLARATION_FOR_LC_NUMERIC_MANIPULATION;
+# 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;
@@ -2095,35 +2193,36 @@ localeconv()
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++;
}
@@ -2136,7 +2235,26 @@ localeconv()
integers++;
}
}
- RESTORE_LC_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
@@ -2148,116 +2266,12 @@ 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_UNDERLYING();
- }
-# endif
- }
-#endif
-#ifdef WIN32 /* Use wrapper on Windows */
- retval = Perl_my_setlocale(aTHX_ category, locale);
-#else
- retval = setlocale(category, locale);
-#endif
- DEBUG_L(PerlIO_printf(Perl_debug_log,
- "%s:%d: %s\n", __FILE__, __LINE__,
- _setlocale_debug_string(category, locale, retval)));
- 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);
- SAVEFREEPV(retval);
-
- /* For locale == 0, we may have switched to NUMERIC_UNDERLYING. 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);
- DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "%s:%d: %s\n", __FILE__, __LINE__,
- _setlocale_debug_string(LC_CTYPE, NULL, newctype)));
- }
- 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);
- DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "%s:%d: %s\n", __FILE__, __LINE__,
- _setlocale_debug_string(LC_COLLATE, NULL, newcoll)));
- }
- 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);
- DEBUG_Lv(PerlIO_printf(Perl_debug_log,
- "%s:%d: %s\n", __FILE__, __LINE__,
- _setlocale_debug_string(LC_NUMERIC, NULL, newnum)));
- }
- else
-#endif
- newnum = RETVAL;
- new_numeric(newnum);
- }
-#endif /* USE_LOCALE_NUMERIC */
- }
+ RETVAL = retval;
OUTPUT:
RETVAL
@@ -2297,7 +2311,11 @@ 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 */
@@ -2592,7 +2610,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;
}
@@ -2603,7 +2626,13 @@ 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
@@ -2612,7 +2641,13 @@ 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
@@ -2621,8 +2656,14 @@ 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
@@ -2630,7 +2671,13 @@ 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
@@ -2656,7 +2703,11 @@ copysign(x,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
@@ -2850,9 +2901,14 @@ nan(payload = 0)
}
#elif defined(c99_nan)
{
- STRLEN elen = my_snprintf(PL_efloatbuf, PL_efloatsize, "%g", nv);
+ 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);
}
@@ -2870,7 +2926,11 @@ jn(x,y)
ALIAS:
yn = 1
CODE:
+#ifdef NV_NAN
RETVAL = NV_NAN;
+#else
+ RETVAL = 0;
+#endif
switch (ix) {
case 0:
#ifdef bessel_jn
@@ -2928,7 +2988,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))
@@ -3241,39 +3301,30 @@ write(fd, buffer, nbytes)
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()
+#ifdef I_WCHAR
+# include <wchar.h>
+#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)
@@ -3286,6 +3337,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)
@@ -3313,6 +3379,7 @@ strtod(str)
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);
@@ -3321,7 +3388,6 @@ strtod(str)
else
PUSHs(&PL_sv_undef);
}
- RESTORE_LC_NUMERIC_STANDARD();
#ifdef HAS_STRTOLD
@@ -3335,6 +3401,7 @@ strtold(str)
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);
@@ -3343,7 +3410,6 @@ strtold(str)
else
PUSHs(&PL_sv_undef);
}
- RESTORE_LC_NUMERIC_STANDARD();
#endif
@@ -3385,7 +3451,7 @@ strtoul(str, base = 0)
int base
PREINIT:
unsigned long num;
- char *unparsed;
+ char *unparsed = NULL;
PPCODE:
PERL_UNUSED_VAR(str);
PERL_UNUSED_VAR(base);
@@ -3520,7 +3586,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 {
@@ -3578,18 +3644,22 @@ 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_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, buf + len,
+ TRUE) /* Means assume UTF-8 */
#endif
)) {
SvUTF8_on(sv);
diff --git a/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pm b/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pm
index 9731dc9a1af..ae33cad9924 100644
--- a/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pm
+++ b/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pm
@@ -4,7 +4,7 @@ use warnings;
our ($AUTOLOAD, %SIGRT);
-our $VERSION = '1.65_01';
+our $VERSION = '1.84';
require XSLoader;
@@ -18,24 +18,13 @@ use Fcntl qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD
my $loaded;
-sub import {
- my $pkg = shift;
-
- load_imports() unless $loaded++;
-
- # Grandfather old foo_h form to new :foo_h form
- s/^(?=\w+_h$)/:/ for my @list = @_;
-
- local $Exporter::ExportLevel = 1;
- Exporter::import($pkg,@list);
-}
-
sub croak { require Carp; goto &Carp::croak }
sub usage { croak "Usage: POSIX::$_[0]" }
XSLoader::load();
my %replacement = (
+ L_tmpnam => undef,
atexit => 'END {}',
atof => undef,
atoi => undef,
@@ -110,6 +99,7 @@ my %replacement = (
strspn => undef,
strtok => undef,
tmpfile => 'IO::File::new_tmpfile',
+ tmpnam => 'use File::Temp',
ungetc => 'IO::Handle::ungetc',
vfprintf => undef,
vprintf => undef,
@@ -117,74 +107,103 @@ my %replacement = (
);
my %reimpl = (
+ abs => 'x => CORE::abs($_[0])',
+ alarm => 'seconds => CORE::alarm($_[0])',
assert => 'expr => croak "Assertion failed" if !$_[0]',
- tolower => 'string => lc($_[0])',
- toupper => 'string => uc($_[0])',
- closedir => 'dirhandle => CORE::closedir($_[0])',
- opendir => 'directory => my $dh; CORE::opendir($dh, $_[0]) ? $dh : undef',
- readdir => 'dirhandle => CORE::readdir($_[0])',
- rewinddir => 'dirhandle => CORE::rewinddir($_[0])',
- errno => '$! + 0',
- creat => 'filename, mode => &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1])',
- fcntl => 'filehandle, cmd, arg => CORE::fcntl($_[0], $_[1], $_[2])',
- getgrgid => 'gid => CORE::getgrgid($_[0])',
- getgrnam => 'name => CORE::getgrnam($_[0])',
atan2 => 'x, y => CORE::atan2($_[0], $_[1])',
+ chdir => 'directory => CORE::chdir($_[0])',
+ chmod => 'mode, filename => CORE::chmod($_[0], $_[1])',
+ chown => 'uid, gid, filename => CORE::chown($_[0], $_[1], $_[2])',
+ closedir => 'dirhandle => CORE::closedir($_[0])',
cos => 'x => CORE::cos($_[0])',
+ creat => 'filename, mode => &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1])',
+ errno => '$! + 0',
+ exit => 'status => CORE::exit($_[0])',
exp => 'x => CORE::exp($_[0])',
fabs => 'x => CORE::abs($_[0])',
- log => 'x => CORE::log($_[0])',
- pow => 'x, exponent => $_[0] ** $_[1]',
- sin => 'x => CORE::sin($_[0])',
- sqrt => 'x => CORE::sqrt($_[0])',
- getpwnam => 'name => CORE::getpwnam($_[0])',
- getpwuid => 'uid => CORE::getpwuid($_[0])',
- kill => 'pid, sig => CORE::kill $_[1], $_[0]',
- raise => 'sig => CORE::kill $_[0], $$; # Is this good enough',
+ fcntl => 'filehandle, cmd, arg => CORE::fcntl($_[0], $_[1], $_[2])',
+ fork => 'CORE::fork',
+ fstat => 'fd => CORE::open my $dup, "<&", $_[0]; CORE::stat($dup)', # Gross.
getc => 'handle => CORE::getc($_[0])',
getchar => 'CORE::getc(STDIN)',
- gets => 'scalar <STDIN>',
- remove => 'filename => (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0])',
- rename => 'oldfilename, newfilename => CORE::rename($_[0], $_[1])',
- rewind => 'filehandle => CORE::seek($_[0],0,0)',
- abs => 'x => CORE::abs($_[0])',
- exit => 'status => CORE::exit($_[0])',
- getenv => 'name => $ENV{$_[0]}',
- system => 'command => CORE::system($_[0])',
- strerror => 'errno => BEGIN { local $!; require locale; locale->import} my $e = $_[0] + 0; local $!; $! = $e; "$!"',
- strstr => 'big, little => CORE::index($_[0], $_[1])',
- chmod => 'mode, filename => CORE::chmod($_[0], $_[1])',
- fstat => 'fd => CORE::open my $dup, "<&", $_[0]; CORE::stat($dup)', # Gross.
- mkdir => 'directoryname, mode => CORE::mkdir($_[0], $_[1])',
- stat => 'filename => CORE::stat($_[0])',
- umask => 'mask => CORE::umask($_[0])',
- wait => 'CORE::wait()',
- waitpid => 'pid, options => CORE::waitpid($_[0], $_[1])',
- gmtime => 'time => CORE::gmtime($_[0])',
- localtime => 'time => CORE::localtime($_[0])',
- time => 'CORE::time',
- alarm => 'seconds => CORE::alarm($_[0])',
- chdir => 'directory => CORE::chdir($_[0])',
- chown => 'uid, gid, filename => CORE::chown($_[0], $_[1], $_[2])',
- fork => 'CORE::fork',
getegid => '$) + 0',
+ getenv => 'name => $ENV{$_[0]}',
geteuid => '$> + 0',
getgid => '$( + 0',
+ getgrgid => 'gid => CORE::getgrgid($_[0])',
+ getgrnam => 'name => CORE::getgrnam($_[0])',
getgroups => 'my %seen; grep !$seen{$_}++, split " ", $)',
getlogin => 'CORE::getlogin()',
getpgrp => 'CORE::getpgrp',
getpid => '$$',
getppid => 'CORE::getppid',
+ getpwnam => 'name => CORE::getpwnam($_[0])',
+ getpwuid => 'uid => CORE::getpwuid($_[0])',
+ gets => 'scalar <STDIN>',
getuid => '$<',
+ gmtime => 'time => CORE::gmtime($_[0])',
isatty => 'filehandle => -t $_[0]',
+ kill => 'pid, sig => CORE::kill $_[1], $_[0]',
link => 'oldfilename, newfilename => CORE::link($_[0], $_[1])',
+ localtime => 'time => CORE::localtime($_[0])',
+ log => 'x => CORE::log($_[0])',
+ mkdir => 'directoryname, mode => CORE::mkdir($_[0], $_[1])',
+ opendir => 'directory => my $dh; CORE::opendir($dh, $_[0]) ? $dh : undef',
+ pow => 'x, exponent => $_[0] ** $_[1]',
+ raise => 'sig => CORE::kill $_[0], $$; # Is this good enough',
+ readdir => 'dirhandle => CORE::readdir($_[0])',
+ remove => 'filename => (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0])',
+ rename => 'oldfilename, newfilename => CORE::rename($_[0], $_[1])',
+ rewind => 'filehandle => CORE::seek($_[0],0,0)',
+ rewinddir => 'dirhandle => CORE::rewinddir($_[0])',
rmdir => 'directoryname => CORE::rmdir($_[0])',
+ sin => 'x => CORE::sin($_[0])',
+ sqrt => 'x => CORE::sqrt($_[0])',
+ stat => 'filename => CORE::stat($_[0])',
+ strerror => 'errno => BEGIN { local $!; require locale; locale->import} my $e = $_[0] + 0; local $!; $! = $e; "$!"',
+ strstr => 'big, little => CORE::index($_[0], $_[1])',
+ system => 'command => CORE::system($_[0])',
+ time => 'CORE::time',
+ umask => 'mask => CORE::umask($_[0])',
unlink => 'filename => CORE::unlink($_[0])',
utime => 'filename, atime, mtime => CORE::utime($_[1], $_[2], $_[0])',
+ wait => 'CORE::wait()',
+ waitpid => 'pid, options => CORE::waitpid($_[0], $_[1])',
);
+sub import {
+ my $pkg = shift;
+
+ load_imports() unless $loaded++;
+
+ # Grandfather old foo_h form to new :foo_h form
+ s/^(?=\w+_h$)/:/ for my @list = @_;
+
+ my @unimpl = sort grep { exists $replacement{$_} } @list;
+ if (@unimpl) {
+ for my $u (@unimpl) {
+ warn "Unimplemented: POSIX::$u(): ", unimplemented_message($u);
+ }
+ croak(sprintf("Unimplemented: %s",
+ join(" ", map { "POSIX::$_()" } @unimpl)));
+ }
+
+ local $Exporter::ExportLevel = 1;
+ Exporter::import($pkg,@list);
+}
+
eval join ';', map "sub $_", keys %replacement, keys %reimpl;
+sub unimplemented_message {
+ my $func = shift;
+ my $how = $replacement{$func};
+ return "C-specific, stopped" unless defined $how;
+ return "$$how" if ref $how;
+ return "$how instead" if $how =~ /^use /;
+ return "Use method $how() instead" if $how =~ /::/;
+ return "C-specific: use $how instead";
+}
+
sub AUTOLOAD {
my ($func) = ($AUTOLOAD =~ /.*::(.*)/);
@@ -207,12 +226,7 @@ sub AUTOLOAD {
goto &$AUTOLOAD;
}
if (exists $replacement{$func}) {
- my $how = $replacement{$func};
- croak "Unimplemented: POSIX::$func() is C-specific, stopped"
- unless defined $how;
- croak "Unimplemented: POSIX::$func() is $$how" if ref $how;
- croak "Use method $how() instead of POSIX::$func()" if $how =~ /::/;
- croak "Unimplemented: POSIX::$func() is C-specific: use $how instead";
+ croak "Unimplemented: POSIX::$func(): ", unimplemented_message($func);
}
constant($func);
@@ -238,8 +252,7 @@ my %default_export_tags = ( # cf. exports policy below
assert_h => [qw(assert NDEBUG)],
- ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower
- isprint ispunct isspace isupper isxdigit tolower toupper)],
+ ctype_h => [],
dirent_h => [],
@@ -293,7 +306,8 @@ my %default_export_tags = ( # cf. exports policy below
_POSIX_STREAM_MAX _POSIX_TZNAME_MAX)],
locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES
- LC_MONETARY LC_NUMERIC LC_TIME NULL
+ LC_MONETARY LC_NUMERIC LC_TIME LC_IDENTIFICATION
+ LC_MEASUREMENT LC_PAPER LC_TELEPHONE LC_ADDRESS NULL
localeconv setlocale)],
math_h => [qw(FP_ILOGB0 FP_ILOGBNAN FP_INFINITE FP_NAN FP_NORMAL
@@ -322,7 +336,7 @@ my %default_export_tags = ( # cf. exports policy below
stddef_h => [qw(NULL offsetof)],
stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid
- L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET
+ NULL SEEK_CUR SEEK_END SEEK_SET
STREAM_MAX TMP_MAX stderr stdin stdout
clearerr fclose fdopen feof ferror fflush fgetc fgetpos
fgets fopen fprintf fputc fputs fread freopen
@@ -413,12 +427,23 @@ my %other_export_tags = ( # cf. exports policy below
Inf NaN acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim fma
fmax fmin fpclassify hypot ilogb isfinite isgreater isgreaterequal
isinf isless islessequal islessgreater isnan isnormal isunordered j0 j1
- jn lgamma log1p log2 logb lrint nan nearbyint nextafter nexttoward
+ jn lgamma log1p log2 logb lrint lround nan nearbyint nextafter nexttoward
remainder remquo rint round scalbn signbit tgamma trunc y0 y1 yn
)],
+ netdb_h => [qw(EAI_AGAIN EAI_BADFLAGS EAI_FAIL
+ EAI_FAMILY EAI_MEMORY EAI_NONAME
+ EAI_OVERFLOW EAI_SERVICE EAI_SOCKTYPE
+ EAI_SYSTEM)],
+
stdlib_h_c99 => [ @{$default_export_tags{stdlib_h}}, 'strtold' ],
+ sys_resource_h => [qw(PRIO_PROCESS PRIO_PGRP PRIO_USER)],
+
+ sys_socket_h => [qw(
+ MSG_CTRUNC MSG_DONTROUTE MSG_EOR MSG_OOB MSG_PEEK MSG_TRUNC MSG_WAITALL
+ )],
+
nan_payload => [ qw(getpayload setpayload setpayloadsig issignaling) ],
signal_h_si_code => [qw(
@@ -450,10 +475,7 @@ my %other_export_tags = ( # cf. exports policy below
# you do not want to add symbols to the following list. add a new tag instead
our @EXPORT_OK = (qw(close lchown nice open pipe read sleep times write
- printf sprintf lround),
- # lround() should really be in the :math_h_c99 tag, but
- # we're too far into the 5.24 code freeze for that to be
- # done now. This can be revisited in the 5.25.x cycle.
+ printf sprintf),
grep {!exists $export{$_}} keys %reimpl, keys %replacement, keys %export_ok);
our %EXPORT_TAGS = ( %default_export_tags, %other_export_tags );
diff --git a/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pod b/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pod
index 1d263a7bc40..a319b0df3a3 100644
--- a/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pod
+++ b/gnu/usr.bin/perl/ext/POSIX/lib/POSIX.pod
@@ -24,7 +24,7 @@ interfaces.
This document gives a condensed list of the features available in the POSIX
module. Consult your operating system's manpages for general information on
most features. Consult L<perlfunc> for functions which are noted as being
-identical to Perl's builtin functions.
+identical or almost identical to Perl's builtin functions.
The first section describes POSIX functions from the 1003.1 specification.
The second section describes some classes for signal objects, TTY objects,
@@ -81,8 +81,13 @@ if the handler does not return normally (it e.g. does a C<longjmp>).
=item C<abs>
-This is identical to Perl's builtin C<abs()> function, returning
-the absolute value of its numerical argument.
+This is identical to Perl's builtin C<abs()> function, returning the absolute
+value of its numerical argument (except that C<POSIX::abs()> must be provided
+an explicit value (rather than relying on an implicit C<$_>):
+
+ $absolute_value = POSIX::abs(42); # good
+
+ $absolute_value = POSIX::abs(); # throws exception
=item C<access>
@@ -110,8 +115,13 @@ L<Math::Trig>.
=item C<alarm>
-This is identical to Perl's builtin C<alarm()> function,
-either for arming or disarming the C<SIGARLM> timer.
+This is identical to Perl's builtin C<alarm()> function, either for arming or
+disarming the C<SIGARLM> timer, except that C<POSIX::alarm()> must be provided
+an explicit value (rather than relying on an implicit C<$_>):
+
+ POSIX::alarm(3) # good
+
+ POSIX::alarm() # throws exception
=item C<asctime>
@@ -203,13 +213,27 @@ integer value greater than or equal to the given numerical argument.
=item C<chdir>
-This is identical to Perl's builtin C<chdir()> function, allowing
-one to change the working (default) directory, see L<perlfunc/chdir>.
+This is identical to Perl's builtin C<chdir()> function, allowing one to
+change the working (default) directory -- see L<perlfunc/chdir> -- with the
+exception that C<POSIX::chdir()> must be provided an explicit value (rather
+than relying on an implicit C<$_>):
+
+ $rv = POSIX::chdir('path/to/dir'); # good
+
+ $rv = POSIX::chdir(); # throws exception
=item C<chmod>
This is identical to Perl's builtin C<chmod()> function, allowing
-one to change file and directory permissions, see L<perlfunc/chmod>.
+one to change file and directory permissions -- see L<perlfunc/chmod> -- with
+the exception that C<POSIX::chmod()> can only change one file at a time
+(rather than a list of files):
+
+ $c = chmod 0664, $file1, $file2; # good
+
+ $c = POSIX::chmod 0664, $file1; # throws exception
+
+ $c = POSIX::chmod 0664, $file1, $file2; # throws exception
=item C<chown>
@@ -915,6 +939,14 @@ containing the current underlying locale's formatting values. Users of this fun
should also read L<perllocale>, which provides a comprehensive
discussion of Perl locale handling, including
L<a section devoted to this function|perllocale/The localeconv function>.
+Prior to Perl 5.28, or when operating in a non thread-safe environment,
+it should not be used in a threaded application unless it's certain that
+the underlying locale is C or POSIX. This is because it otherwise
+changes the locale, which globally affects all threads simultaneously.
+Windows platforms starting with Visual Studio 2005 are mostly
+thread-safe, but use of this function in those prior to Visual Studio
+2015 can interefere with a thread that has called
+L<perlapi/switch_to_global_locale>.
Here is how to query the database for the B<de> (Deutsch or German) locale.
@@ -958,7 +990,15 @@ POSIX.1-2008 and are only available on systems that support them.
=item C<localtime>
This is identical to Perl's builtin C<localtime()> function for
-converting seconds since the epoch to a date see L<perlfunc/localtime>.
+converting seconds since the epoch to a date see L<perlfunc/localtime> except
+that C<POSIX::localtime()> must be provided an explicit value (rather than
+relying on an implicit C<$_>):
+
+ @localtime = POSIX::localtime(time); # good
+
+ @localtime = localtime(); # good
+
+ @localtime = POSIX::localtime(); # throws exception
=item C<log>
@@ -1013,7 +1053,7 @@ See also L</ceil>, L</floor>, L</trunc>.
Owing to an oversight, this is not currently exported by default, or as part of
the C<:math_h_c99> export tag; importing it must therefore be done by explicit
-name. This will be changed in Perl 5.26.
+name.
=item C<malloc>
@@ -1671,6 +1711,10 @@ for collating (comparing) strings transformed using
the C<strxfrm()> function. Not really needed since
Perl can do this transparently, see L<perllocale>.
+Beware that in a UTF-8 locale, anything you pass to this function must
+be in UTF-8; and when not in a UTF-8 locale, anything passed must not be
+UTF-8 encoded.
+
=item C<strcpy>
Not implemented. C<strcpy()> is C-specific, use C<=> instead, see L<perlop>.
@@ -1768,7 +1812,10 @@ may not check for overflow, and therefore will never set C<$!>.
C<strtod> respects any POSIX C<setlocale()> C<LC_TIME> settings,
regardless of whether or not it is called from Perl code that is within
-the scope of S<C<use locale>>.
+the scope of S<C<use locale>>. This means it should not be used in a
+threaded application unless it's certain that the underlying locale is C
+or POSIX. This is because it otherwise changes the locale, which
+globally affects all threads simultaneously.
To parse a string C<$str> as a floating point number use
@@ -1843,6 +1890,10 @@ Used in conjunction with the C<strcoll()> function, see L</strcoll>.
Not really needed since Perl can do this transparently, see
L<perllocale>.
+Beware that in a UTF-8 locale, anything you pass to this function must
+be in UTF-8; and when not in a UTF-8 locale, anything passed must not be
+UTF-8 encoded.
+
=item C<sysconf>
Retrieves values of system configurable variables.
@@ -1941,13 +1992,9 @@ Not implemented. Use method C<IO::File::new_tmpfile()> instead, or see L<File::
=item C<tmpnam>
-Returns a name for a temporary file.
-
- $tmpfile = POSIX::tmpnam();
-
For security reasons, which are probably detailed in your system's
documentation for the C library C<tmpnam()> function, this interface
-should not be used; instead see L<File::Temp>.
+is no longer available; instead use L<File::Temp>.
=item C<tolower>
@@ -2429,6 +2476,18 @@ C<_POSIX_TZNAME_MAX> C<_POSIX_VDISABLE> C<_POSIX_VERSION>
=back
+=head1 RESOURCE CONSTANTS
+
+Imported with the C<:sys_resource_h> tag.
+
+=over 8
+
+=item Constants
+
+C<PRIO_PROCESS> C<PRIO_PGRP> C<PRIO_USER>
+
+=back
+
=head1 SYSTEM CONFIGURATION
=over 8
@@ -2589,7 +2648,7 @@ C<EXIT_FAILURE> C<EXIT_SUCCESS> C<MB_CUR_MAX> C<RAND_MAX>
=item Constants
-C<BUFSIZ> C<EOF> C<FILENAME_MAX> C<L_ctermid> C<L_cuserid> C<L_tmpname> C<TMP_MAX>
+C<BUFSIZ> C<EOF> C<FILENAME_MAX> C<L_ctermid> C<L_cuserid> C<TMP_MAX>
=back
diff --git a/gnu/usr.bin/perl/ext/POSIX/t/export.t b/gnu/usr.bin/perl/ext/POSIX/t/export.t
index 5c37f83a07b..50648c8b336 100644
--- a/gnu/usr.bin/perl/ext/POSIX/t/export.t
+++ b/gnu/usr.bin/perl/ext/POSIX/t/export.t
@@ -45,11 +45,13 @@ my %expect = (
FLT_ROUNDS F_DUPFD F_GETFD F_GETFL F_GETLK F_OK F_RDLCK
F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK HUGE_VAL
HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR INLCR INPCK
- INT_MAX INT_MIN ISIG ISTRIP IXOFF IXON LC_ALL LC_COLLATE
- LC_CTYPE LC_MESSAGES LC_MONETARY LC_NUMERIC LC_TIME LDBL_DIG
+ INT_MAX INT_MIN ISIG ISTRIP IXOFF IXON
+ LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION
+ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NUMERIC LC_PAPER
+ LC_TELEPHONE LC_TIME LDBL_DIG
LDBL_EPSILON LDBL_MANT_DIG LDBL_MAX LDBL_MAX_10_EXP
LDBL_MAX_EXP LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP LINK_MAX
- LONG_MAX LONG_MIN L_ctermid L_cuserid L_tmpname MAX_CANON
+ LONG_MAX LONG_MIN L_ctermid L_cuserid MAX_CANON
MAX_INPUT MB_CUR_MAX MB_LEN_MAX NAME_MAX NCCS NDEBUG
NGROUPS_MAX NOFLSH NULL OPEN_MAX OPOST O_ACCMODE O_APPEND
O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC
@@ -90,8 +92,7 @@ my %expect = (
fgets floor fmod fopen fpathconf fprintf fputc fputs fread
free freopen frexp fscanf fseek fsetpos fstat fsync ftell
fwrite getchar getcwd getegid getenv geteuid getgid getgroups
- getpid gets getuid isalnum isalpha isatty iscntrl isdigit
- isgraph islower isprint ispunct isspace isupper isxdigit labs
+ getpid gets getuid isatty labs
ldexp ldiv localeconv log10 longjmp lseek malloc mblen
mbstowcs mbtowc memchr memcmp memcpy memmove memset mkfifo
mktime modf offsetof pathconf pause perror pow putc putchar
@@ -103,7 +104,7 @@ my %expect = (
strncpy strpbrk strrchr strspn strstr strtod strtok strtol
strtoul strxfrm sysconf tan tanh tcdrain tcflow tcflush
tcgetattr tcgetpgrp tcsendbreak tcsetattr tcsetpgrp tmpfile
- tmpnam tolower toupper ttyname tzname tzset uname ungetc
+ tmpnam ttyname tzname tzset uname ungetc
vfprintf vprintf vsprintf wcstombs wctomb
),
# this stuff was added in 5.21
@@ -130,6 +131,16 @@ my %expect = (
# it is OK to add new constants, but new functions may only go in EXPORT_OK
],
EXPORT_OK => [sort
+ # this stuff was added in 5.9, but not exported until 5.25
+ qw(
+ MSG_CTRUNC MSG_DONTROUTE MSG_EOR MSG_OOB MSG_PEEK
+ MSG_TRUNC MSG_WAITALL
+ ),
+ # this stuff was added in 5.11, but not exported until 5.25
+ qw(
+ EAI_AGAIN EAI_BADFLAGS EAI_FAIL EAI_FAMILY EAI_MEMORY
+ EAI_NONAME EAI_OVERFLOW EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM
+ ),
# this stuff was in 5.20.2
qw(
abs alarm atan2 chdir chmod chown close closedir cos exit
@@ -138,9 +149,12 @@ my %expect = (
localtime log mkdir nice open opendir pipe printf rand
read readdir rename rewinddir rmdir sin sleep sprintf sqrt
srand stat system time times umask unlink utime wait
- waitpid write
+ waitpid write L_tmpnam
),
# this stuff was added in 5.21
+ # (though an oversight meant that lround wasn't listed here
+ # initially; it was added to @EXPORT_OK in 5.23, and to the
+ # :math_h_c99 tag in 5.25)
qw(
FE_DOWNWARD FE_TONEAREST FE_TOWARDZERO FE_UPWARD
fegetround fesetround
@@ -148,7 +162,7 @@ my %expect = (
acosh asinh atanh cbrt copysign erf erfc exp2 expm1 fdim
fma fmax fmin fpclassify hypot ilogb isfinite isgreater
isgreaterequal isinf isless islessequal islessgreater isnan
- isnormal isunordered j0 j1 jn lgamma log1p log2 logb lrint nan
+ isnormal isunordered j0 j1 jn lgamma log1p log2 logb lrint lround nan
nearbyint nextafter nexttoward remainder remquo rint round scalbn
signbit tgamma trunc y0 y1 yn strtold
),
@@ -166,14 +180,14 @@ my %expect = (
POLL_IN POLL_OUT POLL_MSG POLL_ERR POLL_PRI POLL_HUP
SI_USER SI_QUEUE SI_TIMER SI_ASYNCIO SI_MESGQ
),
- # this was implemented in 5.21, but not exported; it was added to
- # @EXPORT_OK late in 5.23, and will be added to :math_h_c99 tag early
- # in 5.25
- qw( lround ),
+ # added in 5.27
+ qw(
+ PRIO_PROCESS PRIO_PGRP PRIO_USER
+ ),
],
);
-plan (tests => 2 * keys %expect);
+plan (tests => 2 * keys(%expect) + keys(%POSIX::));
while (my ($var, $expect) = each %expect) {
my $have = *{$POSIX::{$var}}{ARRAY};
@@ -181,3 +195,23 @@ while (my ($var, $expect) = each %expect) {
"Correct number of entries for \@POSIX::$var");
is_deeply([sort @$have], $expect, "Correct entries for \@POSIX::$var");
}
+
+my %no_export_needed = map +($_ => 1),
+ qw(AUTOLOAD bootstrap constant croak import load_imports
+ unimplemented_message usage);
+
+my %exported = map +($_ => 1),
+ (@POSIX::EXPORT, @POSIX::EXPORT_OK, map @$_, values %POSIX::EXPORT_TAGS);
+
+for my $name (sort keys %POSIX::) {
+ my $code = do { no strict 'refs'; \&{"POSIX::$name"} };
+ if (!defined &$code) {
+ pass("$name need not be exported as it does not name a subroutine");
+ }
+ elsif ($no_export_needed{$name}) {
+ pass("$name need not be exported as it is part of the internals");
+ }
+ else {
+ ok($exported{$name}, "subroutine POSIX::$name is exported somehow");
+ }
+}
diff --git a/gnu/usr.bin/perl/ext/POSIX/t/math.t b/gnu/usr.bin/perl/ext/POSIX/t/math.t
index 54067d1f02d..0426e03ae18 100644
--- a/gnu/usr.bin/perl/ext/POSIX/t/math.t
+++ b/gnu/usr.bin/perl/ext/POSIX/t/math.t
@@ -4,7 +4,6 @@ use strict;
use POSIX ':math_h_c99';
use POSIX ':nan_payload';
-use POSIX 'lround';
use Test::More;
use Config;
@@ -60,8 +59,14 @@ SKIP: {
skip "no fpclassify", 4 unless $Config{d_fpclassify};
is(fpclassify(1), FP_NORMAL, "fpclassify 1");
is(fpclassify(0), FP_ZERO, "fpclassify 0");
- is(fpclassify(INFINITY), FP_INFINITE, "fpclassify INFINITY");
- is(fpclassify(NAN), FP_NAN, "fpclassify NAN");
+ SKIP: {
+ skip("no inf", 1) unless $Config{d_double_has_inf};
+ is(fpclassify(INFINITY), FP_INFINITE, "fpclassify INFINITY");
+ }
+ SKIP: {
+ skip("no nan", 1) unless $Config{d_double_has_nan};
+ is(fpclassify(NAN), FP_NAN, "fpclassify NAN");
+ }
}
sub near {
@@ -97,30 +102,42 @@ SKIP: {
is(ilogb(255), 7, "ilogb 255");
is(ilogb(256), 8, "ilogb 256");
ok(isfinite(1), "isfinite 1");
- ok(!isfinite(Inf), "isfinite Inf");
- ok(!isfinite(NaN), "isfinite NaN");
- ok(isinf(INFINITY), "isinf INFINITY");
- ok(isinf(Inf), "isinf Inf");
- ok(!isinf(NaN), "isinf NaN");
ok(!isinf(42), "isinf 42");
- ok(isnan(NAN), "isnan NAN");
- ok(isnan(NaN), "isnan NaN");
- ok(!isnan(Inf), "isnan Inf");
ok(!isnan(42), "isnan Inf");
- cmp_ok(nan(), '!=', nan(), 'nan');
+ SKIP: {
+ skip("no inf", 4) unless $Config{d_double_has_inf};
+ ok(!isfinite(Inf), "isfinite Inf");
+ ok(isinf(INFINITY), "isinf INFINITY");
+ ok(isinf(Inf), "isinf Inf");
+ ok(!isnan(Inf), "isnan Inf");
+ }
+ SKIP: {
+ skip("no nan", 5) unless $Config{d_double_has_nan};
+ ok(!isfinite(NaN), "isfinite NaN");
+ ok(!isinf(NaN), "isinf NaN");
+ ok(isnan(NAN), "isnan NAN");
+ ok(isnan(NaN), "isnan NaN");
+ cmp_ok(nan(), '!=', nan(), 'nan');
+ }
near(log1p(2), 1.09861228866811, "log1p", 1e-9);
near(log1p(1e-6), 9.99999500000333e-07, "log1p", 1e-9);
near(log2(8), 3, "log2", 1e-9);
is(signbit(2), 0, "signbit 2"); # zero
ok(signbit(-2), "signbit -2"); # non-zero
+ is(signbit(0), 0, "signbit 0"); # zero
+ is(signbit(0.5), 0, "signbit 0.5"); # zero
+ ok(signbit(-0.5), "signbit -0.5"); # non-zero
is(round(2.25), 2, "round 2.25");
is(round(-2.25), -2, "round -2.25");
is(round(2.5), 3, "round 2.5");
is(round(-2.5), -3, "round -2.5");
is(round(2.75), 3, "round 2.75");
is(round(-2.75), -3, "round 2.75");
- is(lround(-2.75), -3, "lround -0.25");
- is(signbit(lround(-0.25)), 0, "lround -0.25 -> +0"); # unlike round()
+ is(lround(-2.75), -3, "lround -2.75");
+ is(lround(-0.25), 0, "lround -0.25");
+ is(lround(-0.50), -1, "lround -0.50");
+ is(signbit(lround(-0.25)), 0, "signbit lround -0.25 zero");
+ ok(signbit(lround(-0.50)), "signbit lround -0.50 non-zero"); # non-zero
is(trunc(2.25), 2, "trunc 2.25");
is(trunc(-2.25), -2, "trunc -2.25");
is(trunc(2.5), 2, "trunc 2.5");
@@ -130,10 +147,14 @@ SKIP: {
ok(isless(1, 2), "isless 1 2");
ok(!isless(2, 1), "isless 2 1");
ok(!isless(1, 1), "isless 1 1");
- ok(!isless(1, NaN), "isless 1 NaN");
ok(isgreater(2, 1), "isgreater 2 1");
ok(islessequal(1, 1), "islessequal 1 1");
- ok(isunordered(1, NaN), "isunordered 1 NaN");
+
+ SKIP: {
+ skip("no nan", 2) unless $Config{d_double_has_nan};
+ ok(!isless(1, NaN), "isless 1 NaN");
+ ok(isunordered(1, NaN), "isunordered 1 NaN");
+ }
near(erf(0.5), 0.520499877813047, "erf 0.5", 1.5e-7);
near(erf(1), 0.842700792949715, "erf 1", 1.5e-7);
@@ -151,66 +172,70 @@ SKIP: {
near(lgamma(5.5), 3.95781396761872, "lgamma 5.5", 1.5e-7);
near(lgamma(9), 10.6046029027452, "lgamma 9", 1.5e-7);
- # These don't work on old mips/hppa platforms because == Inf (or == -Inf).
- # ok(isnan(setpayload(0)), "setpayload zero");
- # is(getpayload(setpayload(0)), 0, "setpayload + getpayload (zero)");
- #
- # These don't work on most platforms because == Inf (or == -Inf).
- # ok(isnan(setpayloadsig(0)), "setpayload zero");
- # is(getpayload(setpayloadsig(0)), 0, "setpayload + getpayload (zero)");
-
- # Verify that the payload set be setpayload()
- # (1) still is a nan
- # (2) but the payload can be retrieved
- # (3) but is not signaling
- my $x = 0;
- setpayload($x, 0x12345);
- ok(isnan($x), "setpayload + isnan");
- is(getpayload($x), 0x12345, "setpayload + getpayload");
- ok(!issignaling($x), "setpayload + issignaling");
-
- # Verify that the signaling payload set be setpayloadsig()
- # (1) still is a nan
- # (2) but the payload can be retrieved
- # (3) and is signaling
- setpayloadsig($x, 0x12345);
- ok(isnan($x), "setpayloadsig + isnan");
- is(getpayload($x), 0x12345, "setpayloadsig + getpayload");
SKIP: {
- # https://rt.perl.org/Ticket/Display.html?id=125710
- # In the 32-bit x86 ABI cannot preserve the signaling bit
- # (the x87 simply does not preserve that). But using the
- # 80-bit extended format aka long double, the bit is preserved.
- # https://gcc.gnu.org/bugzilla/show_bug.cgi?id=57484
- my $could_be_x86_32 =
- # This is a really weak test: there are other 32-bit
- # little-endian platforms than just Intel (some embedded
- # processors, for example), but we use this just for not
- # bothering with the test if things look iffy.
- # We could, say, $Config{ccsymbols} =~ /\b__[xi][3-7]86=1\b/,
- # but that feels quite shaky.
- $Config{byteorder} =~ /1234/ &&
- $Config{longdblkind} == 3 &&
- $Config{ptrsize} == 4;
- skip($^O, 1) if $could_be_x86_32 && !$Config{uselongdouble};
- ok(issignaling($x), "setpayloadsig + issignaling");
- }
+ skip("no inf/nan", 19) unless $Config{d_double_has_inf} && $Config{d_double_has_nan};
- # Try a payload more than one byte.
- is(getpayload(nan(0x12345)), 0x12345, "nan + getpayload");
+ # These don't work on old mips/hppa platforms
+ # because nan with payload zero == Inf (or == -Inf).
+ # ok(isnan(setpayload(0)), "setpayload zero");
+ # is(getpayload(setpayload(0)), 0, "setpayload + getpayload (zero)");
+ #
+ # These don't work on most platforms because == Inf (or == -Inf).
+ # ok(isnan(setpayloadsig(0)), "setpayload zero");
+ # is(getpayload(setpayloadsig(0)), 0, "setpayload + getpayload (zero)");
- # Try payloads of 2^k, most importantly at and beyond 2^32. These
- # tests will fail if NV is just 32-bit float, but that Should Not
- # Happen (tm).
- is(getpayload(nan(2**31)), 2**31, "nan + getpayload 2**31");
- is(getpayload(nan(2**32)), 2**32, "nan + getpayload 2**32");
- is(getpayload(nan(2**33)), 2**33, "nan + getpayload 2**33");
+ # Verify that the payload set be setpayload()
+ # (1) still is a nan
+ # (2) but the payload can be retrieved
+ # (3) but is not signaling
+ my $x = 0;
+ setpayload($x, 0x12345);
+ ok(isnan($x), "setpayload + isnan");
+ is(getpayload($x), 0x12345, "setpayload + getpayload");
+ ok(!issignaling($x), "setpayload + issignaling");
+
+ # Verify that the signaling payload set be setpayloadsig()
+ # (1) still is a nan
+ # (2) but the payload can be retrieved
+ # (3) and is signaling
+ setpayloadsig($x, 0x12345);
+ ok(isnan($x), "setpayloadsig + isnan");
+ is(getpayload($x), 0x12345, "setpayloadsig + getpayload");
+ SKIP: {
+ # https://rt.perl.org/Ticket/Display.html?id=125710
+ # In the 32-bit x86 ABI cannot preserve the signaling bit
+ # (the x87 simply does not preserve that). But using the
+ # 80-bit extended format aka long double, the bit is preserved.
+ # https://gcc.gnu.org/bugzilla/show_bug.cgi?id=57484
+ my $could_be_x86_32 =
+ # This is a really weak test: there are other 32-bit
+ # little-endian platforms than just Intel (some embedded
+ # processors, for example), but we use this just for not
+ # bothering with the test if things look iffy.
+ # We could, say, $Config{ccsymbols} =~ /\b__[xi][3-7]86=1\b/,
+ # but that feels quite shaky.
+ $Config{byteorder} =~ /1234/ &&
+ $Config{longdblkind} == 3 &&
+ $Config{ptrsize} == 4;
+ skip($^O, 1) if $could_be_x86_32 && !$Config{uselongdouble};
+ ok(issignaling($x), "setpayloadsig + issignaling");
+ }
- # Payloads just lower than 2^k.
- is(getpayload(nan(2**31-1)), 2**31-1, "nan + getpayload 2**31-1");
- is(getpayload(nan(2**32-1)), 2**32-1, "nan + getpayload 2**32-1");
+ # Try a payload more than one byte.
+ is(getpayload(nan(0x12345)), 0x12345, "nan + getpayload");
- # Payloads not divisible by two (and larger than 2**32).
+ # Try payloads of 2^k, most importantly at and beyond 2^32. These
+ # tests will fail if NV is just 32-bit float, but that Should Not
+ # Happen (tm).
+ is(getpayload(nan(2**31)), 2**31, "nan + getpayload 2**31");
+ is(getpayload(nan(2**32)), 2**32, "nan + getpayload 2**32");
+ is(getpayload(nan(2**33)), 2**33, "nan + getpayload 2**33");
+
+ # Payloads just lower than 2^k.
+ is(getpayload(nan(2**31-1)), 2**31-1, "nan + getpayload 2**31-1");
+ is(getpayload(nan(2**32-1)), 2**32-1, "nan + getpayload 2**32-1");
+
+ # Payloads not divisible by two (and larger than 2**32).
SKIP: {
# solaris gets 10460353202 from getpayload() when it should
@@ -231,17 +256,18 @@ SKIP: {
# probably just by blind luck.
skip($^O, 1) if $^O eq 'solaris';
is(getpayload(nan(3**21)), 3**21, "nan + getpayload 3**21");
- }
- is(getpayload(nan(4294967311)), 4294967311, "nan + getpayload prime");
+ }
+ is(getpayload(nan(4294967311)), 4294967311, "nan + getpayload prime");
- # Truncates towards zero.
- is(getpayload(nan(1234.567)), 1234, "nan (trunc) + getpayload");
+ # Truncates towards zero.
+ is(getpayload(nan(1234.567)), 1234, "nan (trunc) + getpayload");
- # Not signaling.
- ok(!issignaling(0), "issignaling zero");
- ok(!issignaling(+Inf), "issignaling +Inf");
- ok(!issignaling(-Inf), "issignaling -Inf");
- ok(!issignaling(NaN), "issignaling NaN");
+ # Not signaling.
+ ok(!issignaling(0), "issignaling zero");
+ ok(!issignaling(+Inf), "issignaling +Inf");
+ ok(!issignaling(-Inf), "issignaling -Inf");
+ ok(!issignaling(NaN), "issignaling NaN");
+ }
} # SKIP
done_testing();
diff --git a/gnu/usr.bin/perl/ext/POSIX/t/posix.t b/gnu/usr.bin/perl/ext/POSIX/t/posix.t
index bd5c3009fcf..1b2dd4010b8 100644
--- a/gnu/usr.bin/perl/ext/POSIX/t/posix.t
+++ b/gnu/usr.bin/perl/ext/POSIX/t/posix.t
@@ -10,7 +10,7 @@ BEGIN {
require 'loc_tools.pl';
}
-use Test::More tests => 94;
+use Test::More tests => 93;
use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read strftime write
errno localeconv dup dup2 lseek access);
@@ -25,7 +25,6 @@ $| = 1;
$Is_W32 = $^O eq 'MSWin32';
$Is_Dos = $^O eq 'dos';
-$Is_MacOS = $^O eq 'MacOS';
$Is_VMS = $^O eq 'VMS';
$Is_OS2 = $^O eq 'os2';
$Is_UWin = $^O eq 'uwin';
@@ -91,55 +90,51 @@ SKIP: {
ok(! $sigset->ismember(1), 'POSIX::SigSet->delset' );
ok( $sigset->ismember(3), 'POSIX::SigSet->ismember' );
- SKIP: {
- skip("no kill() support on Mac OS", 4) if $Is_MacOS;
-
- my $sigint_called = 0;
-
- my $mask = new POSIX::SigSet &SIGINT;
- my $action = new POSIX::SigAction 'main::SigHUP', $mask, 0;
- sigaction(&SIGHUP, $action);
- $SIG{'INT'} = 'SigINT';
-
- # At least OpenBSD/i386 3.3 is okay, as is NetBSD 1.5.
- # But not NetBSD 1.6 & 1.6.1: the test makes perl crash.
- # So the kill() must not be done with this config in order to
- # finish the test.
- # For others (darwin & freebsd), let the test fail without crashing.
- # the test passes at least from freebsd 8.1
- my $todo = $^O eq 'netbsd' && $Config{osvers}=~/^1\.6/;
- my $why_todo = "# TODO $^O $Config{osvers} seems to lose blocked signals";
- if (!$todo) {
- kill 'HUP', $$;
- } else {
- print "not ok 9 - sigaction SIGHUP ",$why_todo,"\n";
- print "not ok 10 - sig mask delayed SIGINT ",$why_todo,"\n";
- }
- sleep 1;
-
- $todo = 1 if ($^O eq 'freebsd' && $Config{osvers} < 8)
- || ($^O eq 'darwin' && $Config{osvers} < '6.6');
- printf "%s 11 - masked SIGINT received %s\n",
- $sigint_called ? "ok" : "not ok",
- $todo ? $why_todo : '';
-
- print "ok 12 - signal masks successful\n";
-
- sub SigHUP {
- print "ok 9 - sigaction SIGHUP\n";
- kill 'INT', $$;
- sleep 2;
- print "ok 10 - sig mask delayed SIGINT\n";
- }
+ my $sigint_called = 0;
+
+ my $mask = new POSIX::SigSet &SIGINT;
+ my $action = new POSIX::SigAction 'main::SigHUP', $mask, 0;
+ sigaction(&SIGHUP, $action);
+ $SIG{'INT'} = 'SigINT';
+
+ # At least OpenBSD/i386 3.3 is okay, as is NetBSD 1.5.
+ # But not NetBSD 1.6 & 1.6.1: the test makes perl crash.
+ # So the kill() must not be done with this config in order to
+ # finish the test.
+ # For others (darwin & freebsd), let the test fail without crashing.
+ # the test passes at least from freebsd 8.1
+ my $todo = $^O eq 'netbsd' && $Config{osvers}=~/^1\.6/;
+ my $why_todo = "# TODO $^O $Config{osvers} seems to lose blocked signals";
+ if (!$todo) {
+ kill 'HUP', $$;
+ } else {
+ print "not ok 9 - sigaction SIGHUP ",$why_todo,"\n";
+ print "not ok 10 - sig mask delayed SIGINT ",$why_todo,"\n";
+ }
+ sleep 1;
- sub SigINT {
- $sigint_called++;
- }
+ $todo = 1 if ($^O eq 'freebsd' && $Config{osvers} < 8)
+ || ($^O eq 'darwin' && $Config{osvers} < '6.6');
+ printf "%s 11 - masked SIGINT received %s\n",
+ $sigint_called ? "ok" : "not ok",
+ $todo ? $why_todo : '';
- # The order of the above tests is very important, so
- # we use literal prints and hard coded numbers.
- next_test() for 1..4;
+ print "ok 12 - signal masks successful\n";
+
+ sub SigHUP {
+ print "ok 9 - sigaction SIGHUP\n";
+ kill 'INT', $$;
+ sleep 2;
+ print "ok 10 - sig mask delayed SIGINT\n";
+ }
+
+ sub SigINT {
+ $sigint_called++;
}
+
+ # The order of the above tests is very important, so
+ # we use literal prints and hard coded numbers.
+ next_test() for 1..4;
}
SKIP: {
@@ -155,7 +150,7 @@ if ( $unix_mode ) {
$pat = qr#[\\/]POSIX$#i;
}
else {
- $pat = qr/\.POSIX]/i;
+ $pat = qr/\.POSIX\]/i;
}
like( getcwd(), qr/$pat/, 'getcwd' );
@@ -283,11 +278,8 @@ try_strftime("Fri Mar 31 00:00:00 2000 091", 0,0,0, 31,2,100);
}
}
-SKIP: {
- skip("no kill() support on Mac OS", 1) if $Is_MacOS;
- is (eval "kill 0", 0, "check we have CORE::kill")
- or print "\$\@ is " . _qq($@) . "\n";
-}
+is (eval "kill 0", 0, "check we have CORE::kill")
+ or print "\$\@ is " . _qq($@) . "\n";
# Check that we can import the POSIX kill routine
POSIX->import ('kill');
@@ -299,13 +291,13 @@ like ($@, qr/^Usage: POSIX::kill\(pid, sig\)/, "check its usage message");
# Check unimplemented.
$result = eval {POSIX::offsetof};
is ($result, undef, "offsetof should fail");
-like ($@, qr/^Unimplemented: POSIX::offsetof\(\) is C-specific/,
+like ($@, qr/^Unimplemented: POSIX::offsetof\(\): C-specific/,
"check its unimplemented message");
# Check reimplemented.
$result = eval {POSIX::fgets};
is ($result, undef, "fgets should fail");
-like ($@, qr/^Use method IO::Handle::gets\(\) instead/,
+like ($@, qr/^Unimplemented: POSIX::fgets\(\): Use method IO::Handle::gets\(\) instead/,
"check its redef message");
eval { use strict; POSIX->import("S_ISBLK"); my $x = S_ISBLK };
@@ -402,19 +394,10 @@ SKIP: {
cmp_ok($!, '==', POSIX::ENOTDIR);
}
-{ # tmpnam() is deprecated
- my @warn;
- local $SIG{__WARN__} = sub { push @warn, "@_"; note "@_"; };
- my $x = sub { POSIX::tmpnam() };
- my $foo = $x->();
- $foo = $x->();
- is(@warn, 1, "POSIX::tmpnam() should warn only once per location");
- like($warn[0], qr!^Calling POSIX::tmpnam\(\) is deprecated at t/posix.t line \d+\.$!,
- "check POSIX::tmpnam warns by default");
- no warnings "deprecated";
- undef $warn;
- my $foo = POSIX::tmpnam();
- is($warn, undef, "... but the warning can be disabled");
+{ # tmpnam() has been removed as unsafe
+ my $x = eval { POSIX::tmpnam() };
+ is($x, undef, 'tmpnam has been removed');
+ like($@, qr/use File::Temp/, 'tmpnam advises File::Temp');
}
# Check that output is not flushed by _exit. This test should be last
@@ -424,7 +407,7 @@ if ($^O eq 'vos') {
} else {
$| = 0;
# The following line assumes buffered output, which may be not true:
- print '@#!*$@(!@#$' unless ($Is_MacOS || $Is_OS2 || $Is_UWin || $Is_OS390 ||
+ print '@#!*$@(!@#$' unless ($Is_OS2 || $Is_UWin || $Is_OS390 ||
$Is_VMS ||
(defined $ENV{PERLIO} &&
$ENV{PERLIO} eq 'unix' &&
diff --git a/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t b/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t
index b96812f3470..73c66f9404d 100644
--- a/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t
+++ b/gnu/usr.bin/perl/ext/POSIX/t/sigaction.t
@@ -5,7 +5,7 @@ BEGIN{
use Config;
eval 'use POSIX';
if($@ || $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'dos' ||
- $^O eq 'MacOS' || ($^O eq 'VMS' && !$Config{'d_sigaction'})) {
+ ($^O eq 'VMS' && !$Config{'d_sigaction'})) {
print "1..0\n";
exit 0;
}
@@ -14,7 +14,7 @@ BEGIN{
use Test::More tests => 36;
use strict;
-use vars qw/$bad $bad7 $ok10 $bad18 $ok/;
+our ( $bad, $bad7, $ok10, $bad18, $ok );
$^W=1;
@@ -202,7 +202,11 @@ SKIP: {
$skip{pid}{$^O} = $skip{uid}{$^O} = "not set for kill()"
if (($^O.$Config{osvers}) =~ /^darwin[0-8]\./
||
- ($^O.$Config{osvers}) =~ /^openbsd[0-6]\./);
+ ($^O.$Config{osvers}) =~ /^openbsd[0-6]\./
+ ||
+ ($^O eq 'gnu')
+ ||
+ ($^O eq 'dragonfly'));
my $tests = keys %{{ %siginfo, %opt_val }};
eval 'use POSIX qw(SA_SIGINFO); SA_SIGINFO';
skip("no SA_SIGINFO", $tests) if $@;
diff --git a/gnu/usr.bin/perl/ext/POSIX/t/time.t b/gnu/usr.bin/perl/ext/POSIX/t/time.t
index 6a906e031d6..4b10eb83350 100644
--- a/gnu/usr.bin/perl/ext/POSIX/t/time.t
+++ b/gnu/usr.bin/perl/ext/POSIX/t/time.t
@@ -22,7 +22,7 @@ SKIP: {
# actually do anything. Cygwin works in some places, but not others. The
# other Win32's below are guesses.
skip "No tzset()", 2
- if $^O eq "MacOS" || $^O eq "VMS" || $^O eq "cygwin" || $^O eq "djgpp" ||
+ if $^O eq "VMS" || $^O eq "cygwin" || $^O eq "djgpp" ||
$^O eq "MSWin32" || $^O eq "dos" || $^O eq "interix";
tzset();
my @tzname = tzname();
diff --git a/gnu/usr.bin/perl/ext/POSIX/t/wrappers.t b/gnu/usr.bin/perl/ext/POSIX/t/wrappers.t
index f09b92595f1..e41b3194c9e 100644
--- a/gnu/usr.bin/perl/ext/POSIX/t/wrappers.t
+++ b/gnu/usr.bin/perl/ext/POSIX/t/wrappers.t
@@ -28,9 +28,7 @@ if (locales_enabled('LC_MESSAGES')) {
local $! = 1;
my $english_message = "$!"; # Should be C locale since not in scope of
# "use locale"
- for $non_english_locale (find_locales(&POSIX::LC_MESSAGES,
- 'reasonable_locales_only'))
- {
+ for $non_english_locale (find_locales(&POSIX::LC_MESSAGES)) {
use locale;
setlocale(&POSIX::LC_MESSAGES, $non_english_locale);
$! = 1;
@@ -164,9 +162,6 @@ SKIP: {
cmp_ok($present, '<=', $future, 'time');
}
-is(POSIX::tolower('Perl Rules'), 'perl rules', 'tolower');
-is(POSIX::toupper('oi!'), 'OI!', 'toupper');
-
is(-e NOT_HERE, undef, NOT_HERE . ' does not exist');
foreach ([undef, 0, 'chdir', NOT_HERE],
Copyright © 1996 – 2023 Jason A. Donenfeld. All Rights Reverse Engineered.