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.xxx 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  */