tjh.dev
nixpkgs mirror (for testing)
github.com/NixOS/nixpkgs
nix
1From 2877f33747e3871c3a682b3a0c812b8ba2e4da5a Mon Sep 17 00:00:00 2001
2From: Caolan McMahon <caolan@caolanmcmahon.com>
3Date: Sat, 25 Jun 2016 11:52:28 +0100
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
12Original patch by Moritz Heidkamp.
13Updated by Caolan McMahon for CHICKEN 4.11.0
14---
15 chicken-install.scm | 29 ++++++++++++++++++++++++-----
16 chicken.import.scm | 1 +
17 eval.scm | 37 +++++++++++++++++++++++++++++++------
18 3 files changed, 56 insertions(+), 11 deletions(-)
19
20diff --git a/chicken-install.scm b/chicken-install.scm
21index 7bc6041..f557793 100644
22--- a/chicken-install.scm
23+++ b/chicken-install.scm
24@@ -120,6 +120,19 @@
25 (sprintf "lib/chicken/~a" (##sys#fudge 42)))
26 (repository-path)))))
27
28+ (define (repo-paths)
29+ (if *deploy*
30+ *prefix*
31+ (if (and *cross-chicken* (not *host-extension*))
32+ (list (make-pathname C_TARGET_LIB_HOME (sprintf "chicken/~a" C_BINARY_VERSION)))
33+ (cons
34+ (if *prefix*
35+ (make-pathname
36+ *prefix*
37+ (sprintf "lib/chicken/~a" (##sys#fudge 42)))
38+ (repository-path))
39+ (repository-extra-paths)))))
40+
41 (define (get-prefix #!optional runtime)
42 (cond ((and *cross-chicken*
43 (not *host-extension*))
44@@ -226,10 +239,13 @@
45 (chicken-version) )
46 ;; Duplication of (extension-information) to get custom
47 ;; prefix. This should be fixed.
48- ((let* ((ep (##sys#canonicalize-extension-path x 'ext-version))
49- (sf (make-pathname (repo-path) ep "setup-info")))
50- (and (file-exists? sf)
51- (with-input-from-file sf read))) =>
52+ ((let ((ep (##sys#canonicalize-extension-path x 'ext-version)))
53+ (let loop ((paths (repo-paths)))
54+ (cond ((null? paths) #f)
55+ ((let ((sf (make-pathname (car paths) ep "setup-info")))
56+ (and (file-exists? sf)
57+ (with-input-from-file sf read))))
58+ (else (loop (cdr paths)))))) =>
59 (lambda (info)
60 (let ((a (assq 'version info)))
61 (if a
62@@ -776,7 +792,10 @@
63 "installed extension has no information about which egg it belongs to"
64 (pathname-file sf))
65 #f))))
66- (glob (make-pathname (repo-path) "*" "setup-info")))
67+ (append-map
68+ (lambda (path)
69+ (glob (make-pathname path "*" "setup-info")))
70+ (repo-paths)))
71 equal?))
72
73 (define (list-available-extensions trans locn)
74diff --git a/chicken.import.scm b/chicken.import.scm
75index f6e3a19..be1637c 100644
76--- a/chicken.import.scm
77+++ b/chicken.import.scm
78@@ -200,6 +200,7 @@
79 repl
80 repl-prompt
81 repository-path
82+ repository-extra-paths
83 require
84 reset
85 reset-handler
86diff --git a/eval.scm b/eval.scm
87index 6242f62..f7d76d4 100644
88--- a/eval.scm
89+++ b/eval.scm
90@@ -81,6 +81,7 @@
91 (define-constant source-file-extension ".scm")
92 (define-constant setup-file-extension "setup-info")
93 (define-constant repository-environment-variable "CHICKEN_REPOSITORY")
94+(define-constant repository-extra-environment-variable "CHICKEN_REPOSITORY_EXTRA")
95 (define-constant prefix-environment-variable "CHICKEN_PREFIX")
96
97 ; these are actually in unit extras, but that is used by default
98@@ -1176,6 +1177,25 @@
99
100 (define ##sys#repository-path repository-path)
101
102+(define ##sys#repository-extra-paths
103+ (let* ((repaths (get-environment-variable repository-extra-environment-variable))
104+ (repaths (if repaths
105+ (let ((len (string-length repaths)))
106+ (let loop ((i 0) (offset 0) (res '()))
107+ (cond ((> i len)
108+ (reverse res))
109+ ((or (= i len) (eq? #\: (string-ref repaths i)))
110+ (loop (+ i 1) (+ i 1) (cons (substring repaths offset i) res)))
111+ (else
112+ (loop (+ i 1) offset res)))))
113+ '())))
114+ (lambda (#!optional val)
115+ (if val
116+ (set! repaths val)
117+ repaths))))
118+
119+(define repository-extra-paths ##sys#repository-extra-paths)
120+
121 (define ##sys#setup-mode #f)
122
123 (define ##sys#find-extension
124@@ -1193,6 +1213,7 @@
125 (let loop ((paths (##sys#append
126 (if ##sys#setup-mode '(".") '())
127 (if rp (list rp) '())
128+ (##sys#repository-extra-paths)
129 (if inc? ##sys#include-pathnames '())
130 (if ##sys#setup-mode '() '("."))) ))
131 (and (pair? paths)
132@@ -1252,12 +1273,16 @@
133 [string-append string-append]
134 [read read] )
135 (lambda (id loc)
136- (and-let* ((rp (##sys#repository-path)))
137- (let* ((p (##sys#canonicalize-extension-path id loc))
138- (rpath (string-append rp "/" p ".")) )
139- (cond ((file-exists? (string-append rpath setup-file-extension))
140- => (cut with-input-from-file <> read) )
141- (else #f) ) ) ) ) ))
142+ (let loop ((rpaths (cons (##sys#repository-path) (##sys#repository-extra-paths))))
143+ (and (pair? rpaths)
144+ (let ((rp (car rpaths)))
145+ (if (not rp)
146+ (loop (cdr rpaths))
147+ (let* ((p (##sys#canonicalize-extension-path id loc))
148+ (rpath (string-append rp "/" p ".")) )
149+ (cond ((file-exists? (string-append rpath setup-file-extension))
150+ => (cut with-input-from-file <> read) )
151+ (else (loop (cdr rpaths))) ) )) ))) ) ))
152
153 (define (extension-information ext)
154 (##sys#extension-information ext 'extension-information) )
155--
1562.1.4
157