1#lang racket/base 2(require racket/set 3 setup/collection-name 4 setup/matching-platform 5 setup/getinfo 6 "../path.rkt" 7 "params.rkt" 8 "metadata.rkt" 9 "get-info.rkt") 10 11(provide pkg-directory->additional-installs 12 directory->additional-installs 13 get-additional-installed) 14 15(define (pkg-directory->additional-installs dir pkg-name 16 #:namespace [metadata-ns (make-metadata-namespace)] 17 #:system-type [sys-type #f] 18 #:system-library-subpath [sys-lib-subpath #f]) 19 (set->list (directory->additional-installs dir pkg-name metadata-ns 20 #:system-type sys-type 21 #:system-library-subpath sys-lib-subpath))) 22 23(define (directory->additional-installs dir pkg-name metadata-ns 24 #:system-type [sys-type #f] 25 #:system-library-subpath [sys-lib-subpath #f]) 26 (define single-collect 27 (pkg-single-collection dir #:name pkg-name #:namespace metadata-ns)) 28 ;; In this loop `omits` is a set of paths built on `dir`, and `prefix+rxes` 29 ;; is a set of regular expressions to continue using as we recur down; 30 ;; each regular expression is matched relative to the directory where it was 31 ;; introduced, so we have to build up a prefix to use with each regexp 32 (let loop ([s (set)] [f-rel dir] [wrt #f] [top? #t] [omits (set)] [prefix+rxs '()]) 33 (define f (if wrt (build-path wrt f-rel) f-rel)) 34 (cond 35 [(and (directory-exists? f) 36 (let ([sf (simplify-path f)]) 37 (and (not (set-member? omits sf)) 38 (not (for/or ([prefix+rx (in-list prefix+rxs)]) 39 (define prefix (car prefix+rx)) 40 (regexp-match? (cdr prefix+rx) (if (eq? prefix 'same) 41 f-rel 42 (build-path prefix f-rel)))))))) 43 (define i (get-pkg-info f metadata-ns)) 44 (define omit-paths (if i 45 (i 'compile-omit-paths (lambda () null)) 46 null)) 47 (cond 48 [(eq? omit-paths 'all) 49 s] 50 [else 51 (define omit-files (if i 52 (i 'compile-omit-files (lambda () null)) 53 null)) 54 (define new-s 55 (if (and i (or single-collect (not top?))) 56 (set-union (extract-additional-installs i sys-type sys-lib-subpath) 57 s) 58 s)) 59 (define new-omits 60 (set-union omits 61 (for/set ([i (in-list (append omit-paths omit-files))] 62 #:unless (regexp? i)) 63 (simplify-path (build-path f i))))) 64 (define new-prefix+rxs 65 (append (for/list ([i (in-list (append omit-paths omit-files))] 66 #:when (regexp? i)) 67 (cons 'same i)) 68 ;; add to prefix for rxs accumulated so far 69 (for/list ([prefix+rx (in-list prefix+rxs)]) 70 (define prefix (car prefix+rx)) 71 (cons (if (eq? prefix 'same) 72 f-rel 73 (build-path prefix f-rel)) 74 (cdr prefix+rx))))) 75 (for/fold ([s new-s]) ([sub-f (directory-list f)]) 76 (loop s sub-f f #f new-omits new-prefix+rxs))])] 77 [else s]))) 78 79(define (extract-additional-installs i sys-type sys-lib-subpath) 80 (define (extract-documents i) 81 (let ([s (i 'scribblings (lambda () null))]) 82 (for/set ([doc (in-list (if (list? s) s null))] 83 #:when (and (list? doc) 84 (pair? doc) 85 (path-string? (car doc)) 86 (or ((length doc) . < . 2) 87 (list? (cadr doc))) 88 (or ((length doc) . < . 4) 89 (collection-name-element? (list-ref doc 3))))) 90 (define flags (if ((length doc) . < . 2) 91 null 92 (cadr doc))) 93 (cond 94 [(member 'main-doc-root flags) '(main-doc-root . "root")] 95 [(member 'user-doc-root flags) '(user-doc-root . "root")] 96 [else 97 (cons 'doc 98 (string-foldcase 99 (if ((length doc) . < . 4) 100 (let-values ([(base name dir?) (split-path (car doc))]) 101 (path->string (path-replace-extension name #""))) 102 (list-ref doc 3))))])))) 103 (define (extract-paths i tag keys) 104 (define (get k) 105 (define l (i k (lambda () null))) 106 (if (and (list? l) (andmap path-string? l)) 107 l 108 null)) 109 (list->set (map (lambda (v) (cons tag 110 (let-values ([(base name dir?) (split-path v)]) 111 ;; Normalize case, because some platforms 112 ;; have case-insensitive filesystems: 113 (string-foldcase (path->string name))))) 114 (apply 115 append 116 (for/list ([k (in-list keys)]) 117 (get k)))))) 118 (define (extract-launchers i) 119 (extract-paths i 'exe '(racket-launcher-names 120 mzscheme-launcher-names 121 gracket-launcher-names 122 mred-launcher-names))) 123 (define (extract-foreign-libs i) 124 (extract-paths i 'lib '(copy-foreign-libs 125 move-foreign-libs))) 126 (define (extract-shared-files i) 127 (extract-paths i 'share '(copy-shared-files 128 move-shared-files))) 129 (define (extract-man-pages i) 130 (extract-paths i 'man '(copy-man-pages 131 move-man-pages))) 132 (define (this-platform? i) 133 (define v (i 'install-platform (lambda () #rx""))) 134 (or (not (platform-spec? v)) 135 (matching-platform? v 136 #:cross? #t 137 #:system-type sys-type 138 #:system-library-subpath sys-lib-subpath))) 139 (set-union (extract-documents i) 140 (extract-launchers i) 141 (if (this-platform? i) 142 (set-union 143 (extract-foreign-libs i) 144 (extract-shared-files i) 145 (extract-man-pages i)) 146 (set)))) 147 148(define (get-additional-installed kind skip-ht-keys ai-cache metadata-ns path-pkg-cache) 149 (or (unbox ai-cache) 150 (let () 151 (define skip-pkgs (list->set (hash-keys skip-ht-keys))) 152 (define dirs (find-relevant-directories '(scribblings 153 racket-launcher-names 154 mzscheme-launcher-names 155 gracket-launcher-names 156 mred-launcher-names 157 copy-foreign-libs 158 move-foreign-libs 159 copy-shared-files 160 move-shared-files 161 copy-man-pages 162 move-man-pages) 163 (if (eq? 'user (current-pkg-scope)) 164 'all-available 165 'no-user))) 166 (define s (for/fold ([s (set)]) ([dir (in-list dirs)]) 167 (cond 168 [(set-member? skip-pkgs (path->pkg dir #:cache path-pkg-cache)) 169 s] 170 [else 171 (define i (get-pkg-info dir metadata-ns)) 172 (if i 173 (set-union s (extract-additional-installs i #f #f)) 174 s)]))) 175 (set-box! ai-cache s) 176 s))) 177 178