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