This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlapi: Remove per-thread section; move to real scns
[perl5.git] / caretx.c
CommitLineData
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
35#ifdef NETWARE
36#include "nwutil.h"
37#endif
38
39#ifdef USE_KERN_PROC_PATHNAME
40# include <sys/sysctl.h>
41#endif
42
43#ifdef USE_NSGETEXECUTABLEPATH
44# include <mach-o/dyld.h>
45#endif
46
c9a047cb
FC
47/* Note: Functions in this file must not have bool parameters. When
48 PERL_BOOL_AS_CHAR is #defined, mach-o/dyld.h overrides it in this file
49 by #including stdbool.h, so the function parameters here would conflict
50 with those in proto.h.
51*/
52
e2051532
PM
53void
54Perl_set_caret_X(pTHX) {
e2051532 55 GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
eb4e1bae 56 SV *const caret_x = GvSV(tmpgv);
e2051532 57#if defined(OS2)
eb4e1bae 58 sv_setpv(caret_x, os2_execname(aTHX));
03b94aa4
AC
59 return;
60#elif defined(WIN32)
61 char *ansi;
62 WCHAR widename[MAX_PATH];
63 GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR));
64 ansi = win32_ansipath(widename);
65 sv_setpv(caret_x, ansi);
66 win32_free(ansi);
67 return;
68#else
69 /* We can try a platform-specific one if possible; if it fails, or we
70 * aren't running on a suitable platform, we'll fall back to argv[0]. */
71# ifdef USE_KERN_PROC_PATHNAME
eb4e1bae
DD
72 size_t size = 0;
73 int mib[4];
74 mib[0] = CTL_KERN;
75 mib[1] = KERN_PROC;
76 mib[2] = KERN_PROC_PATHNAME;
77 mib[3] = -1;
78
79 if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
7682fe5f 80 && inRANGE(size, 1, -1 + MAXPATHLEN * MAXPATHLEN)) {
eb4e1bae
DD
81 sv_grow(caret_x, size);
82
83 if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
84 && size > 2) {
85 SvPOK_only(caret_x);
86 SvCUR_set(caret_x, size - 1);
87 SvTAINT(caret_x);
88 return;
e2051532 89 }
eb4e1bae 90 }
03b94aa4 91# elif defined(USE_NSGETEXECUTABLEPATH)
eb4e1bae
DD
92 char buf[1];
93 uint32_t size = sizeof(buf);
94
95 _NSGetExecutablePath(buf, &size);
96 if (size < MAXPATHLEN * MAXPATHLEN) {
97 sv_grow(caret_x, size);
98 if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
99 char *const tidied = realpath(SvPVX(caret_x), NULL);
100 if (tidied) {
101 sv_setpv(caret_x, tidied);
102 free(tidied);
103 } else {
104 SvPOK_only(caret_x);
105 SvCUR_set(caret_x, size);
e2051532 106 }
eb4e1bae 107 return;
e2051532 108 }
eb4e1bae 109 }
03b94aa4 110# elif defined(HAS_PROCSELFEXE)
eb4e1bae
DD
111 char buf[MAXPATHLEN];
112 SSize_t len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
113 /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
114 * it is impossible to know whether the result was truncated. */
51b468f6 115
eb4e1bae
DD
116 if (len != -1) {
117 buf[len] = '\0';
118 }
e2051532 119
eb4e1bae
DD
120 /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
121 includes a spurious NUL which will cause $^X to fail in system
122 or backticks (this will prevent extensions from being built and
123 many tests from working). readlink is not meant to add a NUL.
124 Normal readlink works fine.
125 */
126 if (len > 0 && buf[len-1] == '\0') {
127 len--;
128 }
e2051532 129
eb4e1bae
DD
130 /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
131 returning the text "unknown" from the readlink rather than the path
132 to the executable (or returning an error from the readlink). Any
133 valid path has a '/' in it somewhere, so use that to validate the
134 result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
135 */
136 if (len > 0 && memchr(buf, '/', len)) {
137 sv_setpvn(caret_x, buf, len);
138 return;
139 }
03b94aa4 140# endif
eb4e1bae
DD
141 /* Fallback to this: */
142 sv_setpv(caret_x, PL_origargv[0]);
e2051532 143#endif
e2051532
PM
144}
145
146/*
e2051532
PM
147 * ex: set ts=8 sts=4 sw=4 et:
148 */