Commit | Line | Data |
---|---|---|
e2051532 PM |
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 | /* | |
7d087888 FC |
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 | * | |
97a07f93 | 18 | * [p.691 of _The Lord of the Rings_, IV/xi: "The Forbidden Pool"] |
e2051532 PM |
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 | ||
e2051532 PM |
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 | void | |
44 | Perl_set_caret_X(pTHX) { | |
e2051532 | 45 | GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */ |
eb4e1bae | 46 | SV *const caret_x = GvSV(tmpgv); |
e2051532 | 47 | #if defined(OS2) |
eb4e1bae | 48 | sv_setpv(caret_x, os2_execname(aTHX)); |
03b94aa4 AC |
49 | return; |
50 | #elif defined(WIN32) | |
51 | char *ansi; | |
52 | WCHAR widename[MAX_PATH]; | |
53 | GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR)); | |
54 | ansi = win32_ansipath(widename); | |
55 | sv_setpv(caret_x, ansi); | |
56 | win32_free(ansi); | |
57 | return; | |
58 | #else | |
59 | /* We can try a platform-specific one if possible; if it fails, or we | |
60 | * aren't running on a suitable platform, we'll fall back to argv[0]. */ | |
61 | # ifdef USE_KERN_PROC_PATHNAME | |
eb4e1bae DD |
62 | size_t size = 0; |
63 | int mib[4]; | |
64 | mib[0] = CTL_KERN; | |
65 | mib[1] = KERN_PROC; | |
66 | mib[2] = KERN_PROC_PATHNAME; | |
67 | mib[3] = -1; | |
68 | ||
69 | if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0 | |
7682fe5f | 70 | && inRANGE(size, 1, -1 + MAXPATHLEN * MAXPATHLEN)) { |
eb4e1bae DD |
71 | sv_grow(caret_x, size); |
72 | ||
73 | if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0 | |
74 | && size > 2) { | |
75 | SvPOK_only(caret_x); | |
76 | SvCUR_set(caret_x, size - 1); | |
77 | SvTAINT(caret_x); | |
78 | return; | |
e2051532 | 79 | } |
eb4e1bae | 80 | } |
03b94aa4 | 81 | # elif defined(USE_NSGETEXECUTABLEPATH) |
eb4e1bae DD |
82 | char buf[1]; |
83 | uint32_t size = sizeof(buf); | |
84 | ||
85 | _NSGetExecutablePath(buf, &size); | |
86 | if (size < MAXPATHLEN * MAXPATHLEN) { | |
87 | sv_grow(caret_x, size); | |
88 | if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) { | |
89 | char *const tidied = realpath(SvPVX(caret_x), NULL); | |
90 | if (tidied) { | |
91 | sv_setpv(caret_x, tidied); | |
92 | free(tidied); | |
93 | } else { | |
94 | SvPOK_only(caret_x); | |
95 | SvCUR_set(caret_x, size); | |
e2051532 | 96 | } |
eb4e1bae | 97 | return; |
e2051532 | 98 | } |
eb4e1bae | 99 | } |
03b94aa4 | 100 | # elif defined(HAS_PROCSELFEXE) |
eb4e1bae DD |
101 | char buf[MAXPATHLEN]; |
102 | SSize_t len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1); | |
103 | /* NOTE: if the length returned by readlink() is sizeof(buf) - 1, | |
104 | * it is impossible to know whether the result was truncated. */ | |
51b468f6 | 105 | |
eb4e1bae DD |
106 | if (len != -1) { |
107 | buf[len] = '\0'; | |
108 | } | |
e2051532 | 109 | |
eb4e1bae DD |
110 | /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe) |
111 | includes a spurious NUL which will cause $^X to fail in system | |
112 | or backticks (this will prevent extensions from being built and | |
113 | many tests from working). readlink is not meant to add a NUL. | |
114 | Normal readlink works fine. | |
115 | */ | |
116 | if (len > 0 && buf[len-1] == '\0') { | |
117 | len--; | |
118 | } | |
e2051532 | 119 | |
eb4e1bae DD |
120 | /* FreeBSD's implementation is acknowledged to be imperfect, sometimes |
121 | returning the text "unknown" from the readlink rather than the path | |
122 | to the executable (or returning an error from the readlink). Any | |
123 | valid path has a '/' in it somewhere, so use that to validate the | |
124 | result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703 | |
125 | */ | |
126 | if (len > 0 && memchr(buf, '/', len)) { | |
127 | sv_setpvn(caret_x, buf, len); | |
128 | return; | |
129 | } | |
03b94aa4 | 130 | # endif |
eb4e1bae DD |
131 | /* Fallback to this: */ |
132 | sv_setpv(caret_x, PL_origargv[0]); | |
e2051532 | 133 | #endif |
e2051532 PM |
134 | } |
135 | ||
136 | /* | |
e2051532 PM |
137 | * ex: set ts=8 sts=4 sw=4 et: |
138 | */ |