From bcc553cea272c99cb375f9d17ffc713989106772 Mon Sep 17 00:00:00 2001
From: Evan Hanson
Date: Tue, 17 Mar 2015 20:57:16 +1300
Subject: [PATCH] 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.
Adds some missing buffer size checks, fixes some overly-conservative
ones, handles a few additional error cases and frees the allocated
buffer when `C_resolve_executable_pathname` fails.
Fixes #971.
---
NEWS | 2 +
chicken.h | 158 +--------------------------------------------
csc.scm | 2 +-
distribution/manifest | 1 +
library.scm | 1 +
manual/Unit library | 9 +++
runtime.c | 129 ++++++++++++++++++++++++++++++++++++
tests/executable-tests.scm | 14 ++++
tests/runtests.bat | 6 ++
tests/runtests.sh | 4 ++
types.db | 1 +
11 files changed, 171 insertions(+), 156 deletions(-)
create mode 100644 tests/executable-tests.scm
diff --git a/NEWS b/NEWS
index 8f3c94c..9ce43cd 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 69e0b95..9e137fd 100644
--- a/chicken.h
+++ b/chicken.h
@@ -961,6 +961,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
@@ -1819,6 +1820,8 @@ 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_path_to_executable(C_char *fname);
+C_fctexport C_char *C_executable_pathname();
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 +2015,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;
@@ -2941,160 +2943,6 @@ C_inline size_t C_strlcat(char *dst, const char *src, size_t sz)
# elif defined(__HAIKU__)
# include
# endif
-
-C_inline C_char *
-C_path_to_executable(C_char *fname)
-{
- 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//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: ;
- }
- }
-
- 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;
-# endif
-}
#endif
C_END_C_DECLS
diff --git a/csc.scm b/csc.scm
index d38cc27..7055ba9 100644
--- a/csc.scm
+++ b/csc.scm
@@ -529,7 +529,7 @@ EOF
(define (use-private-repository)
(set! compile-options (cons "-DC_PRIVATE_REPOSITORY" compile-options))
(when osx
- ;; needed for C_path_to_executable (see chicken.h):
+ ;; needed for C_path_to_executable (see runtime.c):
(set! link-options (cons "-framework CoreFoundation" link-options))))
(let loop ((args args))
diff --git a/distribution/manifest b/distribution/manifest
index 370e275..89f81b3 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -121,6 +121,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 fb85c86..68fdbac 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 8a318c1..8f26de3 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -447,6 +447,15 @@ 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
+
+(executable-pathname)
+
+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}}.
+
+The resulting pathname is not guaranteed to be normalized.
==== exit
diff --git a/runtime.c b/runtime.c
index 96cef6a..8a0f71c 100644
--- a/runtime.c
+++ b/runtime.c
@@ -8955,6 +8955,135 @@ C_private_repository_path()
return private_repository;
}
+C_char *
+C_resolve_executable_pathname(C_char *fname)
+{
+ 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//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
+
+ int n = C_readlink(linkname, buffer, C_MAX_PATH);
+
+ if(n == -1 || n >= C_MAX_PATH)
+ goto error;
+
+ buffer[n] = '\0';
+ return buffer;
+# elif defined(_WIN32) && !defined(__CYGWIN__)
+ int n = GetModuleFileName(NULL, buffer, C_MAX_PATH);
+
+ if(n == 0 || n >= C_MAX_PATH)
+ goto error;
+
+ return buffer;
+# elif defined(C_MACOSX) && defined(C_GUI)
+ CFBundleRef bundle = CFBundleGetMainBundle();
+ CFURLRef url = CFBundleCopyExecutableURL(bundle);
+
+ if(!CFURLGetFileSystemRepresentation(url, true, buffer, C_MAX_PATH))
+ goto error;
+
+ return buffer;
+# elif defined(__unix__) || defined(__unix) || defined(C_XXXBSD) || defined(_AIX)
+ int n, len;
+ C_char *path, buf[C_MAX_PATH];
+
+ /* no name given (execve) */
+ if(fname == NULL) goto error;
+
+ /* absolute path */
+ if(*fname == '/')
+ return C_strncpy(buffer, fname, C_MAX_PATH);
+
+ /* try current dir */
+ if(C_getcwd(buf, C_MAX_PATH) == NULL)
+ goto error;
+
+ n = C_snprintf(buffer, C_MAX_PATH, "%s/%s", buf, fname);
+ if(n == -1 || n >= C_MAX_PATH)
+ goto error;
+
+ if(C_access(buffer, F_OK) == 0)
+ return buffer;
+
+ /* try 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;
+
+ /* "/" to buffer */
+ C_strncpy(buffer, path, len);
+ n = C_snprintf(buffer + len, C_MAX_PATH - len, "/%s", fname);
+ if(n == -1 || n + len >= C_MAX_PATH)
+ continue;
+
+ /* fname found, resolve link */
+ if(C_access(buffer, F_OK) == 0) {
+ n = C_readlink(buffer, buf, C_MAX_PATH);
+ if(n >= C_MAX_PATH) continue;
+ if(n >= 0) return C_strncpy(buffer, buf, C_MAX_PATH);
+ if(errno == EINVAL) return buffer;
+ }
+
+ /* seek next entry, skip colon */
+ } while (path += len, *path++);
+# 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);
+ return buffer;
+ }
+ }
+}
+# endif
+
+error:
+ C_free(buffer);
+ return NULL;
+}
+
+C_char *
+C_path_to_executable(C_char *fname) {
+ int len;
+ C_char *path = C_resolve_executable_pathname(fname);
+
+ if(path == 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_executable_pathname() {
+ if(C_main_argc == 0) return NULL;
+ return C_resolve_executable_pathname(C_main_argv[0]);
+}
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 0000000..ed78168
--- /dev/null
+++ b/tests/executable-tests.scm
@@ -0,0 +1,14 @@
+;;; Compiled executable tests
+
+(use (only files normalize-pathname))
+
+(include "test.scm")
+
+(test-begin "executable tests")
+
+;; Test is invoked with program path as first argument.
+(test-equal "executable-pathname"
+ (car (command-line-arguments))
+ (normalize-pathname (executable-pathname)))
+
+(test-end)
diff --git a/tests/runtests.bat b/tests/runtests.bat
index e94fd10..b962d68 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 5e970a6..c663999 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 177d2a8..472ac8c 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) *))
--
2.1.4