As discussed on IRC, it doesn’t make much sense to have
(repository-path) return a string now that it’s a search path and thus
is not guaranteed to be a valid directory name any longer.
I tried to keep the scope of this patch as minimal as possible, it’s not
very clean but it seems to be working. I added a few tests to ensure that.
From 08f2609232185e09fd323afb6b8ceadad55c52f1 Mon Sep 17 00:00:00 2001
From: Kooda <ko...@upyum.com>
Date: Thu, 9 Aug 2018 20:47:14 +0200
Subject: [PATCH] Make `repository-path` from (chicken platform) return a list
instead of a string
---
NEWS | 3 +++
chicken-install.scm | 2 +-
chicken-status.scm | 13 ++++++---
eval.scm | 44 ++++++-------------------------
library.scm | 42 ++++++++++++++++++++++++++---
tests/private-repository-test.scm | 2 +-
tests/repository-path-default.scm | 9 +++++++
tests/repository-path.scm | 33 +++++++++++++++++++++++
tests/runtests.bat | 10 +++++++
tests/runtests.sh | 11 +++++++-
tests/sample-module.scm | 3 +++
types.db | 1 +
12 files changed, 128 insertions(+), 45 deletions(-)
create mode 100644 tests/repository-path-default.scm
create mode 100644 tests/repository-path.scm
create mode 100644 tests/sample-module.scm
diff --git a/NEWS b/NEWS
index c6489e78..301bf947 100644
--- a/NEWS
+++ b/NEWS
@@ -102,6 +102,9 @@
- `process`, `process*` and `process-execute` now expect lists of the form
(("NAME" . "VALUE") ...) instead of the previous (("NAME=VALUE") ...)
as their environment argument.
+ - `repository-path` is now a parameter containing a list of strings instead
+ of a string, as the search path for libraries can now contain multiple
+ directories.
- Module system
- The compiler has been modularised, for improved namespacing. This
diff --git a/chicken-install.scm b/chicken-install.scm
index e88d23b6..14e07262 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -112,7 +112,7 @@
(define (repo-path)
(if (and cross-chicken (not host-extension))
- (destination-repository 'target)
+ (##sys#split-path (destination-repository 'target))
(repository-path)))
(define (install-path)
diff --git a/chicken-status.scm b/chicken-status.scm
index 25c873dc..e145e32a 100644
--- a/chicken-status.scm
+++ b/chicken-status.scm
@@ -63,7 +63,7 @@
(define (repo-path)
(if (and cross-chicken (not host-extensions))
- (destination-repository 'target)
+ (##sys#split-path (destination-repository 'target))
(repository-path)))
(define (grep rx lst)
@@ -93,7 +93,7 @@
(lambda (dir)
(map pathname-file
(glob (make-pathname dir "*" +egg-info-extension+))))
- (##sys#split-path (repo-path)))
+ (repo-path))
equal?))
(define (format-string str cols #!optional right (padc #\space))
@@ -112,7 +112,14 @@
(let ((version
(cond ((let ((info (read-info egg dir ext)))
(and info (get-egg-property info 'version))))
- ((file-exists? (make-pathname (list dir egg) +version-file+))
+ ((and (string? dir)
+ (file-exists? (make-pathname (list dir egg) +version-file+)))
+ => (lambda (fname)
+ (with-input-from-file fname read)))
+ ((chicken.load#find-file +version-file+
+ (map (lambda (d)
+ (make-pathname d egg))
+ dir))
=> (lambda (fname)
(with-input-from-file fname read)))
(else "unknown"))))
diff --git a/eval.scm b/eval.scm
index c34622f7..68c824bf 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1212,40 +1212,15 @@
(define ##sys#setup-mode #f)
-(define path-list-separator
- (if ##sys#windows-platform #\; #\:))
-
-(define ##sys#split-path
- (let ((cache '(#f)))
- (lambda (path)
- (cond ((not path) '())
- ((equal? path (car cache))
- (cdr cache))
- (else
- (let* ((len (string-length path))
- (lst (let loop ((start 0) (pos 0))
- (cond ((fx>= pos len)
- (if (fx= pos start)
- '()
- (list (substring path start pos))))
- ((char=? (string-ref path pos)
- path-list-separator)
- (cons (substring path start pos)
- (loop (fx+ pos 1)
- (fx+ pos 1))))
- (else
- (loop start (fx+ pos 1)))))))
- (set! cache (cons path lst))
- lst))))))
-
(define (file-exists? name) ; defined here to avoid file unit dependency
(and (##sys#file-exists? name #t #f #f) name))
(define (find-file name search-path)
- (let loop ((p (##sys#split-path search-path)))
- (cond ((null? p) #f)
- ((file-exists? (string-append (car p) "/" name)))
- (else (loop (cdr p))))))
+ (cond ((not search-path) #f)
+ ((null? search-path) #f)
+ ((string? search-path) (find-file name (list search-path)))
+ ((file-exists? (string-append (car search-path) "/" name)))
+ (else (find-file name (cdr search-path)))))
(define find-dynamic-extension
(let ((string-append string-append))
@@ -1261,7 +1236,7 @@
(file-exists? (##sys#string-append p0 source-file-extension)))))
(let loop ((paths (##sys#append
(if ##sys#setup-mode '(".") '())
- (if rp (##sys#split-path rp) '())
+ (or rp '())
(if inc? ##sys#include-pathnames '())
(if ##sys#setup-mode '() '("."))) ))
(and (pair? paths)
@@ -1364,11 +1339,8 @@
(or (test (make-relative-pathname source fname))
(let loop ((paths (if repo
(##sys#append
- ##sys#include-pathnames
- (let ((rp (repository-path)))
- (if rp
- (##sys#split-path rp)
- '())))
+ ##sys#include-pathnames
+ (or (repository-path) '()) )
##sys#include-pathnames) ) )
(cond ((eq? paths '()) #f)
((test (string-append (##sys#slot paths 0)
diff --git a/library.scm b/library.scm
index 90d491ef..e81648cd 100644
--- a/library.scm
+++ b/library.scm
@@ -6472,11 +6472,47 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(define (chicken-home) installation-home)
+(define path-list-separator
+ (if ##sys#windows-platform #\; #\:))
+
+(define ##sys#split-path
+ (let ((cache '(#f)))
+ (lambda (path)
+ (cond ((not path) '())
+ ((equal? path (car cache))
+ (cdr cache))
+ (else
+ (let* ((len (string-length path))
+ (lst (let loop ((start 0) (pos 0))
+ (cond ((fx>= pos len)
+ (if (fx= pos start)
+ '()
+ (list (substring path start pos))))
+ ((char=? (string-ref path pos)
+ path-list-separator)
+ (cons (substring path start pos)
+ (loop (fx+ pos 1)
+ (fx+ pos 1))))
+ (else
+ (loop start (fx+ pos 1)))))))
+ (set! cache (cons path lst))
+ lst))))))
+
(define repository-path
(make-parameter
- (or (foreign-value "C_private_repository_path()" c-string)
- (get-environment-variable "CHICKEN_REPOSITORY_PATH")
- install-egg-home)))
+ (cond ((foreign-value "C_private_repository_path()" c-string)
+ => list)
+ ((get-environment-variable "CHICKEN_REPOSITORY_PATH")
+ => ##sys#split-path)
+ (install-egg-home
+ => list)
+ (else #f))
+ (lambda (new)
+ (and new
+ (begin
+ (##sys#check-list new 'repository-path)
+ (for-each (lambda (p) (##sys#check-string p 'repository-path)) new)
+ new)))))
(define installation-repository
(make-parameter
diff --git a/tests/private-repository-test.scm b/tests/private-repository-test.scm
index d293962e..46fbf37a 100644
--- a/tests/private-repository-test.scm
+++ b/tests/private-repository-test.scm
@@ -12,7 +12,7 @@
((and windows (not cygwin)) (lambda (filename _) filename))
(else read-symbolic-link)))
-(define repo (normalize-pathname (read-symbolic-link* (repository-path) #t)))
+(define repo (normalize-pathname (read-symbolic-link* (car (repository-path)) #t)))
(define dir (normalize-pathname (read-symbolic-link* (car (command-line-arguments)) #t)))
(print (list dir repo))
diff --git a/tests/repository-path-default.scm b/tests/repository-path-default.scm
new file mode 100644
index 00000000..dcb1429d
--- /dev/null
+++ b/tests/repository-path-default.scm
@@ -0,0 +1,9 @@
+(import (chicken platform))
+
+(include "test.scm")
+
+(print (repository-path))
+(test-assert "(repository-path) contains something by default"
+ (= 1 (length (repository-path))))
+
+(test-exit)
diff --git a/tests/repository-path.scm b/tests/repository-path.scm
new file mode 100644
index 00000000..0253c321
--- /dev/null
+++ b/tests/repository-path.scm
@@ -0,0 +1,33 @@
+(import (chicken platform)
+ (chicken process-context)
+ (chicken condition))
+
+(include "test.scm")
+
+(test-equal "find-file on #f"
+ (chicken.load#find-file "repository-path.scm" #f)
+ #f)
+
+(test-equal "find-file on string"
+ (chicken.load#find-file "repository-path.scm" ".")
+ "./repository-path.scm")
+
+(test-equal "find-file on list"
+ (chicken.load#find-file "repository-path.scm" '(".." "."))
+ "./repository-path.scm")
+
+(test-equal "(repository-path) is populated by CHICKEN_REPOSITORY_PATH"
+ (repository-path)
+ (command-line-arguments))
+
+(repository-path
+ (cons (get-environment-variable "CHICKEN_INSTALL_REPOSITORY")
+ (repository-path)))
+
+(test-assert "setting (repository-path) and loading a library"
+ (handle-exceptions exn #f (begin (require-library sample-module) #t)))
+
+(test-error "Putting garbage in (repository-path)"
+ (repository-path '(foo)))
+
+(test-exit)
diff --git a/tests/runtests.bat b/tests/runtests.bat
index 6030d387..6826a734 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -27,6 +27,16 @@ rmdir /q /s %CHICKEN_INSTALL_REPOSITORY%
mkdir %CHICKEN_INSTALL_REPOSITORY%
copy %TYPESDB% %CHICKEN_INSTALL_REPOSITORY%
+echo "======================================== repository search path ..."
+setlocal
+set "CHICKEN_REPOSITORY_PATH="
+%interpret% -s repository-path-default.scm
+endlocal
+%compile_s% sample-module.scm -j sample-module
+copy sample-module.so %CHICKEN_INSTALL_REPOSITORY%
+copy sample-module.import.scm %CHICKEN_INSTALL_REPOSITORY%
+$interpret -s repository-path.scm "%TEST_DIR%\.." "%TEST_DIR%/test-repository"
+
echo "======================================== types.db consistency ..."
%interpret% -s types-db-consistency.scm %TYPESDB%
if errorlevel 1 exit /b 1
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 06279127..0232e7bd 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -4,7 +4,6 @@
# - Note: this needs a proper shell, so it will not work with plain mingw
# (just the compiler and the Windows shell, without MSYS)
-
set -e
if test -z "$MSYSTEM"; then
TEST_DIR=`pwd`
@@ -63,6 +62,16 @@ rm -fr *.exe *.so *.o *.out *.import.* ../foo.import.* test-repository
mkdir -p test-repository
cp $TYPESDB test-repository/types.db
+echo "======================================== repository search path ..."
+export -p >./old-environment
+unset CHICKEN_REPOSITORY_PATH
+$interpret -s repository-path-default.scm
+. ./old-environment
+$compile_s sample-module.scm -j sample-module
+cp sample-module.so $CHICKEN_INSTALL_REPOSITORY
+cp sample-module.import.scm $CHICKEN_INSTALL_REPOSITORY
+$interpret -s repository-path.scm "${TEST_DIR}/.." "${TEST_DIR}/test-repository"
+
echo "======================================== types.db consistency ..."
$interpret -s types-db-consistency.scm ${TYPESDB}
diff --git a/tests/sample-module.scm b/tests/sample-module.scm
new file mode 100644
index 00000000..32ac627f
--- /dev/null
+++ b/tests/sample-module.scm
@@ -0,0 +1,3 @@
+(module sample-module (foo)
+(import scheme)
+(define foo 42))
diff --git a/types.db b/types.db
index b84582b2..c92fcafd 100644
--- a/types.db
+++ b/types.db
@@ -1339,6 +1339,7 @@
(chicken.load#provided? (#(procedure #:clean #:enforce) chicken.load#provided? (#!rest symbol) boolean))
(chicken.load#require (#(procedure #:clean) chicken.load#require (#!rest symbol) undefined))
(chicken.load#set-dynamic-load-mode! (#(procedure #:clean #:enforce) chicken.load#set-dynamic-load-mode! ((or symbol (list-of symbol))) undefined))
+(chicken.load#find-file (#(procedure #:clean) chicken.load#find-file (string (or (list-of string) string)) (or string false)))
;; platform
--
2.18.0
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
