1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
From 752dff853186dc334c519a86fa92f087795fea02 Mon Sep 17 00:00:00 2001
From: Moritz Heidkamp <moritz.heidkamp@bevuta.com>
Date: Wed, 1 Oct 2014 22:41:30 +0200
Subject: [PATCH] Introduce CHICKEN_REPOSITORY_EXTRA
This environment variable works like CHICKEN_REPOSITORY but supports
multiple paths separated by `:'. Those paths are searched after
CHICKEN_REPOSITORY when loading extensions via `require-library' and
friends. It can be accessed and changed at runtime via the new procedure
`repository-extra-paths' which is analog to `repository-path'.
---
chicken-install.scm | 11 +++++++----
chicken.import.scm | 1 +
eval.scm | 37 +++++++++++++++++++++++++++++++------
3 files changed, 39 insertions(+), 10 deletions(-)
diff --git a/chicken-install.scm b/chicken-install.scm
index 2ef6ef4..b5c6bf8 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -109,10 +109,10 @@
(define *show-foreign-depends* #f)
(define *hacks* '())
- (define (repo-path)
+ (define (repo-paths)
(if (and *cross-chicken* (not *host-extension*))
- (make-pathname C_TARGET_LIB_HOME (sprintf "chicken/~a" C_BINARY_VERSION))
- (repository-path)))
+ (list (make-pathname C_TARGET_LIB_HOME (sprintf "chicken/~a" C_BINARY_VERSION)))
+ (cons (repository-path) (repository-extra-paths))))
(define (get-prefix #!optional runtime)
(cond ((and *cross-chicken*
@@ -757,7 +757,10 @@
"installed extension has no information about which egg it belongs to"
(pathname-file sf))
#f))))
- (glob (make-pathname (repo-path) "*" "setup-info")))
+ (append-map
+ (lambda (path)
+ (glob (make-pathname path "*" "setup-info")))
+ (repo-paths)))
equal?))
(define (list-available-extensions trans locn)
diff --git a/chicken.import.scm b/chicken.import.scm
index baa7316..2839b16 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -201,6 +201,7 @@
repl
repl-prompt
repository-path
+ repository-extra-paths
require
reset
reset-handler
diff --git a/eval.scm b/eval.scm
index bbcd86c..838588d 100644
--- a/eval.scm
+++ b/eval.scm
@@ -81,6 +81,7 @@
(define-constant source-file-extension ".scm")
(define-constant setup-file-extension "setup-info")
(define-constant repository-environment-variable "CHICKEN_REPOSITORY")
+(define-constant repository-extra-environment-variable "CHICKEN_REPOSITORY_EXTRA")
(define-constant prefix-environment-variable "CHICKEN_PREFIX")
; these are actually in unit extras, but that is used by default
@@ -1180,6 +1181,25 @@
(define repository-path ##sys#repository-path)
+(define ##sys#repository-extra-paths
+ (let* ((repaths (get-environment-variable repository-extra-environment-variable))
+ (repaths (if repaths
+ (let ((len (string-length repaths)))
+ (let loop ((i 0) (offset 0) (res '()))
+ (cond ((> i len)
+ (reverse res))
+ ((or (= i len) (eq? #\: (string-ref repaths i)))
+ (loop (+ i 1) (+ i 1) (cons (substring repaths offset i) res)))
+ (else
+ (loop (+ i 1) offset res)))))
+ '())))
+ (lambda (#!optional val)
+ (if val
+ (set! repaths val)
+ repaths))))
+
+(define repository-extra-paths ##sys#repository-extra-paths)
+
(define ##sys#setup-mode #f)
(define ##sys#find-extension
@@ -1197,6 +1217,7 @@
(let loop ((paths (##sys#append
(if ##sys#setup-mode '(".") '())
(if rp (list rp) '())
+ (##sys#repository-extra-paths)
(if inc? ##sys#include-pathnames '())
(if ##sys#setup-mode '() '("."))) ))
(and (pair? paths)
@@ -1256,12 +1277,16 @@
[string-append string-append]
[read read] )
(lambda (id loc)
- (and-let* ((rp (##sys#repository-path)))
- (let* ((p (##sys#canonicalize-extension-path id loc))
- (rpath (string-append rp "/" p ".")) )
- (cond ((file-exists? (string-append rpath setup-file-extension))
- => (cut with-input-from-file <> read) )
- (else #f) ) ) ) ) ))
+ (let loop ((rpaths (cons (##sys#repository-path) (##sys#repository-extra-paths))))
+ (and (pair? rpaths)
+ (let ((rp (car rpaths)))
+ (if (not rp)
+ (loop (cdr rpaths))
+ (let* ((p (##sys#canonicalize-extension-path id loc))
+ (rpath (string-append rp "/" p ".")) )
+ (cond ((file-exists? (string-append rpath setup-file-extension))
+ => (cut with-input-from-file <> read) )
+ (else (loop (cdr rpaths))) ) )) ))) ) ))
(define (extension-information ext)
(##sys#extension-information ext 'extension-information) )
--
2.1.0
|