Add Ken Brown to AUTHORS
[perl.git] / caretx.c
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 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
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
53 void
54 Perl_set_caret_X(pTHX) {
55     GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */
56     SV *const caret_x = GvSV(tmpgv);
57 #if defined(OS2)
58     sv_setpv(caret_x, os2_execname(aTHX));
59 #else
60 #  ifdef USE_KERN_PROC_PATHNAME
61     size_t size = 0;
62     int mib[4];
63     mib[0] = CTL_KERN;
64     mib[1] = KERN_PROC;
65     mib[2] = KERN_PROC_PATHNAME;
66     mib[3] = -1;
67
68     if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0
69         && size > 0 && size < MAXPATHLEN * MAXPATHLEN) {
70         sv_grow(caret_x, size);
71
72         if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0
73             && size > 2) {
74             SvPOK_only(caret_x);
75             SvCUR_set(caret_x, size - 1);
76             SvTAINT(caret_x);
77             return;
78         }
79     }
80 #  elif defined(USE_NSGETEXECUTABLEPATH)
81     char buf[1];
82     uint32_t size = sizeof(buf);
83
84     _NSGetExecutablePath(buf, &size);
85     if (size < MAXPATHLEN * MAXPATHLEN) {
86         sv_grow(caret_x, size);
87         if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) {
88             char *const tidied = realpath(SvPVX(caret_x), NULL);
89             if (tidied) {
90                 sv_setpv(caret_x, tidied);
91                 free(tidied);
92             } else {
93                 SvPOK_only(caret_x);
94                 SvCUR_set(caret_x, size);
95             }
96             return;
97         }
98     }
99 #  elif defined(HAS_PROCSELFEXE)
100     char buf[MAXPATHLEN];
101     SSize_t len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
102     /* NOTE: if the length returned by readlink() is sizeof(buf) - 1,
103      * it is impossible to know whether the result was truncated. */
104
105     if (len != -1) {
106         buf[len] = '\0';
107     }
108
109     /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
110        includes a spurious NUL which will cause $^X to fail in system
111        or backticks (this will prevent extensions from being built and
112        many tests from working). readlink is not meant to add a NUL.
113        Normal readlink works fine.
114     */
115     if (len > 0 && buf[len-1] == '\0') {
116         len--;
117     }
118
119     /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
120        returning the text "unknown" from the readlink rather than the path
121        to the executable (or returning an error from the readlink). Any
122        valid path has a '/' in it somewhere, so use that to validate the
123        result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
124     */
125     if (len > 0 && memchr(buf, '/', len)) {
126         sv_setpvn(caret_x, buf, len);
127         return;
128     }
129 #  elif defined(WIN32)
130     char *ansi;
131     WCHAR widename[MAX_PATH];
132     GetModuleFileNameW(NULL, widename, sizeof(widename)/sizeof(WCHAR));
133     ansi = win32_ansipath(widename);
134     sv_setpv(caret_x, ansi);
135     win32_free(ansi);
136     return;
137 #  endif
138     /* Fallback to this:  */
139     sv_setpv(caret_x, PL_origargv[0]);
140 #endif
141 }
142
143 /*
144  * ex: set ts=8 sts=4 sw=4 et:
145  */