X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/af80dd863acea8450a9f41ae03645f4d69dad091..c49a809bf96a6f9d6e8f048bb237650dc7f6ccf9:/perl.c

diff --git a/perl.c b/perl.c
index 5f85fd7..8f5f7c0 100644
--- a/perl.c
+++ b/perl.c
@@ -13,7 +13,7 @@
 /*
  *      A ship then new they built for him
  *      of mithril and of elven-glass
- *              --from Bilbo's song of Eärendil
+ *              --from Bilbo's song of Eärendil
  *
  *     [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"]
  */
@@ -38,15 +38,15 @@
 #include "nwutil.h"	
 #endif
 
-/* XXX If this causes problems, set i_unistd=undef in the hint file.  */
-#ifdef I_UNISTD
-#include <unistd.h>
+#ifdef USE_KERN_PROC_PATHNAME
+#  include <sys/sysctl.h>
+#endif
+
+#ifdef USE_NSGETEXECUTABLEPATH
+#  include <mach-o/dyld.h>
 #endif
 
 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
-#  ifdef I_SYS_WAIT
-#   include <sys/wait.h>
-#  endif
 #  ifdef I_SYSUIO
 #    include <sys/uio.h>
 #  endif
@@ -983,10 +983,8 @@ perl_destruct(pTHXx)
 
     /* clear utf8 character classes */
     SvREFCNT_dec(PL_utf8_alnum);
-    SvREFCNT_dec(PL_utf8_ascii);
     SvREFCNT_dec(PL_utf8_alpha);
     SvREFCNT_dec(PL_utf8_space);
-    SvREFCNT_dec(PL_utf8_cntrl);
     SvREFCNT_dec(PL_utf8_graph);
     SvREFCNT_dec(PL_utf8_digit);
     SvREFCNT_dec(PL_utf8_upper);
@@ -1003,10 +1001,8 @@ perl_destruct(pTHXx)
     SvREFCNT_dec(PL_utf8_idcont);
     SvREFCNT_dec(PL_utf8_foldclosures);
     PL_utf8_alnum	= NULL;
-    PL_utf8_ascii	= NULL;
     PL_utf8_alpha	= NULL;
     PL_utf8_space	= NULL;
-    PL_utf8_cntrl	= NULL;
     PL_utf8_graph	= NULL;
     PL_utf8_digit	= NULL;
     PL_utf8_upper	= NULL;
@@ -1160,7 +1156,7 @@ perl_destruct(pTHXx)
 	for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) {
 	    svend = &sva[SvREFCNT(sva)];
 	    for (sv = sva + 1; sv < svend; ++sv) {
-		if (SvTYPE(sv) != SVTYPEMASK) {
+		if (SvTYPE(sv) != (svtype)SVTYPEMASK) {
 		    PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
 			" flags=0x%"UVxf
 			" refcnt=%"UVuf pTHX__FORMAT "\n"
@@ -1389,54 +1385,81 @@ Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
     ++PL_exitlistlen;
 }
 
-#ifdef HAS_PROCSELFEXE
-/* This is a function so that we don't hold on to MAXPATHLEN
-   bytes of stack longer than necessary
- */
-STATIC void
-S_procself_val(pTHX_ SV *sv, const char *arg0)
-{
-    char buf[MAXPATHLEN];
-    int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
-
-    /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
-       includes a spurious NUL which will cause $^X to fail in system
-       or backticks (this will prevent extensions from being built and
-       many tests from working). readlink is not meant to add a NUL.
-       Normal readlink works fine.
-     */
-    if (len > 0 && buf[len-1] == '\0') {
-      len--;
-    }
-
-    /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
-       returning the text "unknown" from the readlink rather than the path
-       to the executable (or returning an error from the readlink).  Any valid
-       path has a '/' in it somewhere, so use that to validate the result.
-       See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
-    */
-    if (len > 0 && memchr(buf, '/', len)) {
-	sv_setpvn(sv,buf,len);
-    }
-    else {
-	sv_setpv(sv,arg0);
-    }
-}
-#endif /* HAS_PROCSELFEXE */
-
 STATIC void
 S_set_caret_X(pTHX) {
     dVAR;
     GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
     if (tmpgv) {
-#ifdef HAS_PROCSELFEXE
-	S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
+	SV *const caret_x = GvSV(tmpgv);
+#if defined(OS2)
+	sv_setpv(caret_x, os2_execname(aTHX));
 #else
-#ifdef OS2
-	sv_setpv(GvSVn(tmpgv), os2_execname(aTHX));
-#else
-	sv_setpv(GvSVn(tmpgv),PL_origargv[0]);
-#endif
+#  ifdef USE_KERN_PROC_PATHNAME
+	size_t size = 0;
+	int mib[4];
+	mib[0] = CTL_KERN;
+	mib[1] = KERN_PROC;
+	mib[2] = KERN_PROC_PATHNAME;
+	mib[3] = -1;
+
+	if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
+	    && size > 0 && size < MAXPATHLEN * MAXPATHLEN) {
+	    sv_grow(caret_x, size);
+
+	    if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
+		&& size > 2) {
+		SvPOK_only(caret_x);
+		SvCUR_set(caret_x, size - 1);
+		SvTAINT(caret_x);
+		return;
+	    }
+	}
+#  elif defined(USE_NSGETEXECUTABLEPATH)
+	char buf[1];
+	uint32_t size = sizeof(buf);
+
+	_NSGetExecutablePath(buf, &size);
+	if (size < MAXPATHLEN * MAXPATHLEN) {
+	    sv_grow(caret_x, size);
+	    if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
+		char *const tidied = realpath(SvPVX(caret_x), NULL);
+		if (tidied) {
+		    sv_setpv(caret_x, tidied);
+		    free(tidied);
+		} else {
+		    SvPOK_only(caret_x);
+		    SvCUR_set(caret_x, size);
+		}
+		return;
+	    }
+	}
+#  elif defined(HAS_PROCSELFEXE)
+	char buf[MAXPATHLEN];
+	int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
+
+	/* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
+	   includes a spurious NUL which will cause $^X to fail in system
+	   or backticks (this will prevent extensions from being built and
+	   many tests from working). readlink is not meant to add a NUL.
+	   Normal readlink works fine.
+	*/
+	if (len > 0 && buf[len-1] == '\0') {
+	    len--;
+	}
+
+	/* FreeBSD's implementation is acknowledged to be imperfect, sometimes
+	   returning the text "unknown" from the readlink rather than the path
+	   to the executable (or returning an error from the readlink). Any
+	   valid path has a '/' in it somewhere, so use that to validate the
+	   result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
+	*/
+	if (len > 0 && memchr(buf, '/', len)) {
+	    sv_setpvn(caret_x, buf, len);
+	    return;
+	}
+#  endif
+	/* Fallback to this:  */
+	sv_setpv(caret_x, PL_origargv[0]);
 #endif
     }
 }
@@ -1659,6 +1682,9 @@ S_Internals_V(pTHX_ CV *cv)
 #  ifdef DEBUGGING
 			     " DEBUGGING"
 #  endif
+#  ifdef HOMEGROWN_POSIX_SIGNALS
+			     " HOMEGROWN_POSIX_SIGNALS"
+#  endif
 #  ifdef NO_MATHOMS
 			     " NO_MATHOMS"
 #  endif