1#lang racket/base
2(require racket/promise
3         racket/private/config
4         compiler/private/winutf16
5         compiler/private/mach-o
6         setup/cross-system
7         "private/dirs.rkt")
8
9(provide (except-out (all-from-out "private/dirs.rkt")
10                     config:dll-dir
11                     config:bin-dir
12                     config:gui-bin-dir
13                     config:bin-search-dirs
14                     config:gui-bin-search-dirs
15                     config:config-tethered-console-bin-dir
16                     config:config-tethered-gui-bin-dir
17                     config:lib-search-dirs
18                     config:share-search-dirs
19                     config:man-search-dirs
20                     config:doc-search-dirs
21                     define-finder
22                     get-config-table
23                     to-path)
24         find-cross-dll-dir
25         find-dll-dir
26         get-lib-search-dirs)
27
28;; ----------------------------------------
29;; Executables
30
31(define-finder provide
32  config:bin-dir
33  find-console-bin-dir
34  find-user-console-bin-dir
35  (case (cross-system-type)
36    [(windows) 'same]
37    [(macosx unix) "bin"]))
38
39(define-finder provide
40  config:gui-bin-dir
41  find-gui-bin-dir
42  find-user-gui-bin-dir
43  (case (cross-system-type)
44    [(windows macosx) 'same]
45    [(unix) "bin"]))
46
47(provide find-config-tethered-console-bin-dir
48         find-config-tethered-gui-bin-dir)
49
50(define (find-config-tethered-console-bin-dir)
51  (force config:config-tethered-console-bin-dir))
52
53(define (find-config-tethered-gui-bin-dir)
54  (force config:config-tethered-gui-bin-dir))
55
56(provide find-addon-tethered-console-bin-dir
57         find-addon-tethered-gui-bin-dir)
58
59(define addon-bin-table
60  (delay/sync
61   (let ()
62     (define f (build-path (find-system-path 'addon-dir)
63                           "etc"
64                           "config.rktd"))
65     (and (file-exists? f)
66          (call-with-input-file*
67           f
68           (lambda (in)
69             (call-with-default-reading-parameterization
70              (lambda ()
71                (read in)))))))))
72
73(define (find-addon-bin-dir key)
74  (define t (force addon-bin-table))
75  (and (hash? t)
76       (let ([v (hash-ref t key #f)])
77         (and (path-string? v)
78              (simplify-path
79               (path->complete-path
80                v
81                (build-path (find-system-path 'addon-dir)
82                            "etc")))))))
83
84(define (find-addon-tethered-console-bin-dir)
85  (find-addon-bin-dir 'addon-tethered-console-bin-dir))
86
87(define (find-addon-tethered-gui-bin-dir)
88  (find-addon-bin-dir 'addon-tethered-gui-bin-dir))
89
90;; ----------------------------------------
91;; Extra search paths
92
93(provide get-console-bin-search-dirs
94         get-gui-bin-search-dirs
95         get-share-search-dirs
96         get-man-search-dirs
97         get-console-bin-extra-search-dirs
98         get-gui-bin-extra-search-dirs
99         get-share-extra-search-dirs
100         get-man-extra-search-dirs
101         get-doc-extra-search-dirs
102         get-cross-lib-extra-search-dirs)
103
104(define (make-search-list config:search-dirs find-dir)
105  (combine-search (force config:search-dirs)
106                  (let ([p (find-dir)])
107                    (if p
108                        (list p)
109                        null))))
110
111(define (get-console-bin-search-dirs)
112  (make-search-list config:bin-search-dirs find-console-bin-dir))
113
114(define (get-gui-bin-search-dirs)
115  (make-search-list config:gui-bin-search-dirs find-gui-bin-dir))
116
117(define (get-share-search-dirs)
118  (make-search-list config:share-search-dirs find-share-dir))
119
120(define (get-man-search-dirs)
121  (make-search-list config:man-search-dirs find-man-dir))
122
123
124(define (make-extra-search-list config:search-dirs)
125  (combine-search (force config:search-dirs) null))
126
127(define (get-console-bin-extra-search-dirs)
128  (make-extra-search-list config:bin-search-dirs))
129
130(define (get-gui-bin-extra-search-dirs)
131  (make-extra-search-list config:gui-bin-search-dirs))
132
133(define (get-share-extra-search-dirs)
134  (make-extra-search-list config:share-search-dirs))
135
136(define (get-man-extra-search-dirs)
137  (make-extra-search-list config:man-search-dirs))
138
139(define (get-doc-extra-search-dirs)
140  (make-extra-search-list config:doc-search-dirs))
141
142(define (get-cross-lib-extra-search-dirs)
143  (make-extra-search-list config:lib-search-dirs))
144
145;; ----------------------------------------
146;; DLLs
147
148(define (get-dll-dir get-system-type force-cross?)
149  (delay/sync
150    (case (get-system-type)
151      [(windows)
152       (if (and (eq? (system-type) 'windows)
153                (not force-cross?))
154           ;; Extract "lib" location from binary:
155           (let ([exe (parameterize ([current-directory (find-system-path 'orig-dir)])
156                        (find-executable-path (find-system-path 'exec-file)))])
157             (and
158              exe
159              (with-input-from-file exe
160                (lambda ()
161                  (let ([m (regexp-match (byte-regexp
162                                          (bytes-append
163                                           (bytes->utf-16-bytes #"dLl dIRECTORy:")
164                                           #"((?:..)*?)\0\0"))
165                                         (current-input-port))])
166                    (unless m
167                      (error "cannot find \"dLl dIRECTORy\" tag in binary"))
168                    (let-values ([(dir name dir?) (split-path exe)])
169                      (if (regexp-match #rx#"^<" (cadr m))
170                          ;; no DLL dir in binary
171                          #f
172                          ;; resolve relative directory:
173                          (let ([p (bytes->path (utf-16-bytes->bytes (cadr m)))])
174                            (path->complete-path p dir)))))))))
175           ;; Cross-compile: assume it's "lib"
176           (find-lib-dir))]
177      [(macosx)
178       (if (and (eq? (system-type) 'macosx)
179                (not force-cross?))
180           (let* ([exe (parameterize ([current-directory (find-system-path 'orig-dir)])
181                         (let loop ([p (find-executable-path
182                                        (find-system-path 'exec-file))])
183                           (and
184                            p
185                            (if (link-exists? p)
186                                (loop (let-values ([(r) (resolve-path p)]
187                                                   [(dir name dir?) (split-path p)])
188                                        (if (and (path? dir)
189                                                 (relative-path? r))
190                                            (build-path dir r)
191                                            r)))
192                                p))))]
193                  [rel (and exe
194                            (let ([l (get/set-dylib-path exe "Racket" #f)])
195                              (if (null? l)
196                                  #f
197                                  (car l))))])
198             (cond
199              [(not rel) #f] ; no framework reference found!?
200              [(regexp-match
201                #rx#"^(@executable_path/)?(.*?)G?Racket.framework"
202                rel)
203               => (lambda (m)
204                    (let ([b (caddr m)])
205                      (if (and (not (cadr m)) (bytes=? b #""))
206                          #f ; no path in exe
207                          (simplify-path
208                           (path->complete-path
209                            (if (not (cadr m))
210                                (bytes->path b)
211                                (let-values ([(dir name dir?) (split-path exe)])
212                                  (if (bytes=? b #"")
213                                      dir
214                                      (build-path dir (bytes->path b)))))
215                            (find-system-path 'orig-dir))))))]
216              [else (find-lib-dir)]))
217           ;; Cross-compile: assume it's "lib"
218           (find-lib-dir))]
219      [else
220       (if (eq? 'shared (cross-system-type 'link))
221           (or (force config:dll-dir) (find-lib-dir))
222           #f)])))
223
224(define cross-dll-dir
225  (get-dll-dir cross-system-type
226               (eq? (system-type 'cross) 'force)))
227(define host-dll-dir
228  (get-dll-dir system-type
229               #f))
230
231(define (find-cross-dll-dir)
232  (force cross-dll-dir))
233
234(define (find-dll-dir)
235  (force host-dll-dir))
236
237;; ----------------------------------------
238
239(define (get-lib-search-dirs)
240  (cond
241   [(and (eq? (cross-system-type) (system-type))
242         (eq? (system-type 'cross) 'infer))
243    (get-cross-lib-search-dirs)]
244   [else
245    (force host-lib-search-dirs)]))
246
247(define host-config
248  (get-config-table
249   (lambda () (exe-relative-path->complete-path (find-system-path 'host-config-dir)))))
250
251(define host-lib-search-dirs
252  (delay/sync
253   (combine-search
254    (to-path (hash-ref (force host-config) 'lib-search-dirs #f))
255    (list (find-user-lib-dir)
256          (let ([coll-dir (exe-relative-path->complete-path
257                           (find-system-path 'host-collects-dir))])
258            (or (let ([p (hash-ref (force host-config) 'lib-dir #f)])
259                  (and p
260                       (path->complete-path p coll-dir)))
261                (build-path coll-dir 'up "lib")))))))
262