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