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.

1 files changed, 128 insertions, 0 deletions

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:
+ */