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