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 */
}
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 (f < 0.0)
+ return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f;
+ if (f < U32_MAX_P1) {
#if CASTFLAGS & 2
-# define BIGDOUBLE 2147483648.0
- if (f >= BIGDOUBLE)
- return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
+ 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
- if (f >= 0.0)
- return (unsigned long)f;
- along = (long)f;
- return (unsigned long)along;
+ }
+ return f > 0 ? U32_MAX : 0 /* NaN */;
}
-# 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;
+ 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) {
- 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;
+ 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 >= 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;
- }
+ 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
Perl_croak_nocontext("panic: pthread_getspecific");
return (void*)t;
# else
-# ifdef I_MACH_CTHREADS
+# ifdef I_MACH_CTHREADS
return (void*)cthread_data(cthread_self());
-# else
- return (void*)pthread_getspecific(PL_thr_key);
-# endif
+# else
+ 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));
if ((PL_hints & HINT_LOCALE) && PL_numeric_local) {
NV y;
- Perl_atof2(s, x);
+ Perl_atof2(aTHX_ s, &x);
SET_NUMERIC_STANDARD();
- Perl_atof2(s, y);
+ Perl_atof2(aTHX_ s, &y);
SET_NUMERIC_LOCAL();
if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
return y;
}
else
- Perl_atof2(s, x);
+ Perl_atof2(aTHX_ s, &x);
#else
- Perl_atof2(s, x);
+ 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)
{
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) {
+ CWDXS_RETURN_SVUNDEF(sv);
+ }
+
+ 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)) {dp->d_name[0] == '.'
+ 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;
+
+#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
+}
projects / p5sagit/p5-mst-13.2.git / blobdiff