~ chicken-core (chicken-5) 52febfc825729ed3c9f24755bc28c08977ff95f7
commit 52febfc825729ed3c9f24755bc28c08977ff95f7
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Tue Mar 17 20:57:16 2015 +1300
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Mon Apr 20 17:08:29 2015 +1200
Move C_path_to_executable into runtime and add executable-pathname procedure
Moves the logic from `C_path_to_executable` into a new function
`C_resolve_executable_pathname` that returns the executable's full
pathname, exposes this as a library procedure `executable-pathname`, and
redefines `C_path_to_executable` as a wrapper for the new function that
simply drops the filename part of the resolved path.
Resolves the executable once, at startup, on platforms that require
searching for it. Uses realpath to resolve pathnames, where supported.
Handles some additional error cases and frees the allocated buffer when
`C_resolve_executable_pathname` fails.
Removes the dependency on CoreFoundation when compiling with a private
repository on Mac OS X by using _NSGetExecutablePath instead of the
CoreFoundation framework's Bundle- and URL-related functions.
Fixes #971.
diff --git a/NEWS b/NEWS
index 8f3c94ce..9ce43cd8 100644
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,8 @@
- Removed support for memory-mapped files (posix), queues (data-structures),
binary-search (data-structures) and object-eviction (lolevel). These
are now available as eggs.
+ - Added the `executable-pathname` procedure for retrieving a path to
+ the currently-running executable.
- Module system
- The compiler has been modularised, for improved namespacing. This
diff --git a/chicken.h b/chicken.h
index 69e0b952..a0af44a9 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1,4 +1,3 @@
-
/* chicken.h - General headerfile for compiler generated executables
;
; Copyright (c) 2008-2014, The CHICKEN Team
@@ -330,6 +329,22 @@ void *alloca ();
# define C_GENERIC_CONSOLE
#endif
+/**
+ * HAVE_EXE_PATH is defined on platforms on which there's a simple way
+ * to retrieve a path to the current executable (such as reading
+ * "/proc/<pid>/exe" or some similar trick).
+ *
+ * SEARCH_EXE_PATH is defined on platforms on which we must search for
+ * the current executable. Because this search is sensitive to things
+ * like CWD, PATH, and so on, it's done once at startup and saved in
+ * `C_main_exe`.
+ */
+#if defined(__linux__) || defined(__sun) || defined(C_MACOSX) || defined(__HAIKU__) || (defined(_WIN32) && !defined(__CYGWIN__))
+# define HAVE_EXE_PATH
+#elif defined(__unix__) || defined(C_XXXBSD) || defined(_AIX)
+# define SEARCH_EXE_PATH
+#endif
+
/* Needed for pre-emptive threading */
#define C_TIMER_INTERRUPTS
@@ -734,14 +749,16 @@ static inline int isinf_ld (long double x)
# define C_SOFTWARE_VERSION "aix"
#elif defined(__GNU__)
# define C_SOFTWARE_VERSION "hurd"
-/* This is as silly as the other limits, there is no PATH_MAX in The Hurd */
-# define PATH_MAX 1024
#else
# define C_SOFTWARE_VERSION "unknown"
#endif
-#define C_MAX_PATH PATH_MAX
-
+/* There is no PATH_MAX in The Hurd. */
+#ifdef PATH_MAX
+# define C_MAX_PATH PATH_MAX
+#else
+# define C_MAX_PATH 1024
+#endif
/* Types: */
@@ -961,6 +978,7 @@ DECL_C_PROC_p0 (128, 1,0,0,0,0,0,0,0)
# define C_fopen fopen
# define C_fclose fclose
# define C_strpbrk strpbrk
+# define C_strcspn strcspn
# define C_snprintf snprintf
# define C_printf printf
# define C_fprintf fprintf
@@ -1688,6 +1706,9 @@ C_varextern C_TLS C_uword
C_heap_shrinkage;
C_varextern C_TLS char
**C_main_argv,
+#ifdef SEARCH_EXE_PATH
+ *C_main_exe,
+#endif
*C_dlerror;
C_varextern C_TLS C_uword C_maximal_heap_size;
C_varextern C_TLS int (*C_gc_mutation_hook)(C_word *slot, C_word val);
@@ -1819,6 +1840,9 @@ C_fctexport int C_do_unregister_finalizer(C_word x);
C_fctexport C_word C_dbg_hook(C_word x);
C_fctexport void C_use_private_repository(C_char *path);
C_fctexport C_char *C_private_repository_path();
+C_fctexport C_char *C_executable_pathname();
+C_fctexport C_char *C_path_to_executable(C_char *fname);
+C_fctexport C_char *C_resolve_executable_pathname(C_char *fname);
C_fctimport void C_ccall C_toplevel(C_word c, C_word self, C_word k) C_noret;
C_fctimport void C_ccall C_invalid_procedure(int c, C_word self, ...) C_noret;
@@ -2012,7 +2036,6 @@ C_fctexport C_word C_fcall C_i_foreign_unsigned_integer64_argumentp(C_word x) C_
C_fctexport C_char *C_lookup_procedure_id(void *ptr);
C_fctexport void *C_lookup_procedure_ptr(C_char *id);
-C_fctexport C_char *C_executable_path();
#ifdef C_SIXTY_FOUR
C_fctexport void C_ccall C_peek_signed_integer_32(C_word c, C_word closure, C_word k, C_word v, C_word index) C_noret;
@@ -2934,169 +2957,36 @@ C_inline size_t C_strlcat(char *dst, const char *src, size_t sz)
}
#endif
-
-#ifdef C_PRIVATE_REPOSITORY
-# if defined(C_MACOSX) && defined(C_GUI)
-# include <CoreFoundation/CoreFoundation.h>
-# elif defined(__HAIKU__)
-# include <kernel/image.h>
-# endif
-
-C_inline C_char *
-C_path_to_executable(C_char *fname)
+/* Safe realpath usage depends on a reliable PATH_MAX. */
+#ifdef PATH_MAX
+# define C_realpath realpath
+#else
+C_inline char *C_realpath(const char *path, char *resolved)
{
- C_char *buffer = (C_char *)C_malloc(C_MAX_PATH);
-
- if(buffer == NULL) return NULL;
-
-# if defined(__linux__) || defined(__sun)
- C_char linkname[64]; /* /proc/<pid>/exe */
- pid_t pid;
- int ret;
-
- pid = C_getpid();
-# ifdef __linux__
- C_snprintf(linkname, sizeof(linkname), "/proc/%i/exe", pid);
-# else
- C_snprintf(linkname, sizeof(linkname), "/proc/%i/path/a.out", pid); /* SunOS / Solaris */
-# endif
- ret = C_readlink(linkname, buffer, C_MAX_PATH - 1);
-
- if(ret == -1 || ret >= C_MAX_PATH - 1)
- return NULL;
-
- for(--ret; ret > 0 && buffer[ ret ] != '/'; --ret);
-
- buffer[ ret ] = '\0';
- return buffer;
-# elif defined(_WIN32) && !defined(__CYGWIN__)
- int i;
- int n = GetModuleFileName(NULL, buffer, C_MAX_PATH - 1);
-
- if(n == 0 || n >= C_MAX_PATH - 1)
- return NULL;
-
- for(i = n - 1; i >= 0 && buffer[ i ] != '\\'; --i);
-
- buffer[ i ] = '\0';
- return buffer;
-# elif defined(C_MACOSX) && defined(C_GUI)
- CFBundleRef bundle = CFBundleGetMainBundle();
- CFURLRef url = CFBundleCopyExecutableURL(bundle);
- int i;
-
- if(CFURLGetFileSystemRepresentation(url, true, buffer, C_MAX_PATH)) {
- for(i = C_strlen(buffer); i >= 0 && buffer[ i ] != '/'; --i);
-
- buffer[ i ] = '\0';
- return buffer;
- }
- else return NULL;
-# elif defined(__unix__) || defined(__unix) || defined(C_XXXBSD) || defined(_AIX)
- int i, j, k, l;
- C_char *path, *dname;
-
- /* found on stackoverflow.com: */
-
- /* no name given (execve) */
- if(fname == NULL) return NULL;
-
- i = C_strlen(fname) - 1;
-
- while(i >= 0 && fname[ i ] != '/') --i;
-
- /* absolute path */
- if(*fname == '/') {
- fname[ i ] = '\0';
- C_strlcpy(buffer, fname, C_MAX_PATH);
- return buffer;
- }
- else {
- /* try current dir */
- if(C_getcwd(buffer, C_MAX_PATH - 1) == NULL)
- return NULL;
-
- C_strlcat(buffer, "/", C_MAX_PATH);
- C_strlcat(buffer, fname, C_MAX_PATH);
-
- if(C_access(buffer, F_OK) == 0) {
- for(i = C_strlen(buffer); i >= 0 && buffer[ i ] != '/'; --i);
-
- buffer[ i ] = '\0';
- return buffer;
- }
-
- /* walk PATH */
- path = C_getenv("PATH");
-
- if(path == NULL) return NULL;
-
- for(l = j = k = 0; !l; ++k) {
- switch(path[ k ]) {
-
- case '\0':
- if(k == 0) return NULL; /* empty PATH */
- else l = 1;
- /* fall through */
-
- case ':':
- C_strncpy(buffer, path + j, k - j);
- buffer[ k - j ] = '\0';
- C_strlcat(buffer, "/", C_MAX_PATH);
- C_strlcat(buffer, fname, C_MAX_PATH);
-
- if(C_access(buffer, F_OK) == 0) {
- dname = C_strdup(buffer);
- l = C_readlink(dname, buffer, C_MAX_PATH - 1);
-
- if(l == -1) {
- /* not a symlink (we ignore other errors here */
- buffer[ k - j ] = '\0';
- }
- else {
- while(l > 0 && buffer[ l ] != '/') --l;
-
- C_free(dname);
- buffer[ l ] = '\0';
- }
-
- return buffer;
- }
- else j = k + 1;
-
- break;
-
- default: ;
- }
- }
-
+# if _POSIX_C_SOURCE >= 200809L
+ char *p;
+ size_t n;
+ if((p = realpath(path, NULL)) == NULL)
return NULL;
- }
-# elif defined(__HAIKU__)
-{
- image_info info;
- int32 cookie = 0;
- int32 i;
-
- while (get_next_image_info(0, &cookie, &info) == B_OK) {
- if (info.type == B_APP_IMAGE) {
- C_strlcpy(buffer, info.name, C_MAX_PATH);
-
- for(i = C_strlen(buffer); i >= 0 && buffer[ i ] != '/'; --i);
-
- buffer[ i ] = '\0';
-
- return buffer;
- }
- }
-}
- return NULL;
-# else
- return NULL;
+ n = C_strlcpy(resolved, p, C_MAX_PATH);
+ C_free(p);
+ if(n < C_MAX_PATH)
+ return resolved;
# endif
+ return NULL;
}
#endif
+/* For image_info retrieval */
+#if defined(__HAIKU__)
+# include <kernel/image.h>
+#endif
+
+/* For _NSGetExecutablePath */
+#if defined(C_MACOSX)
+# include <mach-o/dyld.h>
+#endif
+
C_END_C_DECLS
#endif /* ___CHICKEN */
diff --git a/csc.scm b/csc.scm
index f82d20f4..55c73561 100644
--- a/csc.scm
+++ b/csc.scm
@@ -529,10 +529,7 @@ EOF
(set! shared #t) )
(define (use-private-repository)
- (set! compile-options (cons "-DC_PRIVATE_REPOSITORY" compile-options))
- (when osx
- ;; needed for C_path_to_executable (see chicken.h):
- (set! link-options (cons "-framework CoreFoundation" link-options))))
+ (set! compile-options (cons "-DC_PRIVATE_REPOSITORY" compile-options)))
(let loop ((args args))
(cond [(null? args)
diff --git a/distribution/manifest b/distribution/manifest
index 6e1dcc50..aa5ba853 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -119,6 +119,7 @@ tests/embedded1.c
tests/embedded2.scm
tests/embedded3.c
tests/embedded4.scm
+tests/executable-tests.scm
tests/condition-tests.scm
tests/fixnum-tests.scm
tests/numbers-string-conversion-tests.scm
diff --git a/library.scm b/library.scm
index fae96a8f..17e0d0e3 100644
--- a/library.scm
+++ b/library.scm
@@ -200,6 +200,7 @@ EOF
(define (current-gc-milliseconds) (##sys#fudge 31))
(define ##sys#decode-seconds (##core#primitive "C_decode_seconds"))
(define get-environment-variable (foreign-lambda c-string "C_getenv" c-string))
+(define executable-pathname (foreign-lambda c-string* "C_executable_pathname"))
(define (##sys#start-timer)
(##sys#gc #t)
diff --git a/manual/Unit library b/manual/Unit library
index 8a318c11..f446c2e0 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -447,6 +447,13 @@ the list is a string containing the name of the executing program. The
other items are the arguments passed to the application. It depends on
the host-shell whether arguments are expanded ('globbed') or not.
+==== executable-pathname
+
+<procedure>(executable-pathname)</procedure>
+
+Returns a full pathname of the currently-running executable, or {{#f}}
+if it couldn't be determined. When evaluating code in the interpreter,
+this will be a path to {{csi}}.
==== exit
diff --git a/runtime.c b/runtime.c
index 96cef6ab..e9ea0172 100644
--- a/runtime.c
+++ b/runtime.c
@@ -368,6 +368,9 @@ C_TLS C_uword C_maximal_heap_size;
C_TLS time_t C_startup_time_seconds;
C_TLS char
**C_main_argv,
+#ifdef SEARCH_EXE_PATH
+ *C_main_exe = NULL,
+#endif
*C_dlerror;
static C_TLS TRACE_INFO
@@ -1219,6 +1222,11 @@ void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *st
C_main_argc = argc;
C_main_argv = argv;
+
+#ifdef SEARCH_EXE_PATH
+ C_main_exe = C_resolve_executable_pathname(argv[0]);
+#endif
+
*heap = DEFAULT_HEAP_SIZE;
*stack = DEFAULT_STACK_SIZE;
*symbols = DEFAULT_SYMBOL_TABLE_SIZE;
@@ -8945,7 +8953,7 @@ C_decode_literal(C_word **ptr, C_char *str)
void
C_use_private_repository(C_char *path)
{
- private_repository = path == NULL ? NULL : C_strdup(path);
+ private_repository = path;
}
@@ -8955,6 +8963,150 @@ C_private_repository_path()
return private_repository;
}
+C_char *
+C_executable_pathname() {
+#ifdef SEARCH_EXE_PATH
+ return C_main_exe == NULL ? NULL : C_strdup(C_main_exe);
+#else
+ return C_resolve_executable_pathname(C_main_argv[0]);
+#endif
+}
+
+C_char *
+C_path_to_executable(C_char *fname) {
+ int len;
+ C_char *path;
+
+ if((path = C_resolve_executable_pathname(fname)) == NULL)
+ return NULL;
+
+#if defined(_WIN32) && !defined(__CYGWIN__)
+ for(len = C_strlen(path); len >= 0 && path[len] != '\\'; len--);
+#else
+ for(len = C_strlen(path); len >= 0 && path[len] != '/'; len--);
+#endif
+
+ path[len] = '\0';
+ return path;
+}
+
+C_char *
+C_resolve_executable_pathname(C_char *fname)
+{
+ int n;
+ C_char *buffer = (C_char *) C_malloc(C_MAX_PATH);
+
+ if(buffer == NULL) return NULL;
+
+#if defined(__linux__) || defined(__sun)
+ C_char linkname[64]; /* /proc/<pid>/exe */
+ pid_t pid = C_getpid();
+
+# ifdef __linux__
+ C_snprintf(linkname, sizeof(linkname), "/proc/%i/exe", pid);
+# else
+ C_snprintf(linkname, sizeof(linkname), "/proc/%i/path/a.out", pid); /* SunOS / Solaris */
+# endif
+
+ n = C_readlink(linkname, buffer, C_MAX_PATH);
+ if(n < 0 || n >= C_MAX_PATH)
+ goto error;
+
+ buffer[n] = '\0';
+ return buffer;
+#elif defined(_WIN32) && !defined(__CYGWIN__)
+ n = GetModuleFileName(NULL, buffer, C_MAX_PATH);
+ if(n == 0 || n >= C_MAX_PATH)
+ goto error;
+
+ return buffer;
+#elif defined(C_MACOSX)
+ C_char buf[C_MAX_PATH];
+ C_u32 size = C_MAX_PATH;
+
+ if(_NSGetExecutablePath(buf, &size) != 0)
+ goto error;
+
+ if(C_realpath(buf, buffer) == NULL)
+ goto error;
+
+ return buffer;
+#elif defined(__HAIKU__)
+{
+ image_info info;
+ int32 cookie = 0;
+
+ while (get_next_image_info(0, &cookie, &info) == B_OK) {
+ if (info.type == B_APP_IMAGE) {
+ C_strlcpy(buffer, info.name, C_MAX_PATH);
+ return buffer;
+ }
+ }
+}
+#elif defined(SEARCH_EXE_PATH)
+ int len;
+ C_char *path, buf[C_MAX_PATH];
+
+ /* no name given (execve) */
+ if(fname == NULL)
+ goto error;
+
+ /* absolute pathname */
+ if(fname[0] == '/') {
+ if(C_realpath(fname, buffer) == NULL)
+ goto error;
+ else
+ return buffer;
+ }
+
+ /* current directory */
+ if(C_strchr(fname, '/') != NULL) {
+ if(C_getcwd(buffer, C_MAX_PATH) == NULL)
+ goto error;
+
+ n = C_snprintf(buf, C_MAX_PATH, "%s/%s", buffer, fname);
+ if(n < 0 || n >= C_MAX_PATH)
+ goto error;
+
+ if(C_access(buf, X_OK) == 0) {
+ if(C_realpath(buf, buffer) == NULL)
+ goto error;
+ else
+ return buffer;
+ }
+ }
+
+ /* walk PATH */
+ if((path = C_getenv("PATH")) == NULL)
+ goto error;
+
+ do {
+ /* check PATH entry length */
+ len = C_strcspn(path, ":");
+ if(len == 0 || len >= C_MAX_PATH)
+ continue;
+
+ /* "<path>/<fname>" to buf */
+ C_strncpy(buf, path, len);
+ n = C_snprintf(buf + len, C_MAX_PATH - len, "/%s", fname);
+ if(n < 0 || n + len >= C_MAX_PATH)
+ continue;
+
+ if(C_access(buf, X_OK) != 0)
+ continue;
+
+ /* fname found, resolve links */
+ if(C_realpath(buf, buffer) != NULL)
+ return buffer;
+
+ /* seek next entry, skip colon */
+ } while (path += len, *path++);
+#endif
+
+error:
+ C_free(buffer);
+ return NULL;
+}
C_regparm C_word C_fcall
C_i_getprop(C_word sym, C_word prop, C_word def)
diff --git a/tests/executable-tests.scm b/tests/executable-tests.scm
new file mode 100644
index 00000000..78695ec8
--- /dev/null
+++ b/tests/executable-tests.scm
@@ -0,0 +1,27 @@
+;;; Compiled executable tests
+
+(include "test.scm")
+
+(use files posix)
+
+(define program-path
+ (car (command-line-arguments)))
+
+(define (read-symbolic-link* p)
+ (cond-expand
+ ((and windows (not cygwin)) p)
+ (else (read-symbolic-link p #t))))
+
+(test-begin "executable tests")
+
+(let ((p (program-name)))
+ (test-equal "program-name"
+ (pathname-strip-directory p)
+ (pathname-strip-directory program-path)))
+
+(and-let* ((p (executable-pathname)))
+ (test-equal "executable-pathname"
+ (read-symbolic-link* p)
+ (read-symbolic-link* program-path)))
+
+(test-end)
diff --git a/tests/runtests.bat b/tests/runtests.bat
index e94fd102..b962d68a 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -443,6 +443,12 @@ if errorlevel 1 exit /b 1
echo ======================================== syntax-rules stress test ...
%interpret% -bnq syntax-rule-stress-test.scm
+echo "======================================== executable tests ..."
+%compile% executable-tests.scm
+if errorlevel 1 exit /b 1
+a.out %TEST_DIR%\a.out
+if errorlevel 1 exit /b 1
+
echo ======================================== embedding (1) ...
%compile% embedded1.c
if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 7bf282ef..9e88761f 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -364,6 +364,10 @@ $compile locative-stress-test.scm
echo "======================================== syntax-rules stress test ..."
time $interpret -bnq syntax-rule-stress-test.scm
+echo "======================================== executable tests ..."
+$compile executable-tests.scm
+./a.out "$TEST_DIR/a.out"
+
echo "======================================== embedding (1) ..."
$compile embedded1.c
./a.out
diff --git a/types.db b/types.db
index 93413b85..ea471213 100644
--- a/types.db
+++ b/types.db
@@ -830,6 +830,7 @@
(error (procedure error (* #!rest) noreturn))
(##sys#error (procedure ##sys#error (* #!rest) noreturn))
(##sys#signal-hook (procedure ##sys#signal-hook (* #!rest) noreturn))
+(executable-pathname (#(procedure #:pure) executable-pathname () (or string false)))
(exit (procedure exit (#!optional fixnum) noreturn))
(exit-handler (#(procedure #:clean #:enforce) exit-handler (#!optional (procedure (fixnum) . *)) procedure))
(expand (procedure expand (* #!optional list) *))
Trap