1#lang racket/base 2 3(require racket/match 4 racket/contract/base 5 planet/cachepath 6 syntax/modread 7 "dirs.rkt" 8 "path-relativize.rkt" 9 "private/encode-relative.rkt") 10 11;; in addition to infodomain/compiled/cache.rktd, getinfo will look in this 12;; file to find mappings. PLaneT uses this to put info about installed 13;; planet packages. 14(define user-infotable (get-planet-cache-path)) 15 16;; get-info : (listof path-or-string) -> info/#f 17(define (get-info coll-path #:namespace [ns #f] #:bootstrap? [bootstrap? #f]) 18 (get-info/full (apply collection-path 19 (map (lambda (x) (if (path? x) (path->string x) x)) 20 coll-path)) 21 #:namespace ns 22 #:bootstrap? bootstrap?)) 23 24;; These `require's ensure that the `#lang info' readers 25;; are loaded, so that no reader guard will be invoked for the reader 26;; intself when checking a language via a reader guard, and 27(require (only-in setup/infotab) 28 (only-in info) 29 (only-in setup/infotab/lang/reader) 30 (only-in (submod info reader))) 31 32;; get-info/full : path -> info/#f 33(define (get-info/full dir #:namespace [ns #f] #:bootstrap? [bootstrap? #f]) 34 (or (get-info/full/ext dir "rkt" ns bootstrap?) 35 (get-info/full/ext dir "ss" ns bootstrap?))) 36 37(define (get-info/full/ext dir ext ns bootstrap?) 38 (define file (build-path dir (format "info.~a" ext))) 39 (define enclosing-ns (variable-reference->namespace 40 (#%variable-reference))) 41 (define (err fmt . args) 42 (apply error 'get-info (string-append "info file " fmt " in ~a") 43 (append args (list file)))) 44 (define (contents) 45 (parameterize ([current-reader-guard 46 (lambda (x) 47 (if (or (eq? x 'setup/infotab/lang/reader) 48 (eq? x 'info/lang/reader) 49 (equal? x '(submod setup/infotab reader)) 50 (equal? x '(submod info reader))) 51 x 52 (err "has illegal #lang or #reader")))] 53 [current-namespace 54 ;; Use this module's namespace; see the `only-in' 55 ;; `require's above. 56 enclosing-ns]) 57 (with-input-from-file file 58 (lambda () 59 (begin0 60 (with-module-reading-parameterization read) 61 (unless (eof-object? (read)) 62 (err "has multiple expressions"))))))) 63 (and (file-exists? file) 64 (match (contents) 65 [(list 'module 'info 66 (or '(lib "infotab.rkt" "setup") 67 '(lib "infotab.ss" "setup") 68 '(lib "setup/infotab.rkt") 69 '(lib "setup/infotab.ss") 70 '(lib "main.rkt" "info") 71 'setup/infotab 72 'info) 73 expr ...) 74 ;; Although `#lang info` is intended to be loaded as code, 75 ;; many modules are so simple that we can synthesize the 76 ;; procedure directly: 77 (cond 78 [(and (not bootstrap?) 79 (= 1 (length expr)) 80 (list? (car expr)) 81 ((length (car expr)) . >= . 1) 82 (eq? '#%module-begin (caar expr)) 83 (for/fold ([ht #hasheq()]) ([e (in-list (cdar expr))]) 84 (match e 85 [`(define ,id ,rhs) 86 (and (symbol? id) 87 ht 88 (eq? file (hash-ref ht id file)) 89 (or (string? rhs) 90 (number? rhs) 91 (boolean? rhs) 92 (and (pair? rhs) 93 (eq? 'quote (car rhs)) 94 (list? rhs) 95 (= 2 (length rhs)))) 96 (hash-set ht id (if (pair? rhs) 97 (cadr rhs) 98 rhs)))] 99 [_ #f]))) 100 => (lambda (ht) 101 ;; This module is so simple that we don't need to `eval` it. 102 (lambda (key [default (lambda () (error 'info.rkt "no info for ~a" key))]) 103 (hash-ref ht key default)))] 104 [else 105 ;; Load the module. 106 ;; No need to set a reader-guard, since we checked it 107 ;; above (a guard will see other uses of #lang for stuff 108 ;; that is required). 109 ;; We are, however, trusting that the bytecode form of the 110 ;; file (if any) matches the source. 111 (parameterize ([current-environment-variables 112 (filter-environment-variables 113 (current-environment-variables))]) 114 (let ([ns (or ns (info-namespace))]) 115 (if (and bootstrap? 116 (parameterize ([current-namespace ns]) 117 (not (module-declared? file)))) 118 ;; Attach `info' language modules to target namespace, and 119 ;; disable the use of compiled bytecode if it fails; we 120 ;; need a trial namespace to try loading bytecode, since 121 ;; the use of bytecode "sticks" for later attempts. 122 (let ([attach! 123 (lambda (ns) 124 (namespace-attach-module enclosing-ns 'setup/infotab ns) 125 (namespace-attach-module enclosing-ns 'setup/infotab/lang/reader ns) 126 (namespace-attach-module enclosing-ns 'info ns) 127 (namespace-attach-module enclosing-ns '(submod info reader) ns))] 128 [try 129 (lambda (ns) 130 (parameterize ([current-namespace ns]) 131 (dynamic-require file '#%info-lookup)))]) 132 (define ns-id (namespace-module-registry ns)) 133 ((with-handlers ([exn:fail? (lambda (exn) 134 ;; Trial namespace is damaged, so uncache: 135 (hash-set! trial-namespaces ns-id #f) 136 ;; Try again from source: 137 (lambda () 138 (attach! ns) 139 (parameterize ([use-compiled-file-paths null]) 140 (try ns))))]) 141 ;; To reduce the cost of the trial namespace, try to used a cached 142 ;; one previously generated for the `ns': 143 (define try-ns (or (hash-ref trial-namespaces ns-id #f) 144 (let ([try-ns (make-base-empty-namespace)]) 145 (attach! try-ns) 146 try-ns))) 147 (define v (try try-ns)) 148 (hash-set! trial-namespaces ns-id try-ns) 149 (namespace-attach-module try-ns file ns) 150 (lambda () v)))) 151 ;; Can use compiled bytecode, etc.: 152 (parameterize ([current-namespace ns]) 153 (dynamic-require file '#%info-lookup)))))])] 154 [_ (err "does not contain a module of the right shape")]))) 155 156(define (filter-environment-variables ev) 157 (let ([keep (environment-variables-ref ev #"PLT_INFO_ALLOW_VARS")] 158 [new-ev (make-environment-variables)]) 159 (when keep 160 (for ([n (in-list (regexp-split #rx#";" keep))] 161 #:when (bytes-environment-variable-name? n)) 162 (define v (environment-variables-ref ev n)) 163 (when v 164 (environment-variables-set! new-ev n v)))) 165 new-ev)) 166 167(define info-namespace 168 ;; To avoid loading modules into the current namespace 169 ;; when get-info is called, load info modules in a separate 170 ;; namespace. 171 (let ([ns-box (make-weak-box #f)]) 172 (lambda () 173 (or (weak-box-value ns-box) 174 (let ([ns (make-base-empty-namespace)]) 175 (set! ns-box (make-weak-box ns)) 176 ns))))) 177 178;; Weak map from a namespace registry to a trial-loading namespace for 179;; bootstrap mode: 180(define trial-namespaces (make-weak-hasheq)) 181 182;; directory-record = (make-directory-record nat nat key path (listof symbol)) 183;; eg: (make-directory-record 1 0 '(lib "mzlib") #"mzlib" '(name)) 184(define-struct directory-record (maj min spec path syms)) 185 186(define-struct table (insert ; directory-record (listof directory-record) 187 ; -> (listof directory-record) 188 ht ; hashtable[symbol -o> directory-record] 189 paths ; (listof (cons path boolean)) 190 ) 191 #:mutable) 192 193(define preferred-table #f) 194(define all-available-table #f) 195(define no-planet-table #f) 196(define no-user-table #f) 197 198;; reset-relevant-directories-state! : -> void 199(define (reset-relevant-directories-state!) 200 (set! preferred-table 201 (make-table 202 (lambda (root-dir i l) 203 (if (or root-dir (null? l)) 204 (cons i l) 205 (match-let ([(struct directory-record (my-maj my-min _ _ _)) i] 206 [(struct directory-record (their-maj their-min _ _ _)) 207 (car l)]) 208 (if (or (> my-maj their-maj) 209 (and (= my-maj their-maj) (>= my-min their-min))) 210 (list i) 211 l)))) 212 #f #f)) 213 (define (always root-dir i l) (cons i l)) 214 (set! all-available-table (make-table always #f #f)) 215 (set! no-planet-table (make-table always #f #f)) 216 (set! no-user-table (make-table always #f #f))) 217 218(reset-relevant-directories-state!) 219 220;; populate-table : table -> void 221(define (populate-table! t) 222 ;; Use the colls ht because a collection might be in multiple 223 ;; collection paths, and we only want one 224 (define-values (path->main-share-relative 225 main-share-relative->path) 226 (make-relativize find-share-dir 227 'share 228 'path->main-share-relative 229 'main-share-relative->path)) 230 (define-values (path->main-lib-relative 231 main-lib-relative->path) 232 (make-relativize find-lib-dir 233 'lib 234 'path->main-lib-relative 235 'main-lib-relative->path)) 236 (let ([colls (make-hash)]) 237 (for ([f+root-dir (reverse (table-paths t))]) 238 (let ([f (car f+root-dir)] 239 [root-dir (cdr f+root-dir)]) 240 (define-values (path->info-relative 241 info-relative->path) 242 (make-relativize (lambda () root-dir) 243 'info 244 'path->info-relative 245 'info-relative->path)) 246 (when (file-exists? f) 247 (for ([i (let ([l (with-input-from-file f read)]) 248 (cond [(list? l) l] 249 [(eof-object? l) '()] ;; allow completely empty files 250 [else (error 'find-relevant-directories 251 "bad info-domain cache file: ~a" f)]))]) 252 (match i 253 [(list (and pathbytes (or (? bytes?) 254 (list (or 'info 'share 'lib) (? bytes?) ...) 255 (list 'rel (or 'up (? bytes?)) ...))) 256 (list (? symbol? fields) ...) 257 key ;; anything is okay here 258 (? integer? maj) 259 (? integer? min)) 260 (let ([old-items (hash-ref colls key null)] 261 [new-item 262 (make-directory-record 263 maj min key 264 (if (bytes? pathbytes) 265 (let ([p (bytes->path pathbytes)]) 266 (if (and (relative-path? p) root-dir) 267 ;; `raco setup' doesn't generate relative paths anyway, 268 ;; but it's ok to support them: 269 (simplify-path (build-path root-dir p)) 270 p)) 271 (case (car pathbytes) 272 [(rel) (simplify-path (build-path root-dir (decode-relative-path pathbytes)))] 273 [(info) (info-relative->path pathbytes)] 274 [(share) (main-share-relative->path pathbytes)] 275 [(lib) (main-lib-relative->path pathbytes)])) 276 fields)]) 277 (hash-set! colls key 278 ((table-insert t) root-dir new-item old-items)))] 279 [_ (error 'find-relevant-directories 280 "bad info-domain cache entry: ~e in: ~a" i f)]))))) 281 ;; For each coll, invert the mapping, adding the col name to the list 282 ;; for each sym: 283 (for* ([(key vals) colls] 284 [val vals]) 285 (match val 286 [(struct directory-record (maj min spec path syms)) 287 (for ([sym syms]) 288 (hash-set! (table-ht t) sym 289 (cons val (hash-ref (table-ht t) sym null))))] 290 [_ (error 'get-info 291 "Internal error: invalid info-domain value format: ~s" val)])))) 292 293(define (find-relevant-directories syms [key 'preferred]) 294 (map directory-record-path (find-relevant-directory-records syms key))) 295 296(define (find-relevant-directory-records syms [key 'preferred]) 297 (define t 298 (cond [(eq? key 'preferred) preferred-table] 299 [(eq? key 'all-available) all-available-table] 300 [(eq? key 'no-planet) no-planet-table] 301 [(eq? key 'no-user) no-user-table] 302 [else (error 'find-relevant-directories "Invalid key: ~s" key)])) 303 ;; A list of (cons cache.rktd-path root-dir-path) 304 ;; If root-dir-path is not #f, then paths in the cache.rktd 305 ;; file are relative to it. #f is used for the planet cache.rktd file. 306 (define search-path 307 ((if (or (eq? key 'no-planet) 308 (eq? key 'no-user)) 309 (lambda (a l) l) 310 cons) 311 (cons user-infotable #f) 312 (append 313 (map (lambda (coll) 314 (cons (build-path coll "info-domain" "compiled" "cache.rktd") 315 coll)) 316 (if (eq? key 'no-user) 317 (get-main-collects-search-dirs) 318 (current-library-collection-paths))) 319 (map (lambda (base) 320 (cons (build-path base "info-cache.rktd") 321 base)) 322 (filter 323 values 324 (if (eq? key 'no-user) 325 (list (find-share-dir)) 326 (list (find-share-dir) (find-user-share-dir)))))))) 327 (when t 328 (unless (equal? (table-paths t) search-path) 329 (set-table-ht! t (make-hasheq)) 330 (set-table-paths! t search-path) 331 (populate-table! t))) 332 (let ([unsorted 333 (if (= (length syms) 1) 334 ;; Simple case: look up in table 335 (hash-ref (table-ht t) (car syms) null) 336 ;; Use a hash table, because the same collection might work 337 ;; for multiple syms 338 (let ([result (make-hash)]) 339 (for* ([sym syms] 340 [c (hash-ref (table-ht t) sym null)]) 341 (hash-set! result c #t)) 342 ;; Extract the relevant collections: 343 (hash-map result (lambda (k v) k))))]) 344 (sort unsorted bytes<? 345 #:key (lambda (dr) (dir->sort-key (directory-record-path dr))) 346 #:cache-keys? #t))) 347 348;; dir->sort-key : path -> bytes 349;; extracts the name of the directory, dropping any "."s it finds at the ends. 350(define (dir->sort-key path) 351 (let-values ([(base name dir?) (split-path path)]) 352 (if (eq? name 'same) (dir->sort-key base) (path->bytes name)))) 353 354(define info? (->* [symbol?] [(-> any/c)] any/c)) 355(define path-or-string? (lambda (x) (or (path? x) (string? x)))) 356 357(provide/contract 358 (reset-relevant-directories-state! (-> any)) 359 (get-info (((listof path-or-string?)) 360 (#:namespace (or/c namespace? #f) #:bootstrap? any/c) 361 . ->* . (or/c info? boolean?))) 362 (get-info/full ((path-string?) 363 (#:namespace (or/c namespace? #f) #:bootstrap? any/c) 364 . ->* . (or/c info? boolean?))) 365 (find-relevant-directories 366 (->* [(listof symbol?)] 367 [(or/c 'preferred 'all-available 'no-planet 'no-user)] 368 (listof path?))) 369 (struct directory-record 370 ([maj integer?] 371 [min integer?] 372 [spec any/c] 373 [path path?] 374 [syms (listof symbol?)])) 375 (find-relevant-directory-records 376 (->* [(listof symbol?)] 377 [(or/c 'preferred 'all-available 'no-planet 'no-user)] 378 (listof directory-record?)))) 379