| 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 | 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 |
| 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 |
| 80 | && size > 0 && size < MAXPATHLEN * MAXPATHLEN) { |
| 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; |
| 89 | } |
| 90 | } |
| 91 | # elif defined(USE_NSGETEXECUTABLEPATH) |
| 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); |
| 106 | } |
| 107 | return; |
| 108 | } |
| 109 | } |
| 110 | # elif defined(HAS_PROCSELFEXE) |
| 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. */ |
| 115 | |
| 116 | if (len != -1) { |
| 117 | buf[len] = '\0'; |
| 118 | } |
| 119 | |
| 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 | } |
| 129 | |
| 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 | } |
| 140 | # endif |
| 141 | /* Fallback to this: */ |
| 142 | sv_setpv(caret_x, PL_origargv[0]); |
| 143 | #endif |
| 144 | } |
| 145 | |
| 146 | /* |
| 147 | * ex: set ts=8 sts=4 sw=4 et: |
| 148 | */ |