# include <sys/wait.h>
#endif
-#ifdef I_LOCALE
-# include <locale.h>
-#endif
-
#define FLUSH
#ifdef LEAKTEST
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
s--, i++;
}
}
- sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */
+ sv_magic(sv, Nullsv, PERL_MAGIC_bm, Nullch, 0); /* deep magic */
SvVALID_on(sv);
s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
#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)
{
}
if (pid == 0) {
/* Child */
- GV* tmpgv;
- int fd;
#undef THIS
#undef THAT
#define THIS that
}
#if !defined(HAS_FCNTL) || !defined(F_SETFD)
/* No automatic close - do it by hand */
-#ifndef NOFILE
-#define NOFILE 20
-#endif
- for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
- if (fd != pp[1])
- PerlLIO_close(fd);
+# ifndef NOFILE
+# define NOFILE 20
+# endif
+ {
+ int fd;
+
+ for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++) {
+ if (fd != pp[1])
+ PerlLIO_close(fd);
+ }
}
#endif
do_aexec5(Nullsv, args-1, args-1+n, pp[1], did_pipes);
#ifndef NOFILE
#define NOFILE 20
#endif
- for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
- if (fd != pp[1])
- PerlLIO_close(fd);
+ {
+ int fd;
+
+ for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
+ if (fd != pp[1])
+ PerlLIO_close(fd);
+ }
#endif
- do_exec3(cmd,pp[1],did_pipes); /* may or may not use the shell */
+ /* may or may not use the shell */
+ do_exec3(cmd, pp[1], did_pipes);
PerlProc__exit(1);
}
#endif /* defined OS2 */
Pid_t pid;
Pid_t pid2;
bool close_failed;
- int saved_errno;
+ int saved_errno = 0;
#ifdef VMS
int saved_vaxc_errno;
#endif
I32
Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
{
+ if (!pid)
+ return -1;
+#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
+ {
SV *sv;
SV** svp;
char spid[TYPE_CHARS(int)];
- if (!pid)
- return -1;
-#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
if (pid > 0) {
sprintf(spid, "%"IVdf, (IV)pid);
svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
(void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
return pid;
}
+ }
}
#endif
#ifdef HAS_WAITPID
}
}
-U32
-Perl_cast_ulong(pTHX_ NV f)
-{
- long along;
-
-#if CASTFLAGS & 2
-# define BIGDOUBLE 2147483648.0
- if (f >= BIGDOUBLE)
- return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
-#endif
- if (f >= 0.0)
- return (unsigned long)f;
- along = (long)f;
- return (unsigned long)along;
-}
-# undef BIGDOUBLE
-
-/* Unfortunately, on some systems the cast_uv() function doesn't
- work with the system-supplied definition of ULONG_MAX. The
- comparison (f >= ULONG_MAX) always comes out true. It must be a
- problem with the compiler constant folding.
-
- In any case, this workaround should be fine on any two's complement
- system. If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
- ccflags.
- --Andy Dougherty <doughera@lafcol.lafayette.edu>
-*/
-
-/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
- of LONG_(MIN/MAX).
- -- Kenneth Albanowski <kjahds@kjahds.com>
-*/
-
-#ifndef MY_UV_MAX
-# define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
-#endif
-
-I32
-Perl_cast_i32(pTHX_ NV f)
-{
- if (f >= I32_MAX)
- return (I32) I32_MAX;
- if (f <= I32_MIN)
- return (I32) I32_MIN;
- return (I32) f;
-}
-
-IV
-Perl_cast_iv(pTHX_ NV f)
-{
- if (f >= IV_MAX) {
- UV uv;
-
- if (f >= (NV)UV_MAX)
- return (IV) UV_MAX;
- uv = (UV) f;
- return (IV)uv;
- }
- if (f <= IV_MIN)
- return (IV) IV_MIN;
- return (IV) f;
-}
-
-UV
-Perl_cast_uv(pTHX_ NV f)
-{
- if (f >= MY_UV_MAX)
- return (UV) MY_UV_MAX;
- if (f < 0) {
- IV iv;
-
- if (f < IV_MIN)
- return (UV)IV_MIN;
- iv = (IV) f;
- return (UV) iv;
- }
- return (UV) f;
-}
-
#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)
{
return (void*)t;
# else
# ifdef I_MACH_CTHREADS
- return (void*)cthread_data(cthread_self());
+ return (void*)cthread_data(cthread_self());
# else
-# if defined(__ALPHA) && (__VMS_VER >= 70000000)
- return (void*)pthread_unchecked_getspecific_np(PL_thr_key);
-# else
- return (void*)pthread_getspecific(PL_thr_key);
-# endif
-# endif
+ return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
+# endif
# endif
#else
return (void*)NULL;
MAGIC *mg;
SvUPGRADE(sv, SVt_PVMG);
- mg = mg_find(sv, 'm');
+ mg = mg_find(sv, PERL_MAGIC_mutex);
if (!mg) {
condpair_t *cp;
COND_INIT(&cp->cond);
cp->owner = 0;
LOCK_CRED_MUTEX; /* XXX need separate mutex? */
- mg = mg_find(sv, 'm');
+ mg = mg_find(sv, PERL_MAGIC_mutex);
if (mg) {
/* someone else beat us to initialising it */
UNLOCK_CRED_MUTEX; /* XXX need separate mutex? */
Safefree(cp);
}
else {
- sv_magic(sv, Nullsv, 'm', 0, 0);
+ sv_magic(sv, Nullsv, PERL_MAGIC_mutex, 0, 0);
mg = SvMAGIC(sv);
mg->mg_ptr = (char *)cp;
mg->mg_len = sizeof(cp);
if (*svp && *svp != &PL_sv_undef) {
SV *sv = newSVsv(*svp);
av_store(thr->threadsv, i, sv);
- sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1);
+ sv_magic(sv, 0, PERL_MAGIC_sv, &PL_threadsv_names[i], 1);
DEBUG_S(PerlIO_printf(Perl_debug_log,
"new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
(IV)i, t, thr));
}
#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(s, x);
- SET_NUMERIC_STANDARD();
- Perl_atof2(s, y);
- SET_NUMERIC_LOCAL();
- if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
- return y;
- }
- else
- Perl_atof2(s, x);
-#else
- Perl_atof2(s, x);
-#endif
- return x;
-}
-
void
Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
{
New(0, buf, buflen, char);
len = strftime(buf, buflen, fmt, &mytm);
/*
- ** The following is needed to handle to the situation where
+ ** The following is needed to handle to the situation where
** tmpbuf overflows. Basically we want to allocate a buffer
** and try repeatedly. The reason why it is so complicated
** is that getting a return value of 0 from strftime can indicate
/* Possibly buf overflowed - try again with a bigger buf */
int fmtlen = strlen(fmt);
int bufsize = fmtlen + buflen;
-
+
New(0, buf, bufsize, char);
while (buf) {
buflen = strftime(buf, bufsize, fmt, &mytm);
#endif
}
+
+#define SV_CWD_RETURN_UNDEF \
+sv_setsv(sv, &PL_sv_undef); \
+return FALSE
+
+#define SV_CWD_ISDOT(dp) \
+ (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \
+ (dp->d_name[1] == '.' && dp->d_name[2] == '\0')))
+
+/*
+=for apidoc sv_getcwd
+
+Fill the sv with current working directory
+
+=cut
+*/
+
+/* Originally written in Perl by John Bazik; rewritten in C by Ben Sugars.
+ * rewritten again by dougm, optimized for use with xs TARG, and to prefer
+ * getcwd(3) if available
+ * Comments from the orignal:
+ * This is a faster version of getcwd. It's also more dangerous
+ * 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
+ 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) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ orig_cdev = statbuf.st_dev;
+ orig_cino = statbuf.st_ino;
+ cdev = orig_cdev;
+ cino = orig_cino;
+
+ for (;;) {
+ odev = cdev;
+ oino = cino;
+
+ if (PerlDir_chdir("..") < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+ if (PerlLIO_stat(".", &statbuf) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ cdev = statbuf.st_dev;
+ cino = statbuf.st_ino;
+
+ if (odev == cdev && oino == cino) {
+ break;
+ }
+ if (!(dir = PerlDir_open("."))) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ while ((dp = PerlDir_read(dir)) != NULL) {
+#ifdef DIRNAMLEN
+ namelen = dp->d_namlen;
+#else
+ namelen = strlen(dp->d_name);
+#endif
+ /* skip . and .. */
+ if (SV_CWD_ISDOT(dp)) {
+ continue;
+ }
+
+ if (PerlLIO_lstat(dp->d_name, &statbuf) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ tdev = statbuf.st_dev;
+ tino = statbuf.st_ino;
+ if (tino == oino && tdev == odev) {
+ break;
+ }
+ }
+
+ if (!dp) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ SvGROW(sv, pathlen + namelen + 1);
+
+ if (pathlen) {
+ /* shift down */
+ Move(SvPVX(sv), SvPVX(sv) + namelen + 1, pathlen, char);
+ }
+
+ /* prepend current directory to the front */
+ *SvPVX(sv) = '/';
+ Move(dp->d_name, SvPVX(sv)+1, namelen, char);
+ pathlen += (namelen + 1);
+
+#ifdef VOID_CLOSEDIR
+ PerlDir_close(dir);
+#else
+ if (PerlDir_close(dir) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+#endif
+ }
+
+ SvCUR_set(sv, pathlen);
+ *SvEND(sv) = '\0';
+ SvPOK_only(sv);
+
+ if (PerlDir_chdir(SvPVX(sv)) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+ if (PerlLIO_stat(".", &statbuf) < 0) {
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ cdev = statbuf.st_dev;
+ cino = statbuf.st_ino;
+
+ if (cdev != orig_cdev || cino != orig_cino) {
+ Perl_croak(aTHX_ "Unstable directory path, "
+ "current directory changed unexpectedly");
+ }
+#endif
+
+ return TRUE;
+#else
+ return FALSE;
+#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;
+
+ /* Don't use strlen() to avoid running off the end. */
+ s = memchr(path, '\0', MAXPATHLEN);
+ pathlen = s ? s - path : MAXPATHLEN;
+
+#ifdef HAS_REALPATH
+
+ /* Be paranoid about the use of realpath(),
+ * it is an infamous source of buffer overruns. */
+
+ /* Is the source buffer too long? */
+ 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