1 /* caretx.c
2 *
3 * Copyright (C) 2013
4 * by Larry Wall and others
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11 /*
12 * 'I do not know clearly,' said Frodo; 'but the path climbs, I think,
13 * up into the mountains on the northern side of that vale where the old
14 * city stands. It goes up to a high cleft and so down to -- that which
15 * is beyond.'
16 * 'Do you know the name of that high pass?' said Faramir.
17 *
18 * [p.691 of _The Lord of the Rings_, IV/xi: "The Forbidden Pool"]
19 */
20
21 /* This file contains a single function, set_caret_X, to set the $^X
22 * variable. It's only used in perl.c, but has various OS dependencies,
23 * so its been moved to its own file to reduce header pollution.
24 * See RT 120314 for details.
25 */
26
27 #if defined(PERL_IS_MINIPERL) && !defined(USE_SITECUSTOMIZE)
28 # define USE_SITECUSTOMIZE
29 #endif
30
31 #include "EXTERN.h"
32 #include "perl.h"
33 #include "XSUB.h"
34
35 #ifdef USE_KERN_PROC_PATHNAME
36 # include <sys/sysctl.h>
37 #endif
38
39 #ifdef USE_NSGETEXECUTABLEPATH
40 # include <mach-o/dyld.h>
41 #endif
42
43 /* Note: Functions in this file must not have bool parameters. When
44 PERL_BOOL_AS_CHAR is #defined, mach-o/dyld.h overrides it in this file
45 by #including stdbool.h, so the function parameters here would conflict
46 with those in proto.h.
47 */
48
49 void
Perl_set_caret_X(pTHX)50 Perl_set_caret_X(pTHX) {
51 GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
52 SV *const caret_x = GvSV(tmpgv);
53 #if defined(OS2)
54 sv_setpv(caret_x, os2_execname(aTHX));
55 return;
56 #elif defined(WIN32)
57 char *ansi;
58 WCHAR widename[MAX_PATH];
59 GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR));
60 ansi = win32_ansipath(widename);
61 sv_setpv(caret_x, ansi);
62 win32_free(ansi);
63 return;
64 #else
65 /* We can try a platform-specific one if possible; if it fails, or we
66 * aren't running on a suitable platform, we'll fall back to argv[0]. */
67 # ifdef USE_KERN_PROC_PATHNAME
68 size_t size = 0;
69 int mib[4];
70 mib[0] = CTL_KERN;
71 mib[1] = KERN_PROC;
72 mib[2] = KERN_PROC_PATHNAME;
73 mib[3] = -1;
74
75 if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
76 && inRANGE(size, 1, -1 + MAXPATHLEN * MAXPATHLEN)) {
77 sv_grow(caret_x, size);
78
79 if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
80 && size > 2) {
81 SvPOK_only(caret_x);
82 SvCUR_set(caret_x, size - 1);
83 SvTAINT(caret_x);
84 return;
85 }
86 }
87 # elif defined(USE_NSGETEXECUTABLEPATH)
88 char buf[1];
89 uint32_t size = sizeof(buf);
90
91 _NSGetExecutablePath(buf, &size);
92 if (size < MAXPATHLEN * MAXPATHLEN) {
93 sv_grow(caret_x, size);
94 if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
95 char *const tidied = realpath(SvPVX(caret_x), NULL);
96 if (tidied) {
97 sv_setpv(caret_x, tidied);
98 free(tidied);
99 } else {
100 SvPOK_only(caret_x);
101 SvCUR_set(caret_x, size);
102 }
103 return;
104 }
105 }
106 # elif defined(HAS_PROCSELFEXE)
107 char buf[MAXPATHLEN];
108 SSize_t len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
109 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
110 * it is impossible to know whether the result was truncated. */
111
112 if (len != -1) {
113 buf[len] = '\0';
114 }
115
116 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
117 includes a spurious NUL which will cause $^X to fail in system
118 or backticks (this will prevent extensions from being built and
119 many tests from working). readlink is not meant to add a NUL.
120 Normal readlink works fine.
121 */
122 if (len > 0 && buf[len-1] == '\0') {
123 len--;
124 }
125
126 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
127 returning the text "unknown" from the readlink rather than the path
128 to the executable (or returning an error from the readlink). Any
129 valid path has a '/' in it somewhere, so use that to validate the
130 result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
131 */
132 if (len > 0 && memchr(buf, '/', len)) {
133 sv_setpvn(caret_x, buf, len);
134 return;
135 }
136 # endif
137 /* Fallback to this: */
138 sv_setpv(caret_x, PL_origargv[0]);
139 #endif
140 }
141
142 /*
143 * ex: set ts=8 sts=4 sw=4 et:
144 */
145