354 lines
11 KiB
Racket
354 lines
11 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/promise
|
|
compiler/private/winutf16
|
|
compiler/private/mach-o
|
|
"private/main-collects.rkt")
|
|
|
|
;; ----------------------------------------
|
|
;; "config"
|
|
|
|
(define config-dir
|
|
(delay (complete-path (find-system-path 'config-dir))))
|
|
|
|
(define (find-config-dir)
|
|
(force config-dir))
|
|
|
|
(provide find-config-dir)
|
|
|
|
;; ----------------------------------------
|
|
;; config: definitions
|
|
|
|
(define config-table
|
|
(delay (let ([d (find-config-dir)])
|
|
(if d
|
|
(let ([p (build-path d "config.rktd")])
|
|
(if (file-exists? p)
|
|
(call-with-input-file*
|
|
p
|
|
(lambda (in) (read in)))
|
|
#hash()))
|
|
#hash()))))
|
|
|
|
(define (to-path l)
|
|
(cond [(string? l) (complete-path (string->path l))]
|
|
[(bytes? l) (complete-path (bytes->path l))]
|
|
[(list? l) (map to-path l)]
|
|
[else l]))
|
|
|
|
(define (complete-path p)
|
|
(cond [(complete-path? p) p]
|
|
[(absolute-path? p) (exe-relative p)]
|
|
[else
|
|
(or (parameterize ([current-directory (find-system-path 'orig-dir)])
|
|
(find-executable-path (find-system-path 'exec-file) p))
|
|
(exe-relative p))]))
|
|
|
|
(define (exe-relative p)
|
|
(let ([exec (path->complete-path
|
|
(find-executable-path (find-system-path 'exec-file))
|
|
(find-system-path 'orig-dir))])
|
|
(let-values ([(base name dir?) (split-path exec)])
|
|
(path->complete-path p base))))
|
|
|
|
(define-syntax-rule (define-config name key wrap)
|
|
(define name (delay
|
|
(wrap
|
|
(hash-ref (force config-table) key #f)))))
|
|
|
|
(define-config config:collects-search-dirs 'collects-search-dirs to-path)
|
|
(define-config config:doc-dir 'doc-dir to-path)
|
|
(define-config config:doc-search-dirs 'doc-search-dirs to-path)
|
|
(define-config config:dll-dir 'dll-dir to-path)
|
|
(define-config config:lib-dir 'lib-dir to-path)
|
|
(define-config config:lib-search-dirs 'lib-search-dirs to-path)
|
|
(define-config config:include-dir 'include-dir to-path)
|
|
(define-config config:include-search-dirs 'include-search-dirs to-path)
|
|
(define-config config:bin-dir 'bin-dir to-path)
|
|
(define-config config:man-dir 'man-dir to-path)
|
|
(define-config config:links-file 'links-file to-path)
|
|
(define-config config:links-search-files 'links-search-files to-path)
|
|
(define-config config:pkgs-dir 'pkgs-dir to-path)
|
|
(define-config config:pkgs-search-dirs 'pkgs-search-dirs to-path)
|
|
(define-config config:cgc-suffix 'cgc-suffix values)
|
|
(define-config config:3m-suffix '3m-suffix values)
|
|
(define-config config:absolute-installation? 'absolute-installation? (lambda (x) (and x #t)))
|
|
(define-config config:doc-search-url 'doc-search-url values)
|
|
|
|
(provide get-absolute-installation?
|
|
get-cgc-suffix
|
|
get-3m-suffix
|
|
get-doc-search-url)
|
|
|
|
(define (get-absolute-installation?) (force config:absolute-installation?))
|
|
(define (get-cgc-suffix) (force config:cgc-suffix))
|
|
(define (get-3m-suffix) (force config:3m-suffix))
|
|
(define (get-doc-search-url) (or (force config:doc-search-url)
|
|
"http://docs.racket-lang.org"))
|
|
|
|
;; ----------------------------------------
|
|
;; "collects"
|
|
|
|
(define main-collects-dir
|
|
(delay (find-main-collects)))
|
|
|
|
(provide find-collects-dir
|
|
get-main-collects-search-dirs
|
|
find-user-collects-dir
|
|
get-collects-search-dirs)
|
|
(define (find-collects-dir)
|
|
(force main-collects-dir))
|
|
(define (get-main-collects-search-dirs)
|
|
(combine-search (force config:collects-search-dirs)
|
|
(list (find-collects-dir))))
|
|
(define user-collects-dir
|
|
(delay (build-path (system-path* 'addon-dir) (version) "collects")))
|
|
(define (find-user-collects-dir)
|
|
(force user-collects-dir))
|
|
(define (get-collects-search-dirs)
|
|
(current-library-collection-paths))
|
|
|
|
;; ----------------------------------------
|
|
;; Helpers
|
|
|
|
(define (single p) (if p (list p) null))
|
|
(define (extra a l) (if (and a (not (member a l))) (cons a l) l))
|
|
(define (combine-search l default)
|
|
;; Replace #f in list with default path:
|
|
(if l
|
|
(let loop ([l l])
|
|
(cond
|
|
[(null? l) null]
|
|
[(not (car l)) (append default (loop (cdr l)))]
|
|
[else (cons (car l) (loop (cdr l)))]))
|
|
default))
|
|
(define (cons-user u r)
|
|
(if (and u (use-user-specific-search-paths))
|
|
(cons u r)
|
|
r))
|
|
(define (get-false) #f)
|
|
(define (chain-to f) f)
|
|
|
|
(define-syntax define-finder
|
|
(syntax-rules (get-false chain-to)
|
|
[(_ provide config:id id user-id config:search-id search-id default)
|
|
(begin
|
|
(define-finder provide config:id id user-id default)
|
|
(provide search-id)
|
|
(define (search-id)
|
|
(combine-search (force config:search-id)
|
|
(cons-user (user-id) (single (id))))))]
|
|
[(_ provide config:id id user-id config:search-id search-id
|
|
extra-search-dir default)
|
|
(begin
|
|
(define-finder provide config:id id user-id default)
|
|
(provide search-id)
|
|
(define (search-id)
|
|
(combine-search (force config:search-id)
|
|
(extra (extra-search-dir)
|
|
(cons-user (user-id) (single (id)))))))]
|
|
[(_ provide config:id id get-false (chain-to get-default))
|
|
(begin
|
|
(provide id)
|
|
(define dir
|
|
(delay
|
|
(or (force config:id) (get-default))))
|
|
(define (id)
|
|
(force dir)))]
|
|
[(_ provide config:id id get-false default)
|
|
(begin
|
|
(provide id)
|
|
(define dir
|
|
(delay
|
|
(or (force config:id)
|
|
(let ([p (find-collects-dir)])
|
|
(and p (simplify-path (build-path p 'up 'up default)))))))
|
|
(define (id)
|
|
(force dir)))]
|
|
[(_ provide config:id id user-id default)
|
|
(begin
|
|
(define-finder provide config:id id get-false default)
|
|
(provide user-id)
|
|
(define user-dir
|
|
(delay (build-path (system-path* 'addon-dir) (version) default)))
|
|
(define (user-id)
|
|
(force user-dir)))]))
|
|
|
|
(define-syntax no-provide (syntax-rules () [(_ . rest) (begin)]))
|
|
|
|
;; ----------------------------------------
|
|
;; "doc"
|
|
|
|
(define delayed-#f (delay #f))
|
|
|
|
(provide find-doc-dir
|
|
find-user-doc-dir
|
|
get-doc-search-dirs)
|
|
(define-finder no-provide
|
|
config:doc-dir
|
|
find-doc-dir
|
|
find-user-doc-dir
|
|
delayed-#f
|
|
get-new-doc-search-dirs
|
|
"doc")
|
|
;; For now, include "doc" pseudo-collections in search path:
|
|
(define (get-doc-search-dirs)
|
|
(combine-search (force config:doc-search-dirs)
|
|
(append (get-new-doc-search-dirs)
|
|
(map (lambda (p) (build-path p "doc"))
|
|
(current-library-collection-paths)))))
|
|
|
|
;; ----------------------------------------
|
|
;; "include"
|
|
|
|
(define-finder provide
|
|
config:include-dir
|
|
find-include-dir
|
|
find-user-include-dir
|
|
config:include-search-dirs
|
|
get-include-search-dirs
|
|
"include")
|
|
|
|
;; ----------------------------------------
|
|
;; "lib"
|
|
|
|
(define-finder provide
|
|
config:lib-dir
|
|
find-lib-dir
|
|
find-user-lib-dir
|
|
config:lib-search-dirs
|
|
get-lib-search-dirs find-dll-dir
|
|
"lib")
|
|
|
|
;; ----------------------------------------
|
|
;; "man"
|
|
|
|
(define-finder provide
|
|
config:man-dir
|
|
find-man-dir
|
|
find-user-man-dir
|
|
"man")
|
|
|
|
;; ----------------------------------------
|
|
;; Executables
|
|
|
|
(define-finder provide
|
|
config:bin-dir
|
|
find-console-bin-dir
|
|
find-user-console-bin-dir
|
|
(case (system-type)
|
|
[(windows) 'same]
|
|
[(macosx unix) "bin"]))
|
|
|
|
(define-finder provide
|
|
config:bin-dir
|
|
find-gui-bin-dir
|
|
find-user-gui-bin-dir
|
|
(case (system-type)
|
|
[(windows macosx) 'same]
|
|
[(unix) "bin"]))
|
|
|
|
;; ----------------------------------------
|
|
;; DLLs
|
|
|
|
(provide find-dll-dir)
|
|
(define dll-dir
|
|
(delay
|
|
(case (system-type)
|
|
[(windows)
|
|
;; Extract "lib" location from binary:
|
|
(let ([exe (parameterize ([current-directory (system-path* 'orig-dir)])
|
|
(find-executable-path (find-system-path 'exec-file)))])
|
|
(and
|
|
exe
|
|
(with-input-from-file exe
|
|
(lambda ()
|
|
(let ([m (regexp-match (byte-regexp
|
|
(bytes-append
|
|
(bytes->utf-16-bytes #"dLl dIRECTORy:")
|
|
#"((?:..)*?)\0\0"))
|
|
(current-input-port))])
|
|
(unless m
|
|
(error "cannot find \"dLl dIRECTORy\" tag in binary"))
|
|
(let-values ([(dir name dir?) (split-path exe)])
|
|
(if (regexp-match #rx#"^<" (cadr m))
|
|
;; no DLL dir in binary
|
|
#f
|
|
;; resolve relative directory:
|
|
(let ([p (bytes->path (utf-16-bytes->bytes (cadr m)))])
|
|
(path->complete-path p dir)))))))))]
|
|
[(macosx)
|
|
(let* ([exe (parameterize ([current-directory (system-path* 'orig-dir)])
|
|
(let loop ([p (find-executable-path
|
|
(find-system-path 'exec-file))])
|
|
(and
|
|
p
|
|
(if (link-exists? p)
|
|
(loop (let-values ([(r) (resolve-path p)]
|
|
[(dir name dir?) (split-path p)])
|
|
(if (and (path? dir)
|
|
(relative-path? r))
|
|
(build-path dir r)
|
|
r)))
|
|
p))))]
|
|
[rel (and exe (get/set-dylib-path exe "Racket" #f))])
|
|
(cond
|
|
[(not rel) #f] ; no framework reference found!?
|
|
[(regexp-match
|
|
#rx#"^(@executable_path/)?(.*?)G?Racket.framework"
|
|
rel)
|
|
=> (lambda (m)
|
|
(let ([b (caddr m)])
|
|
(if (and (not (cadr m)) (bytes=? b #""))
|
|
#f ; no path in exe
|
|
(simplify-path
|
|
(path->complete-path
|
|
(if (not (cadr m))
|
|
(bytes->path b)
|
|
(let-values ([(dir name dir?) (split-path exe)])
|
|
(if (bytes=? b #"")
|
|
dir
|
|
(build-path dir (bytes->path b)))))
|
|
(system-path* 'orig-dir))))))]
|
|
[else (find-lib-dir)]))]
|
|
[else
|
|
(if (eq? 'shared (system-type 'link))
|
|
(or (force config:dll-dir) (find-lib-dir))
|
|
#f)])))
|
|
(define (find-dll-dir)
|
|
(force dll-dir))
|
|
|
|
;; ----------------------------------------
|
|
;; Links files
|
|
|
|
(provide find-links-file
|
|
get-links-search-files)
|
|
|
|
(define (find-links-file)
|
|
(or (force config:links-file)
|
|
(build-path (find-lib-dir) "links.rktd")))
|
|
(define (get-links-search-files)
|
|
(combine-search (force config:links-search-files)
|
|
(list (find-links-file))))
|
|
|
|
;; ----------------------------------------
|
|
;; Packages
|
|
|
|
(define-finder provide
|
|
config:pkgs-dir
|
|
find-pkgs-dir
|
|
get-false
|
|
config:pkgs-search-dirs
|
|
get-pkgs-search-dirs
|
|
(chain-to (lambda () (build-path (find-lib-dir) "pkgs"))))
|
|
|
|
(provide find-user-pkgs-dir
|
|
find-shared-pkgs-dir)
|
|
(define (find-user-pkgs-dir [vers (version)])
|
|
(build-path (find-system-path 'addon-dir)
|
|
vers
|
|
"pkgs"))
|
|
(define (find-shared-pkgs-dir)
|
|
(build-path (find-system-path 'addon-dir)
|
|
"pkgs"))
|