# include <sys/wait.h>
#endif
-#ifdef I_LOCALE
-# include <locale.h>
-#endif
-
#define FLUSH
#ifdef LEAKTEST
# define FD_CLOEXEC 1 /* NeXT needs this */
#endif
-/* paranoid version of system's malloc() */
-
/* NOTE: Do not call the next three routines directly. Use the macros
* in handy.h, so that we can easily redefine everything to do tracking of
* allocated hunks back to the original New to track down any memory leaks.
* XXX This advice seems to be widely ignored :-( --AD August 1996.
*/
+/* paranoid version of system's malloc() */
+
Malloc_t
Perl_safesysmalloc(MEM_SIZE size)
{
return Nullch;
}
-/*
- * Set up for a new ctype locale.
- */
-void
-Perl_new_ctype(pTHX_ char *newctype)
-{
-#ifdef USE_LOCALE_CTYPE
-
- int i;
-
- for (i = 0; i < 256; i++) {
- if (isUPPER_LC(i))
- PL_fold_locale[i] = toLOWER_LC(i);
- else if (isLOWER_LC(i))
- PL_fold_locale[i] = toUPPER_LC(i);
- else
- PL_fold_locale[i] = i;
- }
-
-#endif /* USE_LOCALE_CTYPE */
-}
-
-/*
- * Standardize the locale name from a string returned by 'setlocale'.
- *
- * The standard return value of setlocale() is either
- * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
- * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
- * (the space-separated values represent the various sublocales,
- * in some unspecificed order)
- *
- * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
- * which is harmful for further use of the string in setlocale().
- *
- */
-STATIC char *
-S_stdize_locale(pTHX_ char *locs)
-{
- char *s;
- bool okay = TRUE;
-
- if ((s = strchr(locs, '='))) {
- char *t;
-
- okay = FALSE;
- if ((t = strchr(s, '.'))) {
- char *u;
-
- if ((u = strchr(t, '\n'))) {
-
- if (u[1] == 0) {
- STRLEN len = u - s;
- Move(s + 1, locs, len, char);
- locs[len] = 0;
- okay = TRUE;
- }
- }
- }
- }
-
- if (!okay)
- Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
-
- return locs;
-}
-
-/*
- * Set up for a new collation locale.
- */
-void
-Perl_new_collate(pTHX_ char *newcoll)
-{
-#ifdef USE_LOCALE_COLLATE
-
- if (! newcoll) {
- if (PL_collation_name) {
- ++PL_collation_ix;
- Safefree(PL_collation_name);
- PL_collation_name = NULL;
- }
- PL_collation_standard = TRUE;
- PL_collxfrm_base = 0;
- PL_collxfrm_mult = 2;
- return;
- }
-
- if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
- ++PL_collation_ix;
- Safefree(PL_collation_name);
- PL_collation_name = stdize_locale(savepv(newcoll));
- PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
-
- {
- /* 2: at most so many chars ('a', 'b'). */
- /* 50: surely no system expands a char more. */
-#define XFRMBUFSIZE (2 * 50)
- char xbuf[XFRMBUFSIZE];
- Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE);
- Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
- SSize_t mult = fb - fa;
- if (mult < 1)
- Perl_croak(aTHX_ "strxfrm() gets absurd");
- PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0;
- PL_collxfrm_mult = mult;
- }
- }
-
-#endif /* USE_LOCALE_COLLATE */
-}
-
-void
-Perl_set_numeric_radix(pTHX)
-{
-#ifdef USE_LOCALE_NUMERIC
-# ifdef HAS_LOCALECONV
- struct lconv* lc;
-
- lc = localeconv();
- if (lc && lc->decimal_point) {
- if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) {
- SvREFCNT_dec(PL_numeric_radix_sv);
- PL_numeric_radix_sv = Nullsv;
- }
- else {
- if (PL_numeric_radix_sv)
- sv_setpv(PL_numeric_radix_sv, lc->decimal_point);
- else
- PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0);
- }
- }
- else
- PL_numeric_radix_sv = Nullsv;
-# endif /* HAS_LOCALECONV */
-#endif /* USE_LOCALE_NUMERIC */
-}
-
-/*
- * Set up for a new numeric locale.
- */
-void
-Perl_new_numeric(pTHX_ char *newnum)
-{
-#ifdef USE_LOCALE_NUMERIC
-
- if (! newnum) {
- if (PL_numeric_name) {
- Safefree(PL_numeric_name);
- PL_numeric_name = NULL;
- }
- PL_numeric_standard = TRUE;
- PL_numeric_local = TRUE;
- return;
- }
-
- if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
- Safefree(PL_numeric_name);
- PL_numeric_name = stdize_locale(savepv(newnum));
- PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
- PL_numeric_local = TRUE;
- set_numeric_radix();
- }
-
-#endif /* USE_LOCALE_NUMERIC */
-}
-
-void
-Perl_set_numeric_standard(pTHX)
-{
-#ifdef USE_LOCALE_NUMERIC
-
- if (! PL_numeric_standard) {
- setlocale(LC_NUMERIC, "C");
- PL_numeric_standard = TRUE;
- PL_numeric_local = FALSE;
- set_numeric_radix();
- }
-
-#endif /* USE_LOCALE_NUMERIC */
-}
-
-void
-Perl_set_numeric_local(pTHX)
-{
-#ifdef USE_LOCALE_NUMERIC
-
- if (! PL_numeric_local) {
- setlocale(LC_NUMERIC, PL_numeric_name);
- PL_numeric_standard = FALSE;
- PL_numeric_local = TRUE;
- set_numeric_radix();
- }
-
-#endif /* USE_LOCALE_NUMERIC */
-}
-
-/*
- * Initialize locale awareness.
- */
-int
-Perl_init_i18nl10n(pTHX_ int printwarn)
-{
- int ok = 1;
- /* returns
- * 1 = set ok or not applicable,
- * 0 = fallback to C locale,
- * -1 = fallback to C locale failed
- */
-
-#if defined(USE_LOCALE)
-
-#ifdef USE_LOCALE_CTYPE
- char *curctype = NULL;
-#endif /* USE_LOCALE_CTYPE */
-#ifdef USE_LOCALE_COLLATE
- char *curcoll = NULL;
-#endif /* USE_LOCALE_COLLATE */
-#ifdef USE_LOCALE_NUMERIC
- char *curnum = NULL;
-#endif /* USE_LOCALE_NUMERIC */
-#ifdef __GLIBC__
- char *language = PerlEnv_getenv("LANGUAGE");
-#endif
- char *lc_all = PerlEnv_getenv("LC_ALL");
- char *lang = PerlEnv_getenv("LANG");
- bool setlocale_failure = FALSE;
-
-#ifdef LOCALE_ENVIRON_REQUIRED
-
- /*
- * Ultrix setlocale(..., "") fails if there are no environment
- * variables from which to get a locale name.
- */
-
- bool done = FALSE;
-
-#ifdef LC_ALL
- if (lang) {
- if (setlocale(LC_ALL, ""))
- done = TRUE;
- else
- setlocale_failure = TRUE;
- }
- if (!setlocale_failure) {
-#ifdef USE_LOCALE_CTYPE
- if (! (curctype =
- setlocale(LC_CTYPE,
- (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
- ? "" : Nullch)))
- setlocale_failure = TRUE;
- else
- curctype = savepv(curctype);
-#endif /* USE_LOCALE_CTYPE */
-#ifdef USE_LOCALE_COLLATE
- if (! (curcoll =
- setlocale(LC_COLLATE,
- (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
- ? "" : Nullch)))
- setlocale_failure = TRUE;
- else
- curcoll = savepv(curcoll);
-#endif /* USE_LOCALE_COLLATE */
-#ifdef USE_LOCALE_NUMERIC
- if (! (curnum =
- setlocale(LC_NUMERIC,
- (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
- ? "" : Nullch)))
- setlocale_failure = TRUE;
- else
- curnum = savepv(curnum);
-#endif /* USE_LOCALE_NUMERIC */
- }
-
-#endif /* LC_ALL */
-
-#endif /* !LOCALE_ENVIRON_REQUIRED */
-
-#ifdef LC_ALL
- if (! setlocale(LC_ALL, ""))
- setlocale_failure = TRUE;
-#endif /* LC_ALL */
-
- if (!setlocale_failure) {
-#ifdef USE_LOCALE_CTYPE
- if (! (curctype = setlocale(LC_CTYPE, "")))
- setlocale_failure = TRUE;
- else
- curctype = savepv(curctype);
-#endif /* USE_LOCALE_CTYPE */
-#ifdef USE_LOCALE_COLLATE
- if (! (curcoll = setlocale(LC_COLLATE, "")))
- setlocale_failure = TRUE;
- else
- curcoll = savepv(curcoll);
-#endif /* USE_LOCALE_COLLATE */
-#ifdef USE_LOCALE_NUMERIC
- if (! (curnum = setlocale(LC_NUMERIC, "")))
- setlocale_failure = TRUE;
- else
- curnum = savepv(curnum);
-#endif /* USE_LOCALE_NUMERIC */
- }
-
- if (setlocale_failure) {
- char *p;
- bool locwarn = (printwarn > 1 ||
- (printwarn &&
- (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
-
- if (locwarn) {
-#ifdef LC_ALL
-
- PerlIO_printf(Perl_error_log,
- "perl: warning: Setting locale failed.\n");
-
-#else /* !LC_ALL */
-
- PerlIO_printf(Perl_error_log,
- "perl: warning: Setting locale failed for the categories:\n\t");
-#ifdef USE_LOCALE_CTYPE
- if (! curctype)
- PerlIO_printf(Perl_error_log, "LC_CTYPE ");
-#endif /* USE_LOCALE_CTYPE */
-#ifdef USE_LOCALE_COLLATE
- if (! curcoll)
- PerlIO_printf(Perl_error_log, "LC_COLLATE ");
-#endif /* USE_LOCALE_COLLATE */
-#ifdef USE_LOCALE_NUMERIC
- if (! curnum)
- PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
-#endif /* USE_LOCALE_NUMERIC */
- PerlIO_printf(Perl_error_log, "\n");
-
-#endif /* LC_ALL */
-
- PerlIO_printf(Perl_error_log,
- "perl: warning: Please check that your locale settings:\n");
-
-#ifdef __GLIBC__
- PerlIO_printf(Perl_error_log,
- "\tLANGUAGE = %c%s%c,\n",
- language ? '"' : '(',
- language ? language : "unset",
- language ? '"' : ')');
-#endif
-
- PerlIO_printf(Perl_error_log,
- "\tLC_ALL = %c%s%c,\n",
- lc_all ? '"' : '(',
- lc_all ? lc_all : "unset",
- lc_all ? '"' : ')');
-
-#if defined(USE_ENVIRON_ARRAY)
- {
- char **e;
- for (e = environ; *e; e++) {
- if (strnEQ(*e, "LC_", 3)
- && strnNE(*e, "LC_ALL=", 7)
- && (p = strchr(*e, '=')))
- PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
- (int)(p - *e), *e, p + 1);
- }
- }
-#else
- PerlIO_printf(Perl_error_log,
- "\t(possibly more locale environment variables)\n");
-#endif
-
- PerlIO_printf(Perl_error_log,
- "\tLANG = %c%s%c\n",
- lang ? '"' : '(',
- lang ? lang : "unset",
- lang ? '"' : ')');
-
- PerlIO_printf(Perl_error_log,
- " are supported and installed on your system.\n");
- }
-
-#ifdef LC_ALL
-
- if (setlocale(LC_ALL, "C")) {
- if (locwarn)
- PerlIO_printf(Perl_error_log,
- "perl: warning: Falling back to the standard locale (\"C\").\n");
- ok = 0;
- }
- else {
- if (locwarn)
- PerlIO_printf(Perl_error_log,
- "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
- ok = -1;
- }
-
-#else /* ! LC_ALL */
-
- if (0
-#ifdef USE_LOCALE_CTYPE
- || !(curctype || setlocale(LC_CTYPE, "C"))
-#endif /* USE_LOCALE_CTYPE */
-#ifdef USE_LOCALE_COLLATE
- || !(curcoll || setlocale(LC_COLLATE, "C"))
-#endif /* USE_LOCALE_COLLATE */
-#ifdef USE_LOCALE_NUMERIC
- || !(curnum || setlocale(LC_NUMERIC, "C"))
-#endif /* USE_LOCALE_NUMERIC */
- )
- {
- if (locwarn)
- PerlIO_printf(Perl_error_log,
- "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
- ok = -1;
- }
-
-#endif /* ! LC_ALL */
-
-#ifdef USE_LOCALE_CTYPE
- curctype = savepv(setlocale(LC_CTYPE, Nullch));
-#endif /* USE_LOCALE_CTYPE */
-#ifdef USE_LOCALE_COLLATE
- curcoll = savepv(setlocale(LC_COLLATE, Nullch));
-#endif /* USE_LOCALE_COLLATE */
-#ifdef USE_LOCALE_NUMERIC
- curnum = savepv(setlocale(LC_NUMERIC, Nullch));
-#endif /* USE_LOCALE_NUMERIC */
- }
- else {
-
-#ifdef USE_LOCALE_CTYPE
- new_ctype(curctype);
-#endif /* USE_LOCALE_CTYPE */
-
-#ifdef USE_LOCALE_COLLATE
- new_collate(curcoll);
-#endif /* USE_LOCALE_COLLATE */
-
-#ifdef USE_LOCALE_NUMERIC
- new_numeric(curnum);
-#endif /* USE_LOCALE_NUMERIC */
- }
-
-#endif /* USE_LOCALE */
-
-#ifdef USE_LOCALE_CTYPE
- if (curctype != NULL)
- Safefree(curctype);
-#endif /* USE_LOCALE_CTYPE */
-#ifdef USE_LOCALE_COLLATE
- if (curcoll != NULL)
- Safefree(curcoll);
-#endif /* USE_LOCALE_COLLATE */
-#ifdef USE_LOCALE_NUMERIC
- if (curnum != NULL)
- Safefree(curnum);
-#endif /* USE_LOCALE_NUMERIC */
- return ok;
-}
-
-/* Backwards compatibility. */
-int
-Perl_init_i18nl14n(pTHX_ int printwarn)
-{
- return init_i18nl10n(printwarn);
-}
-
-#ifdef USE_LOCALE_COLLATE
-
-/*
- * mem_collxfrm() is a bit like strxfrm() but with two important
- * differences. First, it handles embedded NULs. Second, it allocates
- * a bit more memory than needed for the transformed data itself.
- * The real transformed data begins at offset sizeof(collationix).
- * Please see sv_collxfrm() to see how this is used.
- */
-char *
-Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen)
-{
- char *xbuf;
- STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
-
- /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
- /* the +1 is for the terminating NUL. */
-
- xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
- New(171, xbuf, xAlloc, char);
- if (! xbuf)
- goto bad;
-
- *(U32*)xbuf = PL_collation_ix;
- xout = sizeof(PL_collation_ix);
- for (xin = 0; xin < len; ) {
- SSize_t xused;
-
- for (;;) {
- xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
- if (xused == -1)
- goto bad;
- if (xused < xAlloc - xout)
- break;
- xAlloc = (2 * xAlloc) + 1;
- Renew(xbuf, xAlloc, char);
- if (! xbuf)
- goto bad;
- }
-
- xin += strlen(s + xin) + 1;
- xout += xused;
-
- /* Embedded NULs are understood but silently skipped
- * because they make no sense in locale collation. */
- }
-
- xbuf[xout] = '\0';
- *xlen = xout - sizeof(PL_collation_ix);
- return xbuf;
-
- bad:
- Safefree(xbuf);
- *xlen = 0;
- return NULL;
-}
-
-#endif /* USE_LOCALE_COLLATE */
-
#define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
/* As a space optimization, we do not compile tables for strings of length
*/
/* If SvTAIL is actually due to \Z or \z, this gives false positives
- if PL_multiline. In fact if !PL_multiline the autoritative answer
+ if PL_multiline. In fact if !PL_multiline the authoritative answer
is not supported yet. */
char *
/* The value of pos we can stop at: */
stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
if (previous + start_shift > stop_pos) {
+/*
+ stop_pos does not include SvTAIL in the count, so this check is incorrect
+ (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19
+*/
+#if 0
if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
goto check_tail;
+#endif
return Nullch;
}
while (pos < previous + start_shift) {
#ifdef USE_ENVIRON_ARRAY
/* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */
-#if !defined(WIN32)
+#if !defined(WIN32) && !defined(NETWARE)
void
Perl_my_setenv(pTHX_ char *nam, char *val)
{
#endif /* PERL_USE_SAFE_PUTENV */
}
-#else /* WIN32 */
+#else /* WIN32 || NETWARE */
void
Perl_my_setenv(pTHX_ char *nam,char *val)
Safefree(envstr);
}
-#endif /* WIN32 */
+#endif /* WIN32 || NETWARE */
I32
Perl_setenv_getix(pTHX_ char *nam)
#endif
/* this is a drop-in replacement for bcopy() */
-#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
+#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY))
char *
Perl_my_bcopy(register const char *from,register char *to,register I32 len)
{
PerlIO *
Perl_my_popen_list(pTHX_ char *mode, int n, SV **args)
{
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE)
int p[2];
register I32 This, that;
register Pid_t pid;
}
#endif /* !DOSISH */
-#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
+#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL)
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
}
#endif
}
-#endif /* !DOSISH || OS2 || WIN32 */
+#endif /* !DOSISH || OS2 || WIN32 || NETWARE */
void
/*SUPPRESS 590*/
}
}
-U32
-Perl_cast_ulong(pTHX_ NV f)
-{
- if (f < 0.0)
- return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
- if (f < U32_MAX_P1) {
-#if CASTFLAGS & 2
- if (f < U32_MAX_P1_HALF)
- return (U32) f;
- f -= U32_MAX_P1_HALF;
- return ((U32) f) | (1 + U32_MAX >> 1);
-#else
- return (U32) f;
-#endif
- }
- return f > 0 ? U32_MAX : 0 /* NaN */;
-}
-
-I32
-Perl_cast_i32(pTHX_ NV f)
-{
- if (f < I32_MAX_P1)
- return f < I32_MIN ? I32_MIN : (I32) f;
- if (f < U32_MAX_P1) {
-#if CASTFLAGS & 2
- if (f < U32_MAX_P1_HALF)
- return (I32)(U32) f;
- f -= U32_MAX_P1_HALF;
- return (I32)(((U32) f) | (1 + U32_MAX >> 1));
-#else
- return (I32)(U32) f;
-#endif
- }
- return f > 0 ? (I32)U32_MAX : 0 /* NaN */;
-}
-
-IV
-Perl_cast_iv(pTHX_ NV f)
-{
- if (f < IV_MAX_P1)
- return f < IV_MIN ? IV_MIN : (IV) f;
- if (f < UV_MAX_P1) {
-#if CASTFLAGS & 2
- /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */
- if (f < UV_MAX_P1_HALF)
- return (IV)(UV) f;
- f -= UV_MAX_P1_HALF;
- return (IV)(((UV) f) | (1 + UV_MAX >> 1));
-#else
- return (IV)(UV) f;
-#endif
- }
- return f > 0 ? (IV)UV_MAX : 0 /* NaN */;
-}
-
-UV
-Perl_cast_uv(pTHX_ NV f)
-{
- if (f < 0.0)
- return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f;
- if (f < UV_MAX_P1) {
-#if CASTFLAGS & 2
- if (f < UV_MAX_P1_HALF)
- return (UV) f;
- f -= UV_MAX_P1_HALF;
- return ((UV) f) | (1 + UV_MAX >> 1);
-#else
- return (UV) f;
-#endif
- }
- return f > 0 ? UV_MAX : 0 /* NaN */;
-}
-
#ifndef HAS_RENAME
I32
Perl_same_dirent(pTHX_ char *a, char *b)
}
#endif /* !HAS_RENAME */
-NV
-Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen)
-{
- register char *s = start;
- register NV rnv = 0.0;
- register UV ruv = 0;
- register bool seenb = FALSE;
- register bool overflowed = FALSE;
-
- for (; len-- && *s; s++) {
- if (!(*s == '0' || *s == '1')) {
- if (*s == '_' && len && *retlen
- && (s[1] == '0' || s[1] == '1'))
- {
- --len;
- ++s;
- }
- else if (seenb == FALSE && *s == 'b' && ruv == 0) {
- /* Disallow 0bbb0b0bbb... */
- seenb = TRUE;
- continue;
- }
- else {
- if (ckWARN(WARN_DIGIT))
- Perl_warner(aTHX_ WARN_DIGIT,
- "Illegal binary digit '%c' ignored", *s);
- break;
- }
- }
- if (!overflowed) {
- register UV xuv = ruv << 1;
-
- if ((xuv >> 1) != ruv) {
- overflowed = TRUE;
- rnv = (NV) ruv;
- if (ckWARN_d(WARN_OVERFLOW))
- Perl_warner(aTHX_ WARN_OVERFLOW,
- "Integer overflow in binary number");
- }
- else
- ruv = xuv | (*s - '0');
- }
- if (overflowed) {
- rnv *= 2;
- /* If an NV has not enough bits in its mantissa to
- * represent an UV this summing of small low-order numbers
- * is a waste of time (because the NV cannot preserve
- * the low-order bits anyway): we could just remember when
- * did we overflow and in the end just multiply rnv by the
- * right amount. */
- rnv += (*s - '0');
- }
- }
- if (!overflowed)
- rnv = (NV) ruv;
- if ( ( overflowed && rnv > 4294967295.0)
-#if UVSIZE > 4
- || (!overflowed && ruv > 0xffffffff )
-#endif
- ) {
- if (ckWARN(WARN_PORTABLE))
- Perl_warner(aTHX_ WARN_PORTABLE,
- "Binary number > 0b11111111111111111111111111111111 non-portable");
- }
- *retlen = s - start;
- return rnv;
-}
-
-NV
-Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen)
-{
- register char *s = start;
- register NV rnv = 0.0;
- register UV ruv = 0;
- register bool overflowed = FALSE;
-
- for (; len-- && *s; s++) {
- if (!(*s >= '0' && *s <= '7')) {
- if (*s == '_' && len && *retlen
- && (s[1] >= '0' && s[1] <= '7'))
- {
- --len;
- ++s;
- }
- else {
- /* Allow \octal to work the DWIM way (that is, stop scanning
- * as soon as non-octal characters are seen, complain only iff
- * someone seems to want to use the digits eight and nine). */
- if (*s == '8' || *s == '9') {
- if (ckWARN(WARN_DIGIT))
- Perl_warner(aTHX_ WARN_DIGIT,
- "Illegal octal digit '%c' ignored", *s);
- }
- break;
- }
- }
- if (!overflowed) {
- register UV xuv = ruv << 3;
-
- if ((xuv >> 3) != ruv) {
- overflowed = TRUE;
- rnv = (NV) ruv;
- if (ckWARN_d(WARN_OVERFLOW))
- Perl_warner(aTHX_ WARN_OVERFLOW,
- "Integer overflow in octal number");
- }
- else
- ruv = xuv | (*s - '0');
- }
- if (overflowed) {
- rnv *= 8.0;
- /* If an NV has not enough bits in its mantissa to
- * represent an UV this summing of small low-order numbers
- * is a waste of time (because the NV cannot preserve
- * the low-order bits anyway): we could just remember when
- * did we overflow and in the end just multiply rnv by the
- * right amount of 8-tuples. */
- rnv += (NV)(*s - '0');
- }
- }
- if (!overflowed)
- rnv = (NV) ruv;
- if ( ( overflowed && rnv > 4294967295.0)
-#if UVSIZE > 4
- || (!overflowed && ruv > 0xffffffff )
-#endif
- ) {
- if (ckWARN(WARN_PORTABLE))
- Perl_warner(aTHX_ WARN_PORTABLE,
- "Octal number > 037777777777 non-portable");
- }
- *retlen = s - start;
- return rnv;
-}
-
-NV
-Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen)
-{
- register char *s = start;
- register NV rnv = 0.0;
- register UV ruv = 0;
- register bool overflowed = FALSE;
- char *hexdigit;
-
- if (len > 2) {
- if (s[0] == 'x') {
- s++;
- len--;
- }
- else if (len > 3 && s[0] == '0' && s[1] == 'x') {
- s+=2;
- len-=2;
- }
- }
-
- for (; len-- && *s; s++) {
- hexdigit = strchr((char *) PL_hexdigit, *s);
- if (!hexdigit) {
- if (*s == '_' && len && *retlen && s[1]
- && (hexdigit = strchr((char *) PL_hexdigit, s[1])))
- {
- --len;
- ++s;
- }
- else {
- if (ckWARN(WARN_DIGIT))
- Perl_warner(aTHX_ WARN_DIGIT,
- "Illegal hexadecimal digit '%c' ignored", *s);
- break;
- }
- }
- if (!overflowed) {
- register UV xuv = ruv << 4;
-
- if ((xuv >> 4) != ruv) {
- overflowed = TRUE;
- rnv = (NV) ruv;
- if (ckWARN_d(WARN_OVERFLOW))
- Perl_warner(aTHX_ WARN_OVERFLOW,
- "Integer overflow in hexadecimal number");
- }
- else
- ruv = xuv | ((hexdigit - PL_hexdigit) & 15);
- }
- if (overflowed) {
- rnv *= 16.0;
- /* If an NV has not enough bits in its mantissa to
- * represent an UV this summing of small low-order numbers
- * is a waste of time (because the NV cannot preserve
- * the low-order bits anyway): we could just remember when
- * did we overflow and in the end just multiply rnv by the
- * right amount of 16-tuples. */
- rnv += (NV)((hexdigit - PL_hexdigit) & 15);
- }
- }
- if (!overflowed)
- rnv = (NV) ruv;
- if ( ( overflowed && rnv > 4294967295.0)
-#if UVSIZE > 4
- || (!overflowed && ruv > 0xffffffff )
-#endif
- ) {
- if (ckWARN(WARN_PORTABLE))
- Perl_warner(aTHX_ WARN_PORTABLE,
- "Hexadecimal number > 0xffffffff non-portable");
- }
- *retlen = s - start;
- return rnv;
-}
-
char*
Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
{
{
MAGIC *mg;
- SvUPGRADE(sv, SVt_PVMG);
+ (void)SvUPGRADE(sv, SVt_PVMG);
mg = mg_find(sv, PERL_MAGIC_mutex);
if (!mg) {
condpair_t *cp;
}
#endif /* USE_THREADS */
-#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
-/*
- * This hack is to force load of "huge" support from libm.a
- * So it is in perl for (say) POSIX to use.
- * Needed for SunOS with Sun's 'acc' for example.
- */
-NV
-Perl_huge(void)
-{
-# if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
- return HUGE_VALL;
-# endif
- return HUGE_VAL;
-}
-#endif
-
#ifdef PERL_GLOBAL_STRUCT
struct perl_vars *
Perl_GetVars(pTHX)
extern void _fwalk(int (*)(FILE *));
_fwalk(&fflush);
return 0;
-# else
- long open_max = -1;
+# else
# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
+ long open_max = -1;
# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
# else
-# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
+# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
open_max = sysconf(_SC_OPEN_MAX);
-# else
-# ifdef FOPEN_MAX
+# else
+# ifdef FOPEN_MAX
open_max = FOPEN_MAX;
-# else
-# ifdef OPEN_MAX
+# else
+# ifdef OPEN_MAX
open_max = OPEN_MAX;
-# else
-# ifdef _NFILE
+# else
+# ifdef _NFILE
open_max = _NFILE;
+# endif
+# endif
# endif
# endif
# endif
-# endif
-# endif
if (open_max > 0) {
long i;
for (i = 0; i < open_max; i++)
#endif
}
-NV
-Perl_my_atof(pTHX_ const char* s)
-{
- NV x = 0.0;
-#ifdef USE_LOCALE_NUMERIC
- if ((PL_hints & HINT_LOCALE) && PL_numeric_local) {
- NV y;
-
- Perl_atof2(aTHX_ s, &x);
- SET_NUMERIC_STANDARD();
- Perl_atof2(aTHX_ s, &y);
- SET_NUMERIC_LOCAL();
- if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
- return y;
- }
- else
- Perl_atof2(aTHX_ s, &x);
-#else
- Perl_atof2(aTHX_ s, &x);
-#endif
- return x;
-}
-
-char*
-Perl_my_atof2(pTHX_ const char* orig, NV* value)
-{
- NV result = 0.0;
- bool negative = 0;
- char* s = (char*)orig;
- char* point = "."; /* locale-dependent decimal point equivalent */
- STRLEN pointlen = 1;
- bool seendigit = 0;
-
- if (PL_numeric_radix_sv)
- point = SvPV(PL_numeric_radix_sv, pointlen);
-
- switch (*s) {
- case '-':
- negative = 1;
- /* fall through */
- case '+':
- ++s;
- }
- while (isDIGIT(*s)) {
- result = result * 10 + (*s++ - '0');
- seendigit = 1;
- }
- if (memEQ(s, point, pointlen)) {
- NV decimal = 0.1;
-
- s += pointlen;
- while (isDIGIT(*s)) {
- result += (*s++ - '0') * decimal;
- decimal *= 0.1;
- seendigit = 1;
- }
- }
- if (seendigit && (*s == 'e' || *s == 'E')) {
- I32 exponent = 0;
- I32 expnegative = 0;
- I32 bit;
- NV power;
-
- ++s;
- switch (*s) {
- case '-':
- expnegative = 1;
- /* fall through */
- case '+':
- ++s;
- }
- while (isDIGIT(*s))
- exponent = exponent * 10 + (*s++ - '0');
-
- /* now apply the exponent */
- power = (expnegative) ? 0.1 : 10.0;
- for (bit = 1; exponent; bit <<= 1) {
- if (exponent & bit) {
- exponent ^= bit;
- result *= power;
- }
- power *= power;
- }
- }
- if (negative)
- result = -result;
- *value = result;
- return s;
-}
-
void
Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
{
* because you might chdir out of a directory that you can't chdir
* back into. */
-/* XXX: this needs more porting #ifndef HAS_GETCWD */
int
Perl_sv_getcwd(pTHX_ register SV *sv)
{
#ifndef PERL_MICRO
-#ifndef HAS_GETCWD
+#ifdef HAS_GETCWD
+ {
+ char buf[MAXPATHLEN];
+
+ /* Some getcwd()s automatically allocate a buffer of the given
+ * size from the heap if they are given a NULL buffer pointer.
+ * The problem is that this behaviour is not portable. */
+ if (getcwd(buf, sizeof(buf) - 1)) {
+ STRLEN len = strlen(buf);
+ sv_setpvn(sv, buf, len);
+ return TRUE;
+ }
+ else {
+ sv_setsv(sv, &PL_sv_undef);
+ return FALSE;
+ }
+ }
+
+#else
+
struct stat statbuf;
int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
int namelen, pathlen=0;
DIR *dir;
Direntry_t *dp;
-#endif
(void)SvUPGRADE(sv, SVt_PV);
-#ifdef HAS_GETCWD
-
- SvGROW(sv, 128);
- while ((getcwd(SvPVX(sv), SvLEN(sv)-1) == NULL) && errno == ERANGE) {
- SvGROW(sv, SvLEN(sv) + 128);
- }
- SvCUR_set(sv, strlen(SvPVX(sv)));
- SvPOK_only(sv);
-
-#else
-
if (PerlLIO_lstat(".", &statbuf) < 0) {
- CWDXS_RETURN_SVUNDEF(sv);
+ SV_CWD_RETURN_UNDEF;
}
orig_cdev = statbuf.st_dev;
namelen = strlen(dp->d_name);
#endif
/* skip . and .. */
- if (SV_CWD_ISDOT(dp)) {dp->d_name[0] == '.'
+ if (SV_CWD_ISDOT(dp)) {
continue;
}
SV_CWD_RETURN_UNDEF;
}
+ if (pathlen + namelen + 1 >= MAXPATHLEN) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
SvGROW(sv, pathlen + namelen + 1);
if (pathlen) {
#endif
}
- SvCUR_set(sv, pathlen);
- *SvEND(sv) = '\0';
- SvPOK_only(sv);
+ if (pathlen) {
+ SvCUR_set(sv, pathlen);
+ *SvEND(sv) = '\0';
+ SvPOK_only(sv);
- if (PerlDir_chdir(SvPVX(sv)) < 0) {
- SV_CWD_RETURN_UNDEF;
+ if (PerlDir_chdir(SvPVX(sv)) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
}
if (PerlLIO_stat(".", &statbuf) < 0) {
SV_CWD_RETURN_UNDEF;
#endif
}
-/*
-=for apidoc sv_realpath
-
-Wrap or emulate realpath(3).
-
-=cut
- */
-int
-Perl_sv_realpath(pTHX_ SV *sv, char *path, STRLEN len)
-{
-#ifndef PERL_MICRO
- char name[MAXPATHLEN] = { 0 }, *s;
- STRLEN pathlen, namelen;
-
-#ifdef HAS_REALPATH
- /* Be paranoid about the use of realpath(),
- * it is an infamous source of buffer overruns. */
-
- /* Is the source buffer too long?
- * Don't use strlen() to avoid running off the end. */
- s = memchr(path, '\0', MAXPATHLEN);
- pathlen = s ? s - path : MAXPATHLEN;
- if (pathlen == MAXPATHLEN) {
- Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %c= (MAXPATHLEN = %d)",
- path, s ? '=' : '>', MAXPATHLEN);
- SV_CWD_RETURN_UNDEF;
- }
-
- /* Here goes nothing. */
- if (realpath(path, name) == NULL) {
- Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %s",
- path, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- /* Is the destination buffer too long?
- * Don't use strlen() to avoid running off the end. */
- s = memchr(name, '\0', MAXPATHLEN);
- namelen = s ? s - name : MAXPATHLEN;
- if (namelen == MAXPATHLEN) {
- Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %c= (MAXPATHLEN = %d)",
- path, s ? '=' : '>', MAXPATHLEN);
- SV_CWD_RETURN_UNDEF;
- }
-
- /* The coast is clear? */
- sv_setpvn(sv, name, namelen);
- SvPOK_only(sv);
-
- return TRUE;
-#else
- DIR *parent;
- Direntry_t *dp;
- char dotdots[MAXPATHLEN] = { 0 };
- struct stat cst, pst, tst;
-
- if (PerlLIO_stat(path, &cst) < 0) {
- Perl_warn(aTHX_ "sv_realpath: stat(\"%s\"): %s",
- path, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- (void)SvUPGRADE(sv, SVt_PV);
-
- if (!len) {
- len = strlen(path);
- }
- Copy(path, dotdots, len, char);
-
- for (;;) {
- strcat(dotdots, "/..");
- StructCopy(&cst, &pst, struct stat);
-
- if (PerlLIO_stat(dotdots, &cst) < 0) {
- Perl_warn(aTHX_ "sv_realpath: stat(\"%s\"): %s",
- dotdots, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- if (pst.st_dev == cst.st_dev && pst.st_ino == cst.st_ino) {
- /* We've reached the root: previous is same as current */
- break;
- } else {
- STRLEN dotdotslen = strlen(dotdots);
-
- /* Scan through the dir looking for name of previous */
- if (!(parent = PerlDir_open(dotdots))) {
- Perl_warn(aTHX_ "sv_realpath: opendir(\"%s\"): %s",
- dotdots, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- SETERRNO(0,SS$_NORMAL); /* for readdir() */
- while ((dp = PerlDir_read(parent)) != NULL) {
- if (SV_CWD_ISDOT(dp)) {
- continue;
- }
-
- Copy(dotdots, name, dotdotslen, char);
- name[dotdotslen] = '/';
-#ifdef DIRNAMLEN
- namelen = dp->d_namlen;
-#else
- namelen = strlen(dp->d_name);
-#endif
- Copy(dp->d_name, name + dotdotslen + 1, namelen, char);
- name[dotdotslen + 1 + namelen] = 0;
-
- if (PerlLIO_lstat(name, &tst) < 0) {
- PerlDir_close(parent);
- Perl_warn(aTHX_ "sv_realpath: lstat(\"%s\"): %s",
- name, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- if (tst.st_dev == pst.st_dev && tst.st_ino == pst.st_ino)
- break;
-
- SETERRNO(0,SS$_NORMAL); /* for readdir() */
- }
-
- if (!dp && errno) {
- Perl_warn(aTHX_ "sv_realpath: readdir(\"%s\"): %s",
- dotdots, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-
- SvGROW(sv, pathlen + namelen + 1);
- if (pathlen) {
- /* shift down */
- Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
- }
-
- *SvPVX(sv) = '/';
- Move(dp->d_name, SvPVX(sv)+1, namelen, char);
- pathlen += (namelen + 1);
-
-#ifdef VOID_CLOSEDIR
- PerlDir_close(parent);
-#else
- if (PerlDir_close(parent) < 0) {
- Perl_warn(aTHX_ "sv_realpath: closedir(\"%s\"): %s",
- dotdots, Strerror(errno));
- SV_CWD_RETURN_UNDEF;
- }
-#endif
- }
- }
-
- SvCUR_set(sv, pathlen);
- SvPOK_only(sv);
-
- return TRUE;
-#endif
-#else
- return FALSE;
-#endif
-}
https://perl5.git.perl.org / perl5.git / blobdiff