Move the function to set $^X to its own file

This also moves the indirect dependency on stdbool.h to its
own file, rather than being pulled in for all of perl.c, for
those cases where one may want to test using other definitions
of bool.

8 files changed, 137 insertions, 94 deletions

diff --git a/MANIFEST b/MANIFEST
index 2d94da43f0..5494384aa6 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3,6 +3,7 @@ AUTHORS			Contact info for contributors
 autodoc.pl		Creates pod/perlintern.pod and pod/perlapi.pod
 av.c			Array value code
 av.h			Array value header
+caretx.c		C file to create $^X
 cflags.SH		A script that emits C compilation flags per file
 Changes			Describe how to peruse changes between releases
 charclass_invlists.h	Compiled-in inversion lists
diff --git a/Makefile.SH b/Makefile.SH
index 25dcb8174b..bbd3313504 100755
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -487,7 +487,7 @@ h = $(h1) $(h2) $(h3) $(h4) $(h5) $(h6)
 c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c mro.c perl.c
 c2 = perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c sv.c
 c3 = taint.c toke.c util.c deb.c run.c universal.c pad.c globals.c keywords.c
-c4 = perlio.c perlapi.c numeric.c mathoms.c locale.c pp_pack.c pp_sort.c
+c4 = perlio.c perlapi.c numeric.c mathoms.c locale.c pp_pack.c pp_sort.c caretx.c
 c5 = $(madlysrc) $(mallocsrc)
 
 c = $(c1) $(c2) $(c3) $(c4) $(c5) miniperlmain.c opmini.c perlmini.c
@@ -496,7 +496,7 @@ obj0 = op$(OBJ_EXT) perl$(OBJ_EXT)
 obj0mini = perlmini$(OBJ_EXT) opmini$(OBJ_EXT) miniperlmain$(OBJ_EXT)
 obj1 = $(madlyobj) $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT) mro$(OBJ_EXT) keywords$(OBJ_EXT)
 obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT)
-obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) mathoms$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) pp_sort$(OBJ_EXT)
+obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) mathoms$(OBJ_EXT) locale$(OBJ_EXT) pp_pack$(OBJ_EXT) pp_sort$(OBJ_EXT) caretx$(OBJ_EXT)
 
 minindt_obj = $(obj0mini) $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
 mini_obj = $(minindt_obj) $(MINIDTRACE_O)
diff --git a/caretx.c b/caretx.c
new file mode 100644
index 0000000000..184c7d04fd
--- /dev/null
+++ b/caretx.c
@@ -0,0 +1,128 @@
+/*    caretx.c
+ *
+ *    Copyright (C) 2013
+ *     by Larry Wall and others
+ *
+ *    You may distribute under the terms of either the GNU General Public
+ *    License or the Artistic License, as specified in the README file.
+ *
+ */
+
+/*
+ *     TODO: Quote
+ */
+
+/* This file contains a single function, set_caret_X, to set the $^X
+ * variable.  It's only used in perl.c, but has various OS dependencies,
+ * so its been moved to its own file to reduce header pollution.
+ * See RT 120314 for details.
+ */
+
+#if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
+#  define USE_SITECUSTOMIZE
+#endif
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef NETWARE
+#include "nwutil.h"
+#endif
+
+#ifdef USE_KERN_PROC_PATHNAME
+#  include <sys/sysctl.h>
+#endif
+
+#ifdef USE_NSGETEXECUTABLEPATH
+# include <mach-o/dyld.h>
+#endif
+
+void
+Perl_set_caret_X(pTHX) {
+    dVAR;
+    GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
+    if (tmpgv) {
+        SV *const caret_x = GvSV(tmpgv);
+#if defined(OS2)
+        sv_setpv(caret_x, os2_execname(aTHX));
+#else
+#  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
+    }
+}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: nil
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 et:
+ */
diff --git a/embed.fnc b/embed.fnc
index dc9f17bd5d..7d50d0b863 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1261,6 +1261,8 @@ Apd	|NV	|scan_oct	|NN const char* start|STRLEN len|NN STRLEN* retlen
 AMpd	|OP*	|op_scope	|NULLOK OP* o
 Ap	|char*	|screaminstr	|NN SV *bigstr|NN SV *littlestr|I32 start_shift \
 				|I32 end_shift|NN I32 *old_posp|I32 last
+: Only used by perl.c/miniperl.c, but defined in caretx.c
+px	|void	|set_caret_X
 Apd	|void	|setdefout	|NN GV* gv
 Ap	|HEK*	|share_hek	|NN const char* str|I32 len|U32 hash
 #if defined(HAS_SIGACTION) && defined(SA_SIGINFO)
diff --git a/embed.h b/embed.h
index 3dd7978603..eb945432cc 100644
--- a/embed.h
+++ b/embed.h
@@ -1233,6 +1233,7 @@
 #define sawparens(a)		Perl_sawparens(aTHX_ a)
 #define scalar(a)		Perl_scalar(aTHX_ a)
 #define scalarvoid(a)		Perl_scalarvoid(aTHX_ a)
+#define set_caret_X()		Perl_set_caret_X(aTHX)
 #define sub_crush_depth(a)	Perl_sub_crush_depth(aTHX_ a)
 #define sv_2num(a)		Perl_sv_2num(aTHX_ a)
 #define sv_clean_all()		Perl_sv_clean_all(aTHX)
diff --git a/perl.c b/perl.c
index 15adb8abdf..6939f860a7 100644
--- a/perl.c
+++ b/perl.c
@@ -38,10 +38,6 @@
 #include "nwutil.h"	
 #endif
 
-#ifdef USE_KERN_PROC_PATHNAME
-#  include <sys/sysctl.h>
-#endif
-
 #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
 #  ifdef I_SYSUIO
 #    include <sys/uio.h>
@@ -1418,85 +1414,6 @@ Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
     ++PL_exitlistlen;
 }
 
-STATIC void
-S_set_caret_X(pTHX) {
-    dVAR;
-    GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
-    if (tmpgv) {
-	SV *const caret_x = GvSV(tmpgv);
-#if defined(OS2)
-	sv_setpv(caret_x, os2_execname(aTHX));
-#else
-#  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
-    }
-}
-
 /*
 =for apidoc perl_parse
 
@@ -1646,7 +1563,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
 	init_ids();
 	assert (!TAINT_get);
 	TAINT;
-	S_set_caret_X(aTHX);
+	set_caret_X();
 	TAINT_NOT;
 	init_postdump_symbols(argc,argv,env);
 	return 0;
@@ -2121,7 +2038,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     /* and for SITELIB_EXP in USE_SITECUSTOMIZE                            */
     assert (!TAINT_get);
     TAINT;
-    S_set_caret_X(aTHX);
+    set_caret_X();
     TAINT_NOT;
 
 #if defined(USE_SITECUSTOMIZE)
diff --git a/perl.h b/perl.h
index 0a8beda7d0..dc140bdfcf 100644
--- a/perl.h
+++ b/perl.h
@@ -2298,13 +2298,6 @@ typedef SV PADNAME;
 # define PERL_SAWAMPERSAND
 #endif
 
-/* Include mach-o/dyld.h here for perl.c’s sake, since it may #define bool,
-   and handy.h needs to be able to re#define it under
-  -Accflags=-DPERL_BOOL_AS_CHAR. */
-#if defined(USE_NSGETEXECUTABLEPATH) && defined(PERL_IN_PERL_C)
-# include <mach-o/dyld.h>
-#endif
-
 #include "handy.h"
 
 #if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_RAWIO)
diff --git a/proto.h b/proto.h
index 4fd57981c3..07729d27e8 100644
--- a/proto.h
+++ b/proto.h
@@ -3811,6 +3811,7 @@ PERL_CALLCONV char*	Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_
 	assert(bigstr); assert(littlestr); assert(old_posp)
 
 PERL_CALLCONV U32	Perl_seed(pTHX);
+PERL_CALLCONV void	Perl_set_caret_X(pTHX);
 PERL_CALLCONV void	Perl_set_context(void *t)
 			__attribute__nonnull__(1);
 #define PERL_ARGS_ASSERT_SET_CONTEXT	\