~ chicken-core (chicken-5) 5c13af7e87a330f62ebaddf29547a49ebe5c6a6d
commit 5c13af7e87a330f62ebaddf29547a49ebe5c6a6d
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Feb 15 09:32:48 2010 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Feb 15 09:32:48 2010 +0100
windows fixed for private repositories
diff --git a/chicken.h b/chicken.h
index 780737e4..830ab88e 100644
--- a/chicken.h
+++ b/chicken.h
@@ -325,7 +325,7 @@ typedef unsigned __int64 uint64_t;
/* Have a GUI? */
-#if defined(C_WINDOWS_GUI) || defined(C_GUI)
+#if defined(C_WINDOWS_GUI) || defined(C_GUI) || defined(C_PRIVATE_REPOSITORY)
# ifdef _WIN32
# include <windows.h>
# ifndef WINAPI
@@ -1310,7 +1310,7 @@ extern double trunc(double);
#define C_end_of_main
#ifdef C_PRIVATE_REPOSITORY
-# define C_private_repository C_use_private_repository()
+# define C_private_repository C_use_private_repository(C_path_to_executable())
#else
# define C_private_repository
#endif
@@ -1548,8 +1548,7 @@ C_fctexport C_word C_enumerate_symbols(C_SYMBOL_TABLE *stable, C_word pos) C_reg
C_fctexport void C_do_register_finalizer(C_word x, C_word proc);
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_fctexport C_char *C_path_to_executable();
+C_fctexport void C_use_private_repository(C_char *path);
C_fctexport C_char *C_private_repository_path();
C_fctimport void C_ccall C_toplevel(C_word c, C_word self, C_word k) C_noret;
@@ -2124,6 +2123,134 @@ C_inline C_word C_i_safe_pointerp(C_word x)
}
+#ifdef C_PRIVATE_REPOSITORY
+# if defined(C_MACOSX) && defined(C_GUI)
+# include <CoreFoundation/CoreFoundation.h>
+# endif
+C_inline C_char *
+C_path_to_executable()
+{
+ C_char *buffer = (C_char *)C_malloc(MAX_PATH);
+
+ if(buffer == NULL) return NULL;
+
+# ifdef __linux__
+ C_char linkname[64]; /* /proc/<pid>/exe */
+ pid_t pid;
+ int ret;
+
+ pid = C_getpid();
+ C_sprintf(linkname, "/proc/%i/exe", pid);
+ ret = C_readlink(linkname, buffer, sizeof(buffer) - 1);
+
+ if(ret == -1 || ret >= sizeof(buffer) - 1)
+ return NULL;
+
+ for(--ret; ret > 0 && buffer[ ret ] != '/'; --ret);
+
+ buffer[ ret ] = '\0';
+ return buffer;
+# elif defined(_WIN32) && !defined(__CYGWIN__)
+ int n = GetModuleFileName(NULL, buffer, sizeof(buffer) - 1);
+
+ if(n == 0 || n >= sizeof(buffer) - 1)
+ return NULL;
+
+ buffer[ n ] = '\0';
+ return buffer;
+# elif defined(C_MACOSX) && defined(C_GUI)
+ CFBundleRef bundle = CFBundleGetMainBundle();
+ CFURLRef url = CFBundleCopyExecutableURL(bundle);
+
+ if(CFURLGetFileSystemRepresentation(url, true, buffer, sizeof(buffer)))
+ return buffer;
+ else return NULL;
+# elif defined(__unix__) || defined(C_XXXBSD)
+ int i, j, k, l;
+ C_char *fname = C_main_argv[ 0 ];
+ 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_strcpy(buffer, fname);
+ }
+ else {
+ /* try current dir */
+ if(C_getcwd(buffer, sizeof(buffer) - 1) == NULL)
+ return NULL;
+
+ j = C_strlen(buffer);
+ C_strcat(buffer, "/");
+ C_strcat(buffer, fname);
+
+ if(C_access(buffer, F_OK) == 0) {
+ buffer[ j ] = '\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_strcat(buffer, "/");
+ C_strcat(buffer, fname);
+
+ if(C_access(buffer, F_OK)) {
+ dname = C_strdup(buffer);
+ l = C_readlink(dname, buffer, C_sizeof(buffer) - 1);
+
+ if(l == -1) {
+ /* not a symlink (we ignore other errors here */
+ dname[ 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;
+ }
+# else
+ return NULL;
+# endif
+}
+#endif
+
+
C_END_C_DECLS
#endif /* ___CHICKEN */
diff --git a/csc.scm b/csc.scm
index a85017a9..62c4b8b4 100644
--- a/csc.scm
+++ b/csc.scm
@@ -617,7 +617,9 @@ EOF
(t-options "-static-extension" (car rest))
(set! rest (cdr rest)) ]
((-private-repository)
- (set! compile-options (cons "-DC_PRIVATE_REPOSITORY" compile-options)))
+ (set! compile-options (cons "-DC_PRIVATE_REPOSITORY" compile-options))
+ (when osx
+ (set! link-options (cons "-framework CoreFoundation" link-options))))
[(-gui
-windows |-W|) ;DEPRECATED
(set! gui #t)
diff --git a/library.scm b/library.scm
index 8485b28a..fe823d0b 100644
--- a/library.scm
+++ b/library.scm
@@ -3404,9 +3404,6 @@ EOF
(define ##sys#pathname-directory-separator #\/) ; DEPRECATED
-(define ##sys#program-directory
- (foreign-lambda c-string "C_path_to_executable"))
-
;;; Feature identifiers:
diff --git a/misc/osx-deploy-bundle.scm b/misc/osx-deploy-bundle.scm
deleted file mode 100644
index d3f22018..00000000
--- a/misc/osx-deploy-bundle.scm
+++ /dev/null
@@ -1,29 +0,0 @@
-;;;; osx-deploy-bundle.scm
-;
-; Use like this:
-;
-; % csc <your-application-main-module> -prologue osx-deploy-bundle.scm -framework CoreFoundation
-
-
-(use posix easyffi)
-
-#>
-#include <CoreFoundation/CoreFoundation.h>
-<#
-
-(foreign-parse/declare #<<EOF
-static char *get_bundle_path()
-{
- CFBundleRef bundle = CFBundleGetMainBundle();
- CFURLRef url = CFBundleCopyExecutableURL(bundle);
- static char buffer[ 256 ];
-
- if(CFURLGetFileSystemRepresentation(url, true, buffer, sizeof(buffer))) return buffer;
- else return NULL;
-}
-EOF
-)
-
-(let ((application-path (get_bundle_path)))
- (assert application-path "unable to compute executable path")
- (repository-path (pathname-directory application-path) ) )
diff --git a/posixwin.scm b/posixwin.scm
index b13b0b0e..d30b7f8c 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -250,7 +250,7 @@ readdir(DIR * dir)
#define C_dup(x) C_fix(dup(C_unfix(x)))
#define C_dup2(x, y) C_fix(dup2(C_unfix(x), C_unfix(y)))
#define C_setvbuf(p, m, s) C_fix(setvbuf(C_port_file(p), NULL, C_unfix(m), C_unfix(s)))
-#define C_access(fn, m) C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
+#define C_test_access(fn, m) C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
#define C_pipe(d, m) C_fix(_pipe(C_pipefds, PIPE_BUF, C_unfix(m)))
#define C_close(fd) C_fix(close(C_unfix(fd)))
@@ -1604,7 +1604,7 @@ EOF
(let ()
(define (check filename acc loc)
(##sys#check-string filename loc)
- (let ([r (fx= 0 (##core#inline "C_access" (##sys#make-c-string (##sys#expand-home-path filename)) acc))])
+ (let ([r (fx= 0 (##core#inline "C_test_access" (##sys#make-c-string (##sys#expand-home-path filename)) acc))])
(unless r (##sys#update-errno))
r) )
(set! file-read-access? (lambda (filename) (check filename _r_ok 'file-read-access?)))
diff --git a/runtime.c b/runtime.c
index da4c0547..7530cf1e 100644
--- a/runtime.c
+++ b/runtime.c
@@ -515,6 +515,7 @@ C_dbg(C_char *prefix, C_char *fstr, ...)
{
va_list va;
+ C_fflush(C_stdout);
C_fprintf(C_stderr, "[%s] ", prefix);
va_start(va, fstr);
C_vfprintf(C_stderr, fstr, va);
@@ -8758,123 +8759,9 @@ C_decode_literal(C_word **ptr, C_char *str)
}
-C_char *
-C_path_to_executable()
-{
-#ifdef __linux__
- C_char linkname[64]; /* /proc/<pid>/exe */
- pid_t pid;
- int ret;
-
- pid = C_getpid();
- C_sprintf(linkname, "/proc/%i/exe", pid);
- ret = C_readlink(linkname, buffer, STRING_BUFFER_SIZE - 1);
-
- if(ret == -1 || ret >= STRING_BUFFER_SIZE - 1)
- return NULL;
-
- for(--ret; ret > 0 && buffer[ ret ] != '/'; --ret);
-
- buffer[ ret ] = '\0';
- return buffer;
-#elif defined(_WIN32) && !defined(__CYGWIN__)
- int n = GetModuleFileName(NULL, buffer, STRING_BUFFER_SIZE - 1);
-
- if(n == 0 || n >= STRING_BUFFER_SIZE - 1)
- return NULL;
-
- buffer[ n ] = '\0';
- return buffer;
-#elif defined(__unix__) || defined(C_XXXBSD)
- int i, j, k, l;
- C_char *fname = C_main_argv[ 0 ];
- 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_strcpy(buffer, fname);
- }
- else {
- /* try current dir */
- if(C_getcwd(buffer, STRING_BUFFER_SIZE - 1) == NULL)
- return NULL;
-
- j = C_strlen(buffer);
- C_strcat(buffer, "/");
- C_strcat(buffer, fname);
-
- if(C_access(buffer, F_OK) == 0) {
- buffer[ j ] = '\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_strcat(buffer, "/");
- C_strcat(buffer, fname);
-
- if(C_access(buffer, F_OK)) {
- dname = C_strdup(buffer);
- l = C_readlink(dname, buffer, C_STRING_BUFFER_SIZE - 1);
-
- if(l == -1) {
- /* not a symlink (we ignore other errors here */
- dname[ 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;
- }
-#else
- return NULL;
-#endif
-}
-
-
void
-C_use_private_repository()
+C_use_private_repository(C_char *path)
{
- C_char *path = C_path_to_executable();
-
private_repository = path == NULL ? NULL : C_strdup(path);
}
Trap