1;; Expects parameters to be set before invocation. 2;; Calls `exit' when done. 3 4#lang racket/base 5 6(require racket/path 7 racket/file 8 racket/port 9 racket/match 10 racket/system 11 racket/list 12 racket/string 13 compiler/cm 14 compiler/compilation-path 15 compiler/cross 16 planet/planet-archives 17 planet/private/planet-shared 18 (only-in planet/resolver resolve-planet-path) 19 setup/cross-system 20 setup/variant 21 22 "option.rkt" 23 compiler/compiler 24 (prefix-in compiler:option: compiler/option) 25 launcher/launcher 26 compiler/module-suffix 27 28 "unpack.rkt" 29 "getinfo.rkt" 30 "dirs.rkt" 31 "matching-platform.rkt" 32 "main-collects.rkt" 33 "path-to-relative.rkt" 34 "path-relativize.rkt" 35 "private/omitted-paths.rkt" 36 "parallel-build.rkt" 37 "private/cc-struct.rkt" 38 "link.rkt" 39 "private/dylib.rkt" 40 "private/elf.rkt" 41 "private/pkg-deps.rkt" 42 "collection-name.rkt" 43 "private/format-error.rkt" 44 "private/encode-relative.rkt" 45 "private/time.rkt" 46 compiler/private/dep 47 (only-in pkg/lib pkg-directory 48 pkg-single-collection)) 49 50(define-namespace-anchor anchor) 51 52;; Although we use `#:bootstrap?' mode for reading an "info.rkt" file, 53;; which disables the use of compiled bytecode, also use whatever 54;; namespace, .zo-use, and compilation configuration was in place for 55;; loading setup (just in case), instead of whatever is in place for 56;; the collections that setup is processing: 57(define make-getinfo 58 (let ([ns (namespace-anchor->empty-namespace anchor)] 59 [compile (current-compile)] 60 [loader (current-load/use-compiled)] 61 [paths (use-compiled-file-paths)]) 62 (lambda (info-ns) 63 (lambda (path) 64 (parameterize ([current-namespace ns] 65 [current-compile compile] 66 [current-load/use-compiled loader] 67 [use-compiled-file-paths paths]) 68 (get-info/full path 69 #:namespace info-ns 70 #:bootstrap? #t)))))) 71 72(provide setup-core) 73 74(define (setup-core) 75 76 (define name-str (setup-program-name)) 77 (define name-sym (string->symbol name-str)) 78 (define main-collects-dir (simple-form-path (find-collects-dir))) 79 (define main-collects-dirs (for/hash ([p (in-list (get-main-collects-search-dirs))]) 80 (values (simple-form-path p) #t))) 81 (define main-links-files (for/hash ([p (in-list (get-links-search-files))]) 82 (values (simple-form-path p) #t))) 83 84 (define mode-dir 85 (let ([compiled-dir (let ([l (or (setup-compiled-file-paths) 86 (use-compiled-file-paths))]) 87 (if (pair? l) 88 (car l) 89 "compiled"))]) 90 (if (compile-mode) 91 (build-path compiled-dir (compile-mode)) 92 (build-path compiled-dir)))) 93 94 (unless (make-user) 95 (current-library-collection-paths 96 (for/list ([p (current-library-collection-paths)] 97 #:when (hash-ref main-collects-dirs p #f)) 98 p))) 99 100 (current-library-collection-paths 101 (if (member #f (current-library-collection-links)) 102 ;; Normal case, include current library collection paths: 103 (map simple-form-path (current-library-collection-paths)) 104 ;; No `#f' in links list means that we don't look at 105 ;; the current library collection paths: 106 null)) 107 108 (define (setup-fprintf p task s . args) 109 (let ([task (if task (string-append task ": ") "")]) 110 (apply fprintf p 111 (string-append name-str ": " task s 112 (if timestamp-output? 113 (format " @ ~a" (current-process-milliseconds)) 114 "") 115 "\n") 116 args) 117 (flush-output p))) 118 119 (define (setup-printf task s . args) 120 (apply setup-fprintf (current-output-port) task s args)) 121 122 (define (exn->string x) (if (exn? x) (exn-message x) (format "~s" x))) 123 124 ;; auto-curried list-of 125 (define list-of 126 (case-lambda [(pred) (lambda (x) (and (list? x) (andmap pred x)))] 127 [(pred x) ((list-of pred) x)])) 128 129 (define (relative-path-string? x) (and (path-string? x) (relative-path? x))) 130 131 (define (call-info info flag mk-default test) 132 (let ([v (info flag mk-default)]) (test v) v)) 133 134 (define path->relative-string/console-bin 135 (make-path->relative-string 136 (list (cons find-console-bin-dir "<console-bin>/")))) 137 (define path->relative-string/gui-bin 138 (make-path->relative-string 139 (list (cons find-gui-bin-dir "<gui-bin>/")))) 140 141 (define path->relative-string/lib 142 (make-path->relative-string 143 (list (cons find-lib-dir "<lib>/")))) 144 145 (define path->relative-string/share 146 (make-path->relative-string 147 (list (cons find-share-dir "<share>/")))) 148 149 (define path->relative-string/man 150 (make-path->relative-string 151 (list (cons find-man-dir "<man>/")))) 152 153 (define-values (path->main-lib-relative 154 main-lib-relative->path) 155 (make-relativize find-lib-dir 156 'lib 157 'path->main-lib-relative 158 'main-lib-relative->path)) 159 160 ;; For checking and debugging memory leaks; set `PLT_SETUP_DMS_ARGS` 161 ;; to an S-expression list and use `-j 1` to run a non-parallel setup: 162 (define post-collection-dms-args 163 (let ([v (getenv "PLT_SETUP_DMS_ARGS")]) 164 (and v (read (open-input-string v))))) 165 166 ;; Also help to check for leaks: set `PLT_SETUP_LIMIT_CACHE` to 167 ;; avoid caching compile-file information across different collections: 168 (define limit-cross-collection-cache? 169 (getenv "PLT_SETUP_LIMIT_CACHE")) 170 171 ;; In non-parallel mode, forcing a GC after each collection or 172 ;; document is a relatively good time-to-space tradeoff, so do that 173 ;; unless `PLT_SETUP_NO_FORCE_GC` is set: 174 (define gc-after-each-sequential? 175 (not (getenv "PLT_SETUP_NO_FORCE_GC"))) 176 177 ;; Option to show CPU time since startup on each status line: 178 (define timestamp-output? 179 (and (getenv "PLT_SETUP_SHOW_TIMESTAMPS") #t)) 180 181 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 182 ;; Errors ;; 183 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 184 185 (define errors null) 186 (define exit-code 0) 187 (define original-thread (current-thread)) 188 (define (append-error cc desc exn out err type) 189 (set! errors (cons (list cc desc exn out err type) errors)) 190 (when (fail-fast) 191 (break-thread original-thread))) 192 (define (handle-error cc desc exn out err type) 193 (define long? #t) ; possibly better: (define long? (verbose)) 194 (cond 195 [(exn? exn) 196 (format-error exn #:long? long?)] 197 [(and (pair? exn) (string? (car exn)) (string? (cdr exn))) 198 (eprintf "~a\n" ((if long? car cdr) exn))]) 199 (append-error cc desc exn out err type)) 200 (define (record-error cc desc go fail-k) 201 (with-handlers ([exn:fail? 202 (lambda (x) 203 (handle-error cc desc x "" "" "error") 204 (fail-k))]) 205 (go))) 206 (define-syntax begin-record-error 207 (syntax-rules () 208 [(_ cc desc body ...) (record-error cc desc (lambda () body ...) void)])) 209 (define (show-errors port) 210 (for ([e (reverse errors)]) 211 (match-let ([(list cc desc x out err type) e]) 212 (setup-fprintf port type "during ~a for ~a" desc (cond 213 [(cc? cc) (cc-name cc)] 214 [(path? cc) 215 (path->relative-string/setup cc #:cache pkg-path-cache)] 216 [else cc])) 217 (let ([msg (cond 218 [(exn? x) 219 (format-error x #:long? #f #:to-string? #t #:cache pkg-path-cache)] 220 [(not x) 221 ;; No error; just output 222 #f] 223 [else 224 ;; `x` is a pair of strings, long and short forms of the error: 225 (cdr x)])]) 226 (when x 227 (for ([str (in-list (regexp-split #rx"\n" msg))]) 228 (setup-fprintf port #f " ~a" str)))) 229 (unless (zero? (string-length out)) (eprintf "STDOUT:\n~a=====\n" out)) 230 (unless (zero? (string-length err)) (eprintf "STDERR:\n~a=====\n" err))))) 231 232 (define (done) 233 (unless (null? errors) 234 (setup-printf #f (add-time "--- summary of errors ---")) 235 (show-errors (current-error-port)) 236 (when (pause-on-errors) 237 (eprintf "INSTALLATION FAILED.\nPress Enter to continue...\n") 238 (read-line)) 239 (set! exit-code 1)) 240 (manage-prevous-and-next) 241 (exit exit-code)) 242 243 (define (manage-prevous-and-next) 244 (define prev (previous-error-in-file)) 245 (when (and prev (file-exists? prev)) 246 (setup-printf #f (add-time "--- previous errors ---")) 247 (setup-printf #f "errors were~a reported by a previous process" 248 (if (zero? exit-code) "" " also")) 249 (set! exit-code 1)) 250 (define next (next-error-out-file)) 251 (when next 252 (cond 253 [(zero? exit-code) 254 (delete-directory/files next #:must-exist? #f)] 255 [else 256 (call-with-output-file* 257 next 258 #:exists 'truncate/replace 259 (lambda (o) (fprintf o "Errors reported\n"))) 260 (set! exit-code 0)]))) 261 262 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 263 ;; Archive Unpacking ;; 264 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 265 266 (define make-docs? 267 (and (make-docs) 268 ;; Double-check that `setup/scribble' is present: 269 (let ([p (collection-file-path "scribble.rkt" "setup")]) 270 (or (file-exists? p) 271 (file-exists? (get-compilation-bytecode-file p)))))) 272 273 (define (pkg->collections pkg) 274 (define dir (pkg-directory pkg)) 275 (cond 276 [dir 277 (define collect (pkg-single-collection dir #:name pkg)) 278 (if collect 279 (list (list collect)) 280 (for/list ([d (directory-list dir)] 281 #:when (and (directory-exists? (build-path dir d)) 282 (collection-name-element? (path->string d)))) 283 (list d)))] 284 [else 285 (error 'pkd->collections 286 (string-append "package not found\n" 287 " package: ~a") 288 pkg)])) 289 290 (define x-specific-collections 291 (append* (specific-collections) 292 (apply append 293 (map pkg->collections 294 (specific-packages))) 295 (if (and (make-doc-index) 296 make-docs?) 297 (append 298 (if (not (avoid-main-installation)) 299 '(("scribblings/main")) 300 null) 301 (if (make-user) 302 '(("scribblings/main/user")) 303 null)) 304 null) 305 (for/list ([x (in-list (archives))]) 306 (unpack x 307 (build-path main-collects-dir 'up) 308 (lambda (s) (setup-printf #f "~a" s)) 309 (current-target-directory-getter) 310 (force-unpacks) 311 (current-target-plt-directory-getter))))) 312 313 ;; specific-planet-dir ::= 314 ;; - (list path[directory] string[owner] string[package-name] (listof string[extra package path]) Nat[maj] Nat[min]), or 315 ;; - (list string[owner] string[package-name] string[maj as string] string[min as string]) 316 ;; x-specific-planet-dir ::= (listof specific-planet-dir) 317 (define x-specific-planet-dirs 318 (if (make-planet) (specific-planet-dirs) null)) 319 320 (define no-specific-collections? 321 (and (null? x-specific-collections) 322 (null? x-specific-planet-dirs) 323 (not (make-only)))) 324 325 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 326 ;; Find Collections ;; 327 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 328 329 (define pkg-path-cache (make-hash)) 330 331 (define info-ns (make-base-namespace)) 332 (define getinfo (make-getinfo info-ns)) 333 334 (define info-failures (make-hash)) 335 (define (getinfo/log-failure path) 336 (with-handlers ([exn:fail? (lambda (exn) 337 (if (hash-ref info-failures path #f) 338 #f 339 (begin 340 (hash-set! info-failures path #t) 341 (handle-error path "load of info.rkt" exn "" "" "error") 342 #f)))]) 343 (getinfo path))) 344 345 (define (make-cc* collection parent path omit-root info-root 346 info-path info-path-mode shadowing-policy 347 main?) 348 (define info 349 (or (getinfo/log-failure path) 350 (lambda (flag mk-default) (mk-default)))) 351 (define name 352 (call-info 353 info 'name (lambda () #f) 354 (lambda (x) 355 (when (and x (not (string? x))) 356 (error name-sym 357 "'name' result from collection ~e is not a string: ~e" 358 path x))))) 359 (define path-name (path->relative-string/setup path #:cache pkg-path-cache)) 360 (when (info 'compile-subcollections (lambda () #f)) 361 (setup-printf "WARNING" 362 "ignoring `compile-subcollections' entry in info ~a" 363 path-name)) 364 (make-cc collection path 365 (if name 366 (format "~a (~a)" path-name name) 367 path-name) 368 info 369 parent 370 omit-root 371 info-root info-path info-path-mode 372 shadowing-policy 373 main?)) 374 375 (define ((warning-handler v) exn) 376 (setup-printf "WARNING" "~a" (exn->string exn)) 377 v) 378 379 ;; Maps a collection name to a list of `cc's: 380 (define collection-ccs-table (make-hash)) 381 382 ;; collection-cc! : listof-path .... -> cc 383 (define (collection-cc! collection-p 384 #:parent [parent-cc #f] 385 #:path [dir (apply collection-path collection-p)] 386 #:omit-root [omit-root #f] 387 #:info-root [info-root #f] 388 #:info-path [info-path #f] 389 #:info-path-mode [info-path-mode 'relative] 390 #:main? [main? #f]) 391 (unless (directory-exists? dir) 392 (error name-sym "directory: ~e does not exist for collection: ~s" 393 dir 394 (string-join (map path->string collection-p) "/"))) 395 (unless info-root 396 (error name-sym "cannot find info root for collection: ~s and path: ~e" 397 (string-join (map path->string collection-p) "/") 398 dir)) 399 (define new-cc 400 (make-cc* collection-p 401 parent-cc 402 dir 403 (if (eq? omit-root 'dir) 404 dir 405 omit-root) ; #f => `omitted-paths' can reconstruct it 406 info-root 407 (or info-path 408 (build-path info-root "info-domain" "compiled" "cache.rktd")) 409 info-path-mode 410 ;; by convention, all collections have "version" 1 0. This 411 ;; forces them to conflict with each other. 412 (list (cons 'lib (map path->string collection-p)) 1 0) 413 main?)) 414 (when new-cc 415 (hash-update! collection-ccs-table 416 collection-p 417 (lambda (lst) (cons new-cc lst)) 418 null)) 419 new-cc) 420 421 ;; collection->ccs : listof-path -> listof-cc 422 (define (collection->ccs collection-p) 423 (hash-ref collection-ccs-table collection-p null)) 424 425 ;; planet-spec->planet-list : (list string string nat nat) -> (list path string string (listof string) nat nat) | #f 426 ;; converts a planet package spec into the information needed to create a cc structure 427 (define (planet-spec->planet-list spec) 428 (match spec 429 [(list owner pkg-name maj-str min-str) 430 (define maj 431 (or (string->number maj-str) 432 (error name-sym "bad major version for PLaneT package: ~e" maj-str))) 433 (define min 434 (or (string->number min-str) 435 (error name-sym "bad minor version for PLaneT package: ~e" min-str))) 436 (or (lookup-package-by-keys owner pkg-name maj min min) 437 (error name-sym "not an installed PLaneT package: (~e ~e ~e ~e)" 438 owner pkg-name maj min))] 439 [_ spec])) 440 441 (define (planet-cc! path #:omit-root [omit-root path] owner pkg-file extra-path maj min) 442 (unless (path? path) 443 (error 'planet-cc! "non-path when building package ~e" pkg-file)) 444 (and (directory-exists? path) 445 (make-cc* #f 446 #f 447 path 448 omit-root 449 #f ; don't need info-root; absolute paths in cache.rktd will be ok 450 (get-planet-cache-path) 451 'abs 452 (list `(planet ,owner ,pkg-file ,@extra-path) maj min) 453 #f))) 454 455 ;; planet-cc->sub-cc : cc (listof bytes [encoded path]) -> cc 456 ;; builds a compilation job for the given subdirectory of the given cc this 457 ;; is an awful hack 458 (define (planet-cc->sub-cc cc subdir) 459 (match-let ([(list (list 'planet owner pkg-file extra-path ...) maj min) 460 (cc-shadowing-policy cc)]) 461 (planet-cc! (apply build-path (cc-path cc) (map bytes->path subdir)) 462 #:omit-root (cc-omit-root cc) 463 owner 464 pkg-file 465 (append extra-path subdir) 466 maj 467 min))) 468 469 (define (skip-collection-directory? collection) 470 ;; Skiping ".git" or ".svn" makes it cleaner to use a git of subversion 471 ;; checkout as a collection directory 472 (regexp-match? #rx"[.](git|svn)$" (path->bytes collection))) 473 474 ;; Add in all non-planet collections, first from 475 ;; `current-library-collection-paths': 476 (for ([cp (current-library-collection-paths)] 477 #:when (directory-exists? cp) 478 [collection (directory-list cp)] 479 #:unless (skip-collection-directory? collection) 480 #:when (directory-exists? (build-path cp collection))) 481 (collection-cc! (list collection) 482 #:info-root cp 483 #:path (build-path cp collection) 484 #:main? (hash-ref main-collects-dirs cp #f))) 485 ;; Now from `current-library-collection-links' for installation-wide 486 ;; links: 487 (let () 488 (define info-root (find-share-dir)) 489 (define info-path (build-path info-root "info-cache.rktd")) 490 (define (cc! col #:path path) 491 (collection-cc! col 492 #:path path 493 #:info-root info-root 494 #:info-path info-path 495 #:info-path-mode 'abs-in-relative 496 #:omit-root 'dir 497 #:main? #t)) 498 (for ([inst-links (in-list (current-library-collection-links))] 499 #:when (and (path? inst-links) 500 (hash-ref main-links-files (simple-form-path inst-links) #f))) 501 (for ([c+p (in-list (links #:file inst-links #:with-path? #t))]) 502 (cc! (list (string->path (car c+p))) 503 #:path (cdr c+p))) 504 (for ([cp (in-list (links #:root? #t #:file inst-links))] 505 #:when (directory-exists? cp) 506 [collection (directory-list cp)] 507 #:unless (skip-collection-directory? collection) 508 #:when (directory-exists? (build-path cp collection))) 509 (cc! (list collection) 510 #:path (build-path cp collection))))) 511 ;; Now from `current-library-collection-links' for user-specific 512 ;; links: 513 (when (make-user) 514 (define info-root (find-user-share-dir)) 515 (define info-path (build-path info-root "info-cache.rktd")) 516 (define (cc! col #:path path) 517 (collection-cc! col 518 #:path path 519 #:info-root info-root 520 #:info-path info-path 521 #:info-path-mode 'abs-in-relative 522 #:omit-root 'dir)) 523 ;; A links spec in `current-library-collection-links' counts as 524 ;; user-specific when it's not in `make-links-files': 525 (for ([inst-links (in-list (current-library-collection-links))] 526 #:unless (and (path? inst-links) 527 (hash-ref main-links-files (simple-form-path inst-links) #f))) 528 (cond 529 [(not inst-links) ; covered by `current-library-collection-paths' 530 (void)] 531 [(path? inst-links) 532 (for ([c+p (in-list (links #:file inst-links #:with-path? #t))]) 533 (cc! (list (string->path (car c+p))) 534 #:path (cdr c+p))) 535 (for ([cp (in-list (links #:file inst-links #:root? #t))] 536 #:when (directory-exists? cp) 537 [collection (directory-list cp)] 538 #:unless (skip-collection-directory? collection) 539 #:when (directory-exists? (build-path cp collection))) 540 (cc! (list collection) #:path (build-path cp collection)))] 541 [else ; must be a hash table that simulates a links file: 542 (for* ([(coll-sym dir-list) (in-hash inst-links)] 543 [dir (in-list dir-list)]) 544 (cond 545 [coll-sym 546 ;; A single collection 547 (cc! (map string->path (string-split (symbol->string coll-sym) "/")) #:path dir)] 548 [(directory-exists? dir) 549 ;; A directory that holds collections: 550 (for ([collection (directory-list dir)] 551 #:unless (skip-collection-directory? collection) 552 #:when (directory-exists? (build-path dir collection))) 553 (cc! (list collection) #:path (build-path dir collection)))]))]))) 554 555 ;; `all-collections' lists all top-level collections (not from Planet): 556 (define all-collections 557 (apply append (hash-map collection-ccs-table (lambda (k v) v)))) 558 559 ;; Close over sub-collections 560 (define (collection-closure collections-to-compile make-subs) 561 (define (get-subs cc) 562 (define info (cc-info cc)) 563 (define ccp (cc-path cc)) 564 ;; note: omit can be 'all, if this happens then this collection 565 ;; should not have been included, but we might jump in if a 566 ;; command-line argument specified a coll/subcoll 567 (define omit (omitted-paths ccp getinfo/log-failure (cc-omit-root cc))) 568 (define subs (if (eq? 'all omit) 569 '() 570 (filter (lambda (p) 571 (and (directory-exists? (build-path ccp p)) 572 (not (member p omit)))) 573 (directory-list ccp)))) 574 (filter values (make-subs cc subs))) 575 (filter values 576 (let loop ([l collections-to-compile]) 577 (append-map (lambda (cc) (cons cc (loop (get-subs cc)))) l)))) 578 579 (define (collection-tree-map collections-to-compile has-module-suffix?) 580 (define (build-collection-tree cc) 581 (define (make-child-cc parent-cc name) 582 (collection-cc! (append (cc-collection parent-cc) (list name)) 583 #:parent parent-cc 584 #:path (build-path (cc-path parent-cc) name) 585 #:info-root (cc-info-root cc) 586 #:info-path (cc-info-path cc) 587 #:info-path-mode (cc-info-path-mode cc) 588 #:omit-root (cc-omit-root cc) 589 #:main? (cc-main? cc))) 590 (define info (cc-info cc)) 591 (define ccp (cc-path cc)) 592 ;; note: omit can be 'all, if this happens then this collection 593 ;; should not have been included, but we might jump in if a 594 ;; command-line argument specified a coll/subcoll 595 (define omit (let ([omit (omitted-paths ccp getinfo/log-failure (cc-omit-root cc))]) 596 (if (eq? omit 'all) 597 'all 598 (append 599 (if make-docs? 600 null 601 (list (string->path "scribblings"))) 602 omit)))) 603 (define-values [dirs files] 604 (if (eq? 'all omit) 605 (values null null) 606 (partition (lambda (x) (directory-exists? (build-path ccp x))) 607 (filter (lambda (p) (not (member p omit))) 608 (directory-list ccp))))) 609 (define children-ccs 610 (map build-collection-tree 611 (filter-map (lambda (x) (make-child-cc cc x)) dirs))) 612 (define srcs 613 (append 614 (filter has-module-suffix? files) 615 (if (and make-docs? 616 (not (eq? omit 'all))) 617 (filter (lambda (p) (not (member p omit))) 618 (map (lambda (s) (if (string? s) (string->path s) s)) 619 (map car 620 (let ([v (call-info info 'scribblings (lambda () null) void)]) 621 ;; Ignore ill-formed 'scribblings entries at this level: 622 (if (list? v) 623 (for/list ([i (in-list v)] 624 #:when (and (pair? i) 625 (string? (car i)))) 626 i) 627 null))))) 628 null) 629 (map (lambda (s) (if (string? s) (string->path s) s)) 630 (call-info info 'compile-include-files (lambda () null) void)))) 631 (list cc srcs children-ccs)) 632 (map build-collection-tree collections-to-compile)) 633 634 (define (plt-collection-closure collections-to-compile) 635 (define (make-children-ccs cc children) 636 (map (lambda (child) 637 (collection-cc! (append (cc-collection cc) (list child)) 638 #:parent cc 639 #:path (build-path (cc-path cc) child) 640 #:info-root (cc-info-root cc) 641 #:info-path (cc-info-path cc) 642 #:info-path-mode (cc-info-path-mode cc) 643 #:omit-root (cc-omit-root cc) 644 #:main? (cc-main? cc))) 645 children)) 646 (collection-closure collections-to-compile make-children-ccs)) 647 648 (define (lookup-collection-closure collections-to-compile) 649 (define ht (make-hash)) 650 (for ([cc (in-list collections-to-compile)]) 651 (hash-set! ht cc #t)) 652 (define (lookup-children-ccs! cc children) 653 (apply 654 append 655 (for/list ([child (in-list children)]) 656 (for/list ([cc (in-list (collection->ccs (append (cc-collection cc) (list child))))] 657 #:unless (hash-ref ht cc #f)) 658 (hash-set! ht cc #t) 659 cc)))) 660 (collection-closure collections-to-compile lookup-children-ccs!) 661 (for/list ([v (in-hash-keys ht)]) v)) 662 663 (define all-collections-closure (plt-collection-closure all-collections)) 664 665 (define (check-against-all given-ccs nothing-else-to-do?) 666 (when (and (null? given-ccs) 667 nothing-else-to-do? 668 (not (make-tidy))) 669 (setup-printf #f "nothing to do") 670 (exit 0)) 671 (define (cc->name cc) 672 (string-join (map path->string (cc-collection cc)) "/")) 673 (define (cc->cc+name+id cc) 674 (list cc (cc->name cc) (file-or-directory-identity (cc-path cc)))) 675 (define all-ccs+names+ids 676 (map cc->cc+name+id all-collections-closure)) 677 ;; given collections 678 (define given-ccs+names+ids (map cc->cc+name+id given-ccs)) 679 ;; descendants of given collections 680 (define descendants-names 681 (remove-duplicates 682 (append-map 683 (lambda (cc) 684 (map cc->name (remq cc (lookup-collection-closure (list cc))))) 685 given-ccs))) 686 ;; given collections without duplicates and without ones that are already 687 ;; descendants 688 (define given*-ccs+names+ids 689 (remove-duplicates 690 (filter (lambda (cc+name+id) 691 (not (member (cadr cc+name+id) descendants-names))) 692 given-ccs+names+ids) 693 (lambda (x y) 694 (and (equal? (cadr x) (cadr y)) 695 (equal? (cc-path (car x)) (cc-path (car y))))))) 696 ;; check that there are no bad duplicates in the given list 697 (for ([given-cc+name+id (in-list given*-ccs+names+ids)]) 698 (define bad 699 (ormap (lambda (cc+name+id) 700 (and (not (equal? (cadr cc+name+id) (cadr given-cc+name+id))) 701 (equal? (caddr cc+name+id) (caddr given-cc+name+id)) 702 (cadr cc+name+id))) 703 all-ccs+names+ids)) 704 (when bad 705 (error name-sym 706 "given collection path: \"~a\" refers to the same directory as another given collection path, \"~a\"" 707 (cadr given-cc+name+id) bad))) 708 (map car given*-ccs+names+ids)) 709 710 (define (sort-collections ccs) 711 (sort ccs string<? #:key cc-name)) 712 713 (define (sort-collections-tree ccs) 714 (sort ccs string<? #:key (lambda (x) (cc-name (first x))))) 715 716 (define planet-collects 717 (if (make-planet) 718 (filter-map (lambda (spec) (apply planet-cc! spec)) 719 (if no-specific-collections? 720 (get-all-planet-packages) 721 (filter-map planet-spec->planet-list 722 x-specific-planet-dirs))) 723 null)) 724 725 (define all-top-level-plt-collects 726 (if no-specific-collections? 727 all-collections 728 (check-against-all 729 (append-map 730 (lambda (c) 731 (define sc (map (lambda (s) (if (path? s) (path->string s) s)) 732 c)) 733 (define elems 734 (append-map (lambda (s) (map string->path (regexp-split #rx"/" s))) 735 sc)) 736 (define ccs (collection->ccs elems)) 737 (when (null? ccs) 738 ;; let `collection-path' complain about the name, if that's the problem: 739 (with-handlers ([exn? (compose1 raise-user-error exn-message)]) 740 (apply collection-path elems)) 741 ;; otherwise, it's probably a collection with nothing to compile; 742 ;; spell the name 743 (setup-printf "warning" 744 "nothing to compile in a given collection path: \"~a\"" 745 (string-join sc "/"))) 746 ccs) 747 x-specific-collections) 748 (null? planet-collects)))) 749 750 (define top-level-plt-collects 751 (if (avoid-main-installation) 752 (filter (lambda (cc) (not (cc-main? cc))) 753 all-top-level-plt-collects) 754 all-top-level-plt-collects)) 755 756 (define planet-dirs-to-compile 757 (sort-collections 758 (collection-closure 759 planet-collects 760 (lambda (cc subs) 761 (map (lambda (p) (planet-cc->sub-cc cc (list (path->bytes p)))) 762 subs))))) 763 764 (define (combine-collections top-level-plt-collects) 765 (append 766 (sort-collections (lookup-collection-closure top-level-plt-collects)) 767 planet-dirs-to-compile)) 768 769 (define ccs-to-compile 770 (combine-collections top-level-plt-collects)) 771 772 (define ccs-to-call-installers 773 (if (avoid-main-installation) 774 ;; Although we mostly avoid the main installation, we'll 775 ;; need to call main-installaiton launchers in case they 776 ;; support being called to perform only user-specific 777 ;; actions. 778 (combine-collections all-top-level-plt-collects) 779 ccs-to-compile)) 780 781 (define ccs-to-make-launchers 782 (if (or (find-addon-tethered-console-bin-dir) 783 (find-addon-tethered-gui-bin-dir)) 784 ccs-to-call-installers 785 ccs-to-compile)) 786 787 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 788 ;; Clean ;; 789 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 790 791 (define (delete-file/record-dependency path dependencies) 792 (when (path-has-extension? path #".dep") 793 (define deps 794 (with-handlers ([exn:fail? (lambda (x) null)]) 795 (with-input-from-file path read))) 796 (when (and (pair? deps) (list? deps)) 797 (for ([s (in-list (cdddr deps))]) 798 (unless (external-dep? s) 799 (define new-s (dep->path s)) 800 (when (path-string? new-s) (hash-set! dependencies new-s #t)))))) 801 (delete-file path)) 802 803 (define (delete-files-in-directory path printout dependencies) 804 (for ([end-path (directory-list path)]) 805 (let ([path (build-path path end-path)]) 806 (cond [(directory-exists? path) 807 (void)] 808 [(file-exists? path) 809 (printout) 810 (delete-file/record-dependency path dependencies)] 811 [else (error 'delete-files-in-directory 812 "encountered ~a, neither a file nor a directory" 813 path)])))) 814 815 (define (assume-virtual-sources? cc) 816 (or ((cc-info cc) 'assume-virtual-sources (lambda () #f)) 817 (let ([cc (cc-parent-cc cc)]) 818 (and cc 819 (assume-virtual-sources? cc))))) 820 821 (define (clean-collection cc dependencies) 822 (begin-record-error cc "cleaning" 823 (define info (cc-info cc)) 824 (define paths 825 (call-info 826 info 827 'clean 828 (lambda () 829 (if (assume-virtual-sources? cc) 830 null 831 (list mode-dir 832 (build-path mode-dir "native") 833 (build-path mode-dir "native" (system-library-subpath))))) 834 (lambda (x) 835 (unless (list-of path-string? x) 836 (error name-sym 837 "expected a list of path strings for 'clean, got: ~s" 838 x))))) 839 (define printed? #f) 840 (define (print-message) 841 (unless printed? 842 (set! printed? #t) 843 (setup-printf "deleting" "in ~a" 844 (path->relative-string/setup (cc-path cc) 845 #:cache pkg-path-cache)))) 846 (for ([path paths]) 847 (define full-path (build-path (cc-path cc) path)) 848 (when (or (file-exists? full-path) (directory-exists? full-path)) 849 (let loop ([path (find-relative-path (simple-form-path (cc-path cc)) 850 (simple-form-path full-path))]) 851 (define-values [base name dir?] (split-path path)) 852 (cond 853 [(path? base) 854 (loop base)] 855 [(eq? base 'relative) 856 (when (eq? name 'up) 857 (error 'clean 858 "attempted to clean files in ~s which is not a subdirectory of ~s" 859 full-path 860 (cc-path cc)))] 861 [else 862 (error 'clean 863 "attempted to clean files in ~s which is not a subdirectory of ~s" 864 full-path 865 (cc-path cc))])) 866 (cond [(directory-exists? full-path) 867 (delete-files-in-directory full-path print-message dependencies)] 868 [(file-exists? full-path) 869 (delete-file/record-dependency full-path dependencies) 870 (print-message)] 871 [else (void)]))))) 872 873 (define (clean-step) 874 (setup-printf #f (add-time "--- cleaning collections ---")) 875 (define dependencies (make-hash)) 876 ;; Main deletion: 877 (for ([cc ccs-to-compile]) (clean-collection cc dependencies)) 878 ;; Unless specific collections were named, also delete .zos for 879 ;; referenced modules and delete info-domain cache 880 (when no-specific-collections? 881 (unless (or (avoid-main-installation) 882 (not (make-user))) 883 (setup-printf #f "checking dependencies") 884 (let loop ([old-dependencies dependencies]) 885 (define dependencies (make-hash)) 886 (define did-something? #f) 887 (hash-for-each 888 old-dependencies 889 (lambda (file _) 890 (define-values [dir name dir?] (split-path file)) 891 (define zo (build-path dir mode-dir (path-add-extension name #".zo"))) 892 (define dep (build-path dir mode-dir (path-add-extension name #".dep"))) 893 (when (and (file-exists? dep) (file-exists? zo)) 894 (set! did-something? #t) 895 (setup-printf "deleting" "~a" (path->relative-string/setup zo #:cache pkg-path-cache)) 896 (delete-file/record-dependency zo dependencies) 897 (delete-file/record-dependency dep dependencies)))) 898 (when did-something? (loop dependencies)))) 899 (when (make-info-domain) 900 (setup-printf #f "clearing info-domain caches") 901 (define (check-one-info-domain fn) 902 (when (file-exists? fn) 903 (with-handlers ([exn:fail:filesystem? (warning-handler (void))]) 904 (with-output-to-file fn void #:exists 'truncate/replace)))) 905 (for ([p (current-library-collection-paths)]) 906 (unless (or (and (avoid-main-installation) (hash-ref main-collects-dirs p #f)) 907 (and (not (make-user)) (not (hash-ref main-collects-dirs p #f)))) 908 (check-one-info-domain (build-path p "info-domain" "compiled" "cache.rktd")))) 909 (unless (avoid-main-installation) 910 (check-one-info-domain (build-path (find-share-dir) "info-cache.rktd"))) 911 (when (make-user) 912 (check-one-info-domain (build-path (find-user-share-dir) "info-cache.rktd")))) 913 (when make-docs? 914 (setup-printf #f "deleting documentation databases") 915 (for ([d (in-list (append (if (avoid-main-installation) 916 null 917 (list (find-user-doc-dir))) 918 (if (make-user) 919 (list (find-user-doc-dir)) 920 null)))]) 921 (when d 922 (define f (build-path d "docindex.sqlite")) 923 (when (file-exists? f) 924 (delete-file f))))))) 925 926 (define (do-install-part part) 927 (when (if (eq? part 'post) (call-post-install) (call-install)) 928 (setup-printf #f (add-time 929 (format "--- ~ainstalling collections ---" 930 (case part 931 [(pre) "pre-"] 932 [(general) ""] 933 [(post) "post-"])))) 934 (for ([cc ccs-to-call-installers]) 935 (let/ec k 936 (begin-record-error cc (case part 937 [(pre) "early install"] 938 [(general) "general install"] 939 [(post) "post install"]) 940 (define fn 941 (call-info (cc-info cc) 942 (case part 943 [(pre) 'pre-install-collection] 944 [(general) 'install-collection] 945 [(post) 'post-install-collection]) 946 (lambda () (k #f)) 947 (lambda (v) 948 (unless (relative-path-string? v) 949 (error "result is not a relative path string: " v)) 950 (define p (build-path (cc-path cc) v)) 951 (unless (or (file-exists? p) 952 (bytecode-file-exists? p)) 953 (error "installer file does not exist: " p))))) 954 (define installer 955 (with-handlers ([exn:fail? 956 (lambda (exn) 957 (error name-sym 958 "error loading installer: ~a" 959 (exn->string exn)))]) 960 (define base-installer 961 (dynamic-require (build-path (cc-path cc) fn) 962 (case part 963 [(pre) 'pre-installer] 964 [(general) 'installer] 965 [(post) 'post-installer]))) 966 (if (and (cc-main? cc) 967 (avoid-main-installation) 968 (not (procedure-arity-includes? base-installer 4))) 969 #f 970 base-installer))) 971 (when installer 972 (setup-printf (format "~ainstalling" 973 (case part 974 [(pre) "pre-"] 975 [(post) "post-"] 976 [else ""])) 977 "~a" 978 (cc-name cc)) 979 (define dir (build-path main-collects-dir 'up)) 980 (cond 981 [(procedure-arity-includes? installer 4) 982 (installer dir (cc-path cc) (not (cc-main? cc)) (and (cc-main? cc) 983 (avoid-main-installation)))] 984 [(procedure-arity-includes? installer 3) 985 (installer dir (cc-path cc) (not (cc-main? cc)))] 986 [(procedure-arity-includes? installer 2) 987 (installer dir (cc-path cc))] 988 [else 989 (installer dir)]))))))) 990 991 (define (bytecode-file-exists? p) 992 (parameterize ([use-compiled-file-paths (list mode-dir)]) 993 (define zo (get-compilation-bytecode-file p)) 994 (file-exists? zo))) 995 996 (define (this-platform? info) 997 (define sys 998 (call-info info 999 'install-platform 1000 (lambda () #rx"") 1001 (lambda (v) 1002 (unless (or (regexp? v) 1003 (string? v) 1004 (symbol? v)) 1005 (error "entry is not regexp, string, or symbol:" v))))) 1006 (matching-platform? sys #:cross? #t)) 1007 1008 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1009 ;; Make zo ;; 1010 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1011 1012 (define (control-io print-verbose thunk) 1013 (if (make-verbose) 1014 (thunk) 1015 (let* ([oop (current-output-port)] 1016 [dir-table (make-hash)] 1017 [doing-path (lambda (path) 1018 (unless (verbose) 1019 (let ([path (path-only path)]) 1020 (unless (hash-ref dir-table path #f) 1021 (hash-set! dir-table path #t) 1022 (print-verbose oop path)))))]) 1023 (parameterize ([current-output-port (if (verbose) (current-output-port) (open-output-nowhere))] 1024 [compile-notify-handler doing-path]) 1025 (thunk))))) 1026 1027 (define (clean-cc cc) 1028 ;; Clean up bad .zos: 1029 (unless (assume-virtual-sources? cc) 1030 (define dir (cc-path cc)) 1031 (define info (cc-info cc)) 1032 (define roots 1033 ;; If there's more than one relative root, then there will 1034 ;; be multiple ways to get to a ".zo" file, and our strategy 1035 ;; below will fail. Give up on checking relative roots in 1036 ;; that case. 1037 (let ([roots (current-compiled-file-roots)]) 1038 (if (1 . < . (for/sum ([r (in-list roots)]) 1039 (if (or (eq? r 'same) 1040 (relative-path? r)) 1041 1 1042 0))) 1043 ;; give up on relative: 1044 (filter (lambda (p) (and (path? p) (absolute-path? p))) 1045 roots) 1046 ;; all roots ok: 1047 roots))) 1048 ;; Try each compile-file root, but preserve the list of allowed 1049 ;; bytecode files after it's computed the first time. 1050 (for/fold ([ok-zo-files #f]) ([root (in-list roots)]) 1051 (define c (cond 1052 [(eq? root 'same) (build-path dir mode-dir)] 1053 [(relative-path? root) 1054 (build-path dir root mode-dir)] 1055 [else 1056 (reroot-path (build-path dir mode-dir) root)])) 1057 (cond 1058 [(directory-exists? c) 1059 ;; Directory for compiled files exist... 1060 (let ([ok-zo-files 1061 (or ok-zo-files 1062 ;; Build table of allowed ".zo" file names that can 1063 ;; appear in a "compiled" directory: 1064 (make-immutable-hash 1065 (map (lambda (p) 1066 (cons (path-add-extension p #".zo") #t)) 1067 (append (directory-list dir) 1068 (info 'virtual-sources (lambda () null))))))]) 1069 ;; Check each file in `c` to see whether it can stay: 1070 (for ([p (directory-list c)]) 1071 (when (and (regexp-match? #rx#".[.](zo|dep)$" (path-element->bytes p)) 1072 (not (hash-ref ok-zo-files (path-replace-extension p #".zo") #f))) 1073 (setup-fprintf (current-error-port) #f " deleting ~a" (build-path c p)) 1074 (delete-file (build-path c p)))) 1075 ok-zo-files)] 1076 [else ok-zo-files])))) 1077 1078 (define (with-specified-mode thunk) 1079 (if (not (compile-mode)) 1080 (thunk) 1081 ;; Use the indicated mode 1082 (let ([zo-compile 1083 (with-handlers ([exn:fail? 1084 (lambda (exn) 1085 (error name-sym 1086 "error loading compiler for mode ~s: ~a" 1087 (compile-mode) 1088 (exn->string exn)))]) 1089 (dynamic-require `(lib "zo-compile.rkt" ,(compile-mode)) 1090 'zo-compile))] 1091 [orig-kinds (use-compiled-file-paths)] 1092 [orig-compile (current-compile)] 1093 [orig-namespace (namespace-anchor->empty-namespace anchor)]) 1094 (parameterize ([current-namespace (make-base-empty-namespace)] 1095 [current-compile zo-compile] 1096 [use-compiled-file-paths (list mode-dir)] 1097 [current-compiler-dynamic-require-wrapper 1098 (lambda (thunk) 1099 (parameterize ([current-namespace orig-namespace] 1100 [use-compiled-file-paths orig-kinds] 1101 [current-compile orig-compile]) 1102 (thunk)))]) 1103 (thunk))))) 1104 1105 ;; We keep timestamp information for all files that we try to compile. 1106 ;; That's O(N) for an installation of size N, but the constant is small, 1107 ;; and it makes a do-nothing setup complete much faster. But set the 1108 ;; `PLT_SETUP_LIMIT_CACHE` environment variable to disable it. 1109 (define caching-managed-compile-zo (and (not limit-cross-collection-cache?) 1110 (make-caching-managed-compile-zo))) 1111 1112 (define (compile-cc cc gcs has-module-suffix?) 1113 (parameterize ([current-namespace (make-base-empty-namespace)]) 1114 (begin-record-error cc "making" 1115 (setup-printf "making" "~a" (cc-name cc)) 1116 (control-io 1117 (lambda (p where) 1118 (when gc-after-each-sequential? 1119 ;; trigger `(collect-garbage)` afterward, and again after next collection: 1120 (set! gcs 2)) 1121 (setup-fprintf p #f " in ~a" 1122 (path->relative-string/setup 1123 (path->complete-path where (cc-path cc)) 1124 #:cache pkg-path-cache))) 1125 (lambda () 1126 (define dir (cc-path cc)) 1127 (define info (cc-info cc)) 1128 (compile-directory-zos dir info 1129 #:verbose (verbose) 1130 #:has-module-suffix? has-module-suffix? 1131 #:omit-root (cc-omit-root cc) 1132 #:managed-compile-zo (or caching-managed-compile-zo 1133 (make-caching-managed-compile-zo)) 1134 #:skip-path (and (avoid-main-installation) main-collects-dir) 1135 #:skip-doc-sources? (not make-docs?)))))) 1136 (when post-collection-dms-args 1137 (collect-garbage) 1138 (apply dump-memory-stats post-collection-dms-args)) 1139 (if (eq? 0 gcs) 1140 0 1141 (begin (collect-garbage) (sub1 gcs)))) 1142 1143 ;; To avoid polluting the compilation with modules that are already loaded, 1144 ;; create a fresh namespace before calling this function. 1145 ;; To avoid keeping modules in memory across collections, pass 1146 ;; `make-base-namespace' as `get-namespace', otherwise use 1147 ;; `current-namespace' for `get-namespace'. 1148 (define (iterate-cct thunk cct) 1149 (let loop ([cct cct]) 1150 (map (lambda (x) (thunk (first x)) (loop (third x))) cct))) 1151 1152 (define (make-zo-step) 1153 (define (partition-cct name cct) 1154 (partition (lambda (x) (not (regexp-match? name (cc-name (car x))))) cct)) 1155 (define (move-to where names cct) 1156 (for/fold ([cct cct]) ([name (in-list (reverse names))]) 1157 (define-values [diff same] (partition-cct name cct)) 1158 (case where 1159 [(beginning) (append same diff)] 1160 [(end) (append diff same)]))) 1161 (define has-module-suffix? 1162 (let ([rx (get-module-suffix-regexp 1163 #:mode (cond 1164 [(make-user) 'preferred] 1165 [else 'no-user]) 1166 #:group 'libs 1167 #:namespace info-ns)]) 1168 (lambda (p) (regexp-match? rx p)))) 1169 (setup-printf #f (add-time "--- compiling collections ---")) 1170 (if ((parallel-workers) . > . 1) 1171 (begin 1172 (when (or no-specific-collections? 1173 (member "racket" x-specific-collections)) 1174 (for/fold ([gcs 0]) ([cc (in-list (collection->ccs (list (string->path "racket"))))]) 1175 (when (and (cc-main? cc) 1176 (member (cc-info-root cc) 1177 (current-library-collection-paths))) 1178 (compile-cc cc 0 has-module-suffix?)))) 1179 (with-specified-mode 1180 (lambda () 1181 (define cct 1182 (move-to 'beginning (list #rx"/compiler$" #rx"/raco$" #rx"/racket$" #rx"<pkgs>/images/") 1183 (move-to 'end (list #rx"<pkgs>/drracket") 1184 (sort-collections-tree 1185 (collection-tree-map top-level-plt-collects 1186 has-module-suffix?))))) 1187 (iterate-cct clean-cc cct) 1188 (parallel-compile (parallel-workers) setup-fprintf handle-error cct 1189 #:use-places? (parallel-use-places) 1190 #:options (append 1191 (if (not (current-compile-target-machine)) 1192 '(compile-any) 1193 '()) 1194 (if (managed-recompile-only) 1195 '(recompile-only) 1196 '()))) 1197 (for/fold ([gcs 0]) ([cc planet-dirs-to-compile]) 1198 (compile-cc cc gcs has-module-suffix?))))) 1199 (with-specified-mode 1200 (lambda () 1201 (for ([cc ccs-to-compile]) 1202 (clean-cc cc)) 1203 (for/fold ([gcs 0]) ([cc ccs-to-compile]) 1204 (compile-cc cc gcs has-module-suffix?)))))) 1205 1206 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1207 ;; Info-Domain Cache ;; 1208 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1209 1210 (define (make-info-domain-step) 1211 (setup-printf #f (add-time "--- updating info-domain tables ---")) 1212 ;; Each ht maps a collection root dir to an info-domain table. Even when 1213 ;; `collections-to-compile' is a subset of all collections, we only care 1214 ;; about those collections that exist in the same root as the ones in 1215 ;; `collections-to-compile'. 1216 (define ht (make-hash)) 1217 (define ht-orig (make-hash)) 1218 (define roots (make-hash)) 1219 (define (get-info-ht info-root info-path info-path-mode) 1220 (define-values (path->info-relative info-relative->path) 1221 (apply values 1222 (hash-ref roots 1223 info-root 1224 (lambda () 1225 (define-values [p-> ->p] 1226 (if info-root 1227 (make-relativize (lambda () info-root) 1228 'info 1229 'path->info-relative 1230 'info-relative->path) 1231 (values #f #f))) 1232 (hash-set! roots info-root (list p-> ->p)) 1233 (list p-> ->p))))) 1234 (hash-ref ht info-path 1235 (lambda () 1236 ;; No table for this root, yet. Build one. 1237 (define l 1238 (let ([p info-path]) 1239 (if (file-exists? p) 1240 (with-handlers ([exn:fail? (warning-handler null)]) 1241 (with-input-from-file p read)) 1242 null))) 1243 ;; Convert list to hash table. Include only well-formed 1244 ;; list elements, and only elements whose corresponding 1245 ;; collection exists. 1246 (define t (make-hash)) 1247 (define all-ok? #f) 1248 (when (list? l) 1249 (set! all-ok? #t) 1250 (for ([i l]) 1251 (match i 1252 [(list (and a (or (? bytes?) 1253 (list (or 'info 'lib) (? bytes?) ...) 1254 (list 'rel (or 'up (? bytes?)) ...))) 1255 (list (? symbol? b) ...) c (? integer? d) (? integer? e)) 1256 (define p 1257 (cond 1258 [(bytes? a) (bytes->path a)] 1259 [(and (pair? a) (eq? 'rel (car a))) 1260 (decode-relative-path a)] 1261 [else a])) 1262 (define (normalize-relative-encoding a p) 1263 (if (and (bytes? a) (relative-path? p)) 1264 ;; Convert to encoded form, since new entries will 1265 ;; use encoding to avoid path-convention problems 1266 ;; with cross-compilation: 1267 (encode-relative-path p) 1268 a)) 1269 ;; Check that the path is suitably absolute or relative: 1270 (define dir 1271 (case info-path-mode 1272 [(relative abs-in-relative) 1273 (or (and (list? p) 1274 (if (eq? (car p) 'info) 1275 (info-relative->path p) 1276 (main-lib-relative->path p))) 1277 ;; `c' must be `(lib ...)' 1278 (and (or (relative-path? p) 1279 ;; Keep a complete path only if it could not be 1280 ;; made relative: 1281 (and (complete-path? p) 1282 (complete-path? 1283 (find-relative-path info-root 1284 p 1285 #:more-than-root? #t)))) 1286 (list? c) 1287 (pair? c) 1288 (eq? 'lib (car c)) 1289 (pair? (cdr c)) 1290 (andmap string? (cdr c)) 1291 (let ([p (simplify-path (path->complete-path p info-root))]) 1292 (and 1293 ;; path must match some cc: 1294 (for/or ([cc (in-list all-collections-closure)]) 1295 (equal? p (cc-path cc))) 1296 p))))] 1297 [(abs) 1298 (and (complete-path? p) 1299 (match c 1300 [(list 'planet (? string? a) (? string? pk)) 1301 ;; Check that the package is installed and maps to `p`: 1302 (and (get-installed-package a pk d e) 1303 (let ([bp (resolve-planet-path 1304 `(planet "bogus.rkt" (,a ,pk ,d ,e)))]) 1305 (and (path? bp) 1306 (let-values ([(base name dir?) (split-path bp)]) 1307 (and (path? base) 1308 (equal? (path->directory-path p) 1309 (path->directory-path base)))))))] 1310 [_ 1311 #t]) 1312 p)])) 1313 (if (and dir 1314 (let ([omit-root 1315 (if (path? p) 1316 ;; absolute path => need a root for checking omits; 1317 ;; for a collection path of length N, go up N-1 dirs: 1318 (simplify-path (apply build-path p (for/list ([i (cddr c)]) 'up)) #f) 1319 ;; relative path => no root needed for checking omits: 1320 #f)]) 1321 (and (directory-exists? dir) 1322 (not (eq? 'all (omitted-paths dir getinfo/log-failure omit-root))))) 1323 (or (file-exists? (build-path dir "info.rkt")) 1324 (file-exists? (build-path dir "info.ss")))) 1325 (hash-set! t (normalize-relative-encoding a p) (list b c d e)) 1326 (begin (when (verbose) (printf " drop entry: ~s\n" i)) 1327 (set! all-ok? #f)))] 1328 [_ (when (verbose) (printf " bad entry: ~s\n" i)) 1329 (set! all-ok? #f)]))) 1330 ;; Record the table loaded for this collection root in the 1331 ;; all-roots table: 1332 (hash-set! ht info-path t) 1333 ;; If anything in the "cache.rktd" file was bad, then claim 1334 ;; that the old table was empty, so that we definitely write 1335 ;; the new table. 1336 (hash-set! ht-orig info-path 1337 (and all-ok? (hash-copy t))) 1338 t))) 1339 ;; process all collections: 1340 (for ([cc ccs-to-compile]) 1341 (define domain 1342 (with-handlers ([exn:fail? (lambda (x) (lambda () null))]) 1343 (parameterize ([current-namespace info-ns]) 1344 (dynamic-require (build-path (cc-path cc) "info.rkt") 1345 '#%info-domain)))) 1346 ;; Get the table for this cc's info-domain cache: 1347 (define t (get-info-ht (cc-info-root cc) 1348 (cc-info-path cc) 1349 (cc-info-path-mode cc))) 1350 (define-values (path->info-relative info-relative->path) 1351 ;; Look up value that was forced by by `get-info-ht': 1352 (apply values (hash-ref roots (cc-info-root cc)))) 1353 ;; Add this collection's info to the table, replacing any information 1354 ;; already there, if the collection has an "info.ss" file: 1355 (when (or (file-exists? (build-path (cc-path cc) "info.rkt")) 1356 (file-exists? (build-path (cc-path cc) "info.ss"))) 1357 (hash-set! t 1358 (case (cc-info-path-mode cc) 1359 [(relative) 1360 ;; Use relative path: 1361 (path->info-relative (apply build-path 1362 (cc-info-root cc) 1363 (cc-collection cc)))] 1364 [(abs-in-relative) 1365 ;; Try relative to `lib': 1366 (let ([p (path->main-lib-relative (cc-path cc))]) 1367 (if (path? p) 1368 ;; Fall back to relative (with ".."s) to info root: 1369 (let ([rp (find-relative-path (cc-info-root cc) 1370 p 1371 #:more-than-root? #t)]) 1372 (if (relative-path? rp) 1373 (encode-relative-path rp) 1374 (path->bytes rp))) 1375 p))] 1376 [else (path->bytes (cc-path cc))]) 1377 (cons (domain) (cc-shadowing-policy cc))))) 1378 ;; In "tidy" mode, make sure we check each "cache.rktd": 1379 (when (or (make-tidy) 1380 no-specific-collections?) 1381 (for ([c (in-list (current-library-collection-paths))]) 1382 (when (and (directory-exists? c) 1383 (not (and (avoid-main-installation) 1384 (hash-ref main-collects-dirs c #f)))) 1385 (define info-path (build-path c "info-domain" "compiled" "cache.rktd")) 1386 (when (file-exists? info-path) 1387 (get-info-ht c info-path 'relative)))) 1388 (unless (avoid-main-installation) 1389 (define info-root (find-share-dir)) 1390 (define info-path (build-path info-root "info-cache.rktd")) 1391 (when (file-exists? info-path) 1392 (get-info-ht info-root info-path 'abs-in-relative))) 1393 (when (make-user) 1394 (define info-root (find-user-share-dir)) 1395 (define info-path (build-path info-root "info-cache.rktd")) 1396 (when (file-exists? info-path) 1397 (get-info-ht info-root info-path 'abs-in-relative)) 1398 (define planet-info-path (get-planet-cache-path)) 1399 (when (file-exists? planet-info-path) 1400 (get-info-ht #f planet-info-path 'abs)))) 1401 ;; Write out each collection-root-specific table to a "cache.rktd" file: 1402 (hash-for-each ht 1403 (lambda (info-path ht) 1404 (unless (equal? ht (hash-ref ht-orig info-path)) 1405 (define-values [base name dir?] (split-path info-path)) 1406 (make-directory* base) 1407 (define p info-path) 1408 (setup-printf "updating" "~a" (path->relative-string/setup 1409 p 1410 #:cache pkg-path-cache)) 1411 (when (verbose) 1412 (define ht0 (hash-ref ht-orig info-path)) 1413 (when ht0 1414 (for ([(k v) (in-hash ht)]) 1415 (define v2 (hash-ref ht0 k #f)) 1416 (unless (equal? v v2) 1417 (printf " ~s -> ~s\n instead of ~s\n" k v v2))) 1418 (for ([(k v) (in-hash ht0)]) 1419 (unless (hash-ref ht k #f) 1420 (printf " ~s removed\n" k))))) 1421 (with-handlers ([exn:fail? (warning-handler (void))]) 1422 (with-output-to-file p #:exists 'truncate/replace 1423 (lambda () 1424 (write (hash-map ht cons)) 1425 (newline))))))) 1426 ;; Flush cached state in the current namespace: 1427 (reset-relevant-directories-state!)) 1428 1429 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1430 ;; Docs ;; 1431 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1432 1433 (define (scr:call name . xs) 1434 (parameterize ([current-namespace 1435 (namespace-anchor->empty-namespace anchor)]) 1436 (apply (dynamic-require 'setup/scribble name) xs))) 1437 1438 (define (set-doc:verbose) 1439 (scr:call 'verbose (verbose))) 1440 1441 (define (doc:setup-scribblings latex-dest auto-start-doc?) 1442 (scr:call 'setup-scribblings 1443 (parallel-workers) 1444 (parallel-use-places) 1445 name-str 1446 (if no-specific-collections? #f (map cc-path ccs-to-compile)) 1447 latex-dest auto-start-doc? (make-user) (force-user-docs) 1448 (make-tidy) (avoid-main-installation) (sync-docs-only) 1449 (lambda (what go alt) (record-error what "building docs" go alt)) 1450 setup-printf 1451 gc-after-each-sequential?)) 1452 1453 (define (make-docs-step) 1454 (setup-printf #f (add-time "--- building documentation ---")) 1455 (set-doc:verbose) 1456 (with-handlers ([exn:fail? 1457 (lambda (exn) 1458 (set! exit-code 1) 1459 (setup-printf #f "docs failure: ~a" (exn->string exn)))]) 1460 (define auto-start-doc? 1461 (or (and (not (null? (archives))) 1462 (archive-implies-reindex)) 1463 (make-doc-index))) 1464 (doc:setup-scribblings #f auto-start-doc?))) 1465 1466 (define (doc-pdf-dest-step) 1467 (setup-printf #f (add-time "--- building PDF documentation (via pdflatex) ---")) 1468 (define dest-dir (path->complete-path (doc-pdf-dest))) 1469 (unless (directory-exists? dest-dir) 1470 (make-directory dest-dir)) 1471 (define tmp-dir 1472 (build-path (find-system-path 'temp-dir) 1473 (format "pltpdfdoc~a" (current-seconds)))) 1474 (dynamic-wind 1475 void 1476 (lambda () 1477 (make-directory tmp-dir) 1478 (set-doc:verbose) 1479 (doc:setup-scribblings tmp-dir #f) 1480 (parameterize ([current-directory tmp-dir]) 1481 (for ([f (directory-list)] 1482 #:when (path-has-extension? f #".tex")) 1483 (define pdf (scr:call 'run-pdflatex f 1484 (lambda (fmt . xs) 1485 (apply setup-printf #f fmt xs)))) 1486 (define target (build-path dest-dir pdf)) 1487 (when (file-exists? target) (delete-file target)) 1488 (copy-file pdf target)))) 1489 (lambda () 1490 (when (directory-exists? tmp-dir) 1491 (delete-directory/files tmp-dir))))) 1492 1493 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1494 ;; Make Launchers ;; 1495 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1496 1497 (define (make-launchers-step) 1498 (setup-printf #f (add-time "--- creating launchers ---")) 1499 (define (name-list l) 1500 (unless (list-of relative-path-string? l) 1501 (error "result is not a list of relative path strings:" l))) 1502 (define (flags-list l) 1503 (unless (list-of (list-of string?) l) 1504 (error "result is not a list of strings:" l))) 1505 (define ((or-f f) x) (when x (f x))) 1506 (define created-launchers (make-hash)) 1507 (for ([cc ccs-to-make-launchers]) 1508 (begin-record-error cc "launcher setup" 1509 (define info (cc-info cc)) 1510 (define (make-launcher kind 1511 launcher-names 1512 launcher-libraries 1513 launcher-flags 1514 program-launcher-path 1515 make-launcher 1516 up-to-date?) 1517 (define mzlns 1518 (call-info info launcher-names (lambda () null) name-list)) 1519 (define mzlls 1520 (call-info info launcher-libraries (lambda () #f) (or-f name-list))) 1521 (define mzlfs 1522 (call-info info launcher-flags (lambda () #f) (or-f flags-list))) 1523 (cond 1524 [(null? mzlns) (void)] 1525 [(not (or mzlls mzlfs)) 1526 (unless (null? mzlns) 1527 (setup-printf 1528 "WARNING" 1529 "~s launcher name list ~s has no matching library/flags lists" 1530 kind mzlns))] 1531 [(and (or (not mzlls) (= (length mzlns) (length mzlls))) 1532 (or (not mzlfs) (= (length mzlns) (length mzlfs)))) 1533 (for ([mzln (in-list mzlns)] 1534 [mzll (in-list (or mzlls (map (lambda (_) #f) mzlns)))] 1535 [mzlf (in-list (or mzlfs (map (lambda (_) #f) mzlns)))]) 1536 (define p (program-launcher-path mzln #:user? (not (cc-main? cc)))) 1537 (define addon-p (and (if (eq? kind 'gui) 1538 (find-addon-tethered-gui-bin-dir) 1539 (find-addon-tethered-console-bin-dir)) 1540 (program-launcher-path mzln #:user? #t #:tethered? #t))) 1541 (define config-p (and (cc-main? cc) 1542 (if (eq? kind 'gui) 1543 (find-config-tethered-gui-bin-dir) 1544 (find-config-tethered-console-bin-dir)) 1545 (program-launcher-path mzln #:user? #f #:tethered? #t))) 1546 (define receipt-path 1547 (build-path (if (cc-main? cc) 1548 (find-lib-dir) 1549 (find-user-lib-dir)) 1550 "launchers.rktd")) 1551 (define (prep-dir p) 1552 (define dir (path-only p)) 1553 (make-directory* dir)) 1554 (define skip-non-addon? (and (cc-main? cc) 1555 (avoid-main-installation))) 1556 (define skip-untethered-main? (and (cc-main? cc) 1557 (or 1558 ;; Don't create untethered if we're creating tethered 1559 config-p 1560 ;; If the executable already exists in a search 1561 ;; directory other than the one for `p`, no need 1562 ;; to write `p` after all 1563 (for/or ([dir (in-list (if (and (eq? kind 'gui) 1564 (not (script-variant? 1565 (current-launcher-variant)))) 1566 (get-gui-bin-extra-search-dirs) 1567 (get-console-bin-extra-search-dirs)))]) 1568 (define-values (base name dir?) (split-path p)) 1569 (define p2 (build-path dir name)) 1570 (or (file-exists? p2) 1571 (directory-exists? p2)))))) 1572 (unless skip-non-addon? 1573 (prep-dir receipt-path) 1574 (unless skip-untethered-main? 1575 (prep-dir p)) 1576 (when config-p 1577 (prep-dir config-p))) 1578 (when addon-p 1579 (prep-dir addon-p)) 1580 (hash-set! created-launchers 1581 (record-launcher receipt-path mzln kind (current-launcher-variant) 1582 (cc-collection cc) (cc-path cc)) 1583 #t) 1584 (define (create p user? tethered?) 1585 (define aux 1586 (append 1587 `((exe-name . ,mzln) 1588 (relative? . ,(and (cc-main? cc) 1589 (not tethered?) 1590 (not (get-absolute-installation?)))) 1591 (install-mode . ,(if tethered? 1592 (if user? 'addon-tethered 'config-tethered) 1593 (if (cc-main? cc) 'main 'user))) 1594 ,@(build-aux-from-path 1595 (build-path (cc-path cc) 1596 (path-replace-extension (or mzll mzln) #"")))))) 1597 (unless (up-to-date? p aux) 1598 (setup-printf 1599 "launcher" 1600 "~a~a" 1601 (case kind 1602 [(gui) (path->relative-string/gui-bin p)] 1603 [(console) (path->relative-string/console-bin p)] 1604 [else (error 'make-launcher "internal error (~s)" kind)]) 1605 (let ([v (current-launcher-variant)]) 1606 (if (eq? v (cross-system-type 'gc)) "" (format " [~a]" v)))) 1607 (make-launcher 1608 #:tether-mode (if tethered? 1609 (if user? 1610 'addon 1611 'config) 1612 #f) 1613 (append 1614 (or mzlf 1615 (if (cc-collection cc) 1616 (list "-l-" (string-append 1617 (string-append* 1618 (map (lambda (s) (format "~a/" s)) 1619 (cc-collection cc))) 1620 mzll)) 1621 (list "-t-" (path->string (build-path (cc-path cc) mzll)))))) 1622 p 1623 aux))) 1624 (unless skip-non-addon? 1625 (unless skip-untethered-main? 1626 (create p (not (cc-main? cc)) #f)) 1627 (when config-p 1628 (create config-p #f #t))) 1629 (when addon-p 1630 (create addon-p #t #t)))] 1631 [else 1632 (define fault 1633 (if (or (not mzlls) (= (length mzlns) (length mzlls))) 'f 'l)) 1634 (setup-printf 1635 "WARNING" 1636 "~s launcher name list ~s doesn't match ~a list; ~s" 1637 kind mzlns 1638 (if (eq? 'l fault) "library" "flags") 1639 (if (eq? fault 'l) mzlls mzlfs))])) 1640 (for ([variant (available-gracket-variants)]) 1641 (parameterize ([current-launcher-variant variant]) 1642 (make-launcher 'gui 1643 'gracket-launcher-names 1644 'gracket-launcher-libraries 1645 'gracket-launcher-flags 1646 gracket-program-launcher-path 1647 make-gracket-launcher 1648 gracket-launcher-up-to-date?) 1649 (make-launcher 'gui 1650 'mred-launcher-names 1651 'mred-launcher-libraries 1652 'mred-launcher-flags 1653 mred-program-launcher-path 1654 make-mred-launcher 1655 mred-launcher-up-to-date?))) 1656 (for ([variant (available-racket-variants)]) 1657 (parameterize ([current-launcher-variant variant]) 1658 (make-launcher 'console 1659 'racket-launcher-names 1660 'racket-launcher-libraries 1661 'racket-launcher-flags 1662 racket-program-launcher-path 1663 make-racket-launcher 1664 racket-launcher-up-to-date?) 1665 (make-launcher 'console 1666 'mzscheme-launcher-names 1667 'mzscheme-launcher-libraries 1668 'mzscheme-launcher-flags 1669 mzscheme-program-launcher-path 1670 make-mzscheme-launcher 1671 mzscheme-launcher-up-to-date?))))) 1672 (when (or no-specific-collections? 1673 (make-tidy)) 1674 (unless (avoid-main-installation) 1675 (tidy-launchers #f 1676 (find-lib-dir) 1677 created-launchers 1678 ccs-to-compile)) 1679 (when (make-user) 1680 (tidy-launchers #t 1681 (find-user-lib-dir) 1682 created-launchers 1683 ccs-to-compile)))) 1684 1685 (define (read-receipt-hash receipt-path) 1686 (if (file-exists? receipt-path) 1687 (with-handlers ([exn:fail? 1688 (lambda (exn) 1689 (setup-printf 1690 "WARNING" 1691 "error reading receipts ~s: ~a" 1692 receipt-path 1693 (exn-message exn)) 1694 #hash())]) 1695 (call-with-input-file* 1696 receipt-path 1697 (lambda (i) 1698 (define ht (read i)) 1699 (if (hash? ht) 1700 ht 1701 (error "content is not a hash table"))))) 1702 #hash())) 1703 1704 (define (write-receipt-hash receipt-path ht) 1705 (call-with-output-file* 1706 #:exists 'truncate/replace 1707 receipt-path 1708 (lambda (o) (write ht o) (newline o)))) 1709 1710 (define (record-launcher receipt-path name kind variant coll coll-path) 1711 (let ([ht (read-receipt-hash receipt-path)]) 1712 (define exe-key (vector kind 1713 variant 1714 name)) 1715 (define exe-val (map path->string coll)) 1716 (unless (equal? (hash-ref ht exe-key #f) 1717 exe-val) 1718 (let ([ht (hash-set ht exe-key exe-val)]) 1719 (write-receipt-hash receipt-path ht))) 1720 exe-key)) 1721 1722 (define (tidy-launchers user? lib-dir created ccs-to-compile) 1723 (define receipt-path (build-path lib-dir "launchers.rktd")) 1724 (define ht (read-receipt-hash receipt-path)) 1725 (define ht2 (for/fold ([ht (hash)]) ([(k v) (in-hash ht)]) 1726 (define coll-path (and (pair? v) 1727 (list? v) 1728 (andmap path-string? v) 1729 (apply collection-path v #:fail (lambda (s) #f)))) 1730 (cond 1731 [(hash-ref created k #f) 1732 ;; just created it, so keep it 1733 (hash-set ht k v)] 1734 [(and coll-path 1735 ;; If we set up this collection, then the launcher 1736 ;; must be in the created list if it's to be kept: 1737 (let ([coll (map string->path v)]) 1738 (not 1739 (for/or ([cc (in-list ccs-to-compile)]) 1740 (equal? coll (cc-collection cc)))))) 1741 ;; keep the launcher 1742 (hash-set ht k v)] 1743 [else 1744 ;; remove the launcher 1745 (define kind (vector-ref k 0)) 1746 (define variant (vector-ref k 1)) 1747 (define name (vector-ref k 2)) 1748 (parameterize ([current-launcher-variant variant]) 1749 (define (get-path user? tethered?) 1750 ((if (eq? kind 'gui) 1751 gracket-program-launcher-path 1752 racket-program-launcher-path) 1753 name 1754 #:user? user? 1755 #:tethered? tethered?)) 1756 (define exe-path (get-path user? #f)) 1757 (define config-exe-path (and (not user?) (get-path #f #t))) 1758 (define addon-exe-path (get-path #t #t)) 1759 (define is-dir? 1760 (if (eq? kind 'gui) 1761 (gracket-launcher-is-actually-directory?) 1762 (racket-launcher-is-actually-directory?))) 1763 (define (delete exe-path) 1764 (define rel-exe-path 1765 ((if (eq? kind 'gui) 1766 path->relative-string/gui-bin 1767 path->relative-string/console-bin) 1768 exe-path)) 1769 (cond 1770 [(and (not is-dir?) (file-exists? exe-path)) 1771 (setup-printf "deleting" "launcher ~a" rel-exe-path) 1772 (delete-file exe-path)] 1773 [(and is-dir? (directory-exists? exe-path)) 1774 (setup-printf "deleting" "launcher ~a" rel-exe-path) 1775 (delete-directory/files exe-path)])) 1776 (delete exe-path) 1777 (when config-exe-path (delete config-exe-path)) 1778 (when addon-exe-path (delete addon-exe-path)) 1779 ;; Clean up any associated .desktop file and icon file: 1780 (when (eq? 'unix (cross-system-type)) 1781 (let ([desktop (installed-executable-path->desktop-path 1782 exe-path 1783 user?)]) 1784 (when (file-exists? desktop) 1785 (setup-printf "deleting" "desktop file ~a" 1786 (path->relative-string/share desktop)) 1787 (delete-file desktop)) 1788 (for ([ext (in-list '(#"ico" #"png"))]) 1789 (define icon (installed-desktop-path->icon-path desktop 1790 user? 1791 ext)) 1792 (when (file-exists? icon) 1793 (setup-printf "deleting" "icon file ~a" 1794 (path->relative-string/share icon)) 1795 (delete-file icon)))))) 1796 ht]))) 1797 (unless (equal? ht ht2) 1798 (setup-printf "updating" "launcher list") 1799 (write-receipt-hash receipt-path ht2))) 1800 1801 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1802 ;; Foreign Libraries and Man Pages ;; 1803 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 1804 1805 (define (make-copy/move-step what 1806 whats 1807 what/title 1808 copy-tag 1809 move-tag 1810 find-target-dir 1811 get-extra-search-dirs 1812 find-user-target-dir 1813 path->relative-string/* 1814 receipt-file 1815 receipt-at-dest? 1816 check-entry 1817 build-dest-path 1818 this-platform? 1819 fixup-lib 1820 copy-user-lib) 1821 (define (make-libs-step) 1822 (setup-printf #f (add-time (format "--- installing ~a ---" whats))) 1823 (define installed-libs (make-hash)) 1824 (define dests (make-hash)) 1825 (for ([cc ccs-to-compile]) 1826 (begin-record-error cc what/title 1827 (define info (cc-info cc)) 1828 (define copy-libs 1829 (call-info info copy-tag (lambda () null) check-entry)) 1830 (define move-libs 1831 (call-info info move-tag (lambda () null) check-entry)) 1832 1833 (unless (or (and (null? copy-libs) 1834 (null? move-libs)) 1835 (not (this-platform? info))) 1836 (define dir (if (cc-main? cc) 1837 (find-target-dir) 1838 (find-user-target-dir))) 1839 (define r-dir (if receipt-at-dest? 1840 dir 1841 (if (cc-main? cc) 1842 (find-lib-dir) 1843 (find-user-lib-dir)))) 1844 (define receipt-path (build-path r-dir receipt-file)) 1845 (make-directory* dir) 1846 (make-directory* r-dir) 1847 1848 (define (copy-lib lib moving?) 1849 (define src (path->complete-path lib (cc-path cc))) 1850 (define lib-name (file-name-from-path lib)) 1851 (cond 1852 [(and (cc-main? cc) 1853 (for/or ([s-dir (in-list (get-extra-search-dirs))]) 1854 (let ([p (build-dest-path s-dir lib-name)]) 1855 (and (or (file-exists? p) 1856 (directory-exists? p)) 1857 (or (and moving? 1858 (not (file-exists? src)) 1859 (not (directory-exists? src))) 1860 (same-content? src p)))))) 1861 ;; already exists in one of the search directories, so 1862 ;; don't copy/move to this one 1863 #f] 1864 [else 1865 (define dest (build-dest-path dir lib-name)) 1866 (define already? (or (and moving? 1867 (not (file-exists? src)) 1868 (not (directory-exists? src)) 1869 (or (file-exists? dest) 1870 (directory-exists? dest))) 1871 (same-content? src dest))) 1872 (unless already? 1873 (setup-printf "installing" (string-append what " ~a") 1874 (path->relative-string/* dest))) 1875 (hash-set! 1876 installed-libs 1877 (record-lib receipt-path lib-name (cc-collection cc) (cc-path cc)) 1878 #t) 1879 (unless already? 1880 (hash-set! dests dest #t) 1881 (delete-directory/files/hard dest) 1882 (make-parent-directory* dest) 1883 (if (file-exists? src) 1884 (if (cc-main? cc) 1885 (copy-file src dest) 1886 (copy-user-lib src dest)) 1887 (copy-directory/files src dest))) 1888 src])) 1889 1890 (for ([lib (in-list copy-libs)]) 1891 (copy-lib lib #f)) 1892 1893 (for ([lib (in-list move-libs)]) 1894 (define src (copy-lib lib #t)) 1895 (when src 1896 (delete-directory/files src #:must-exist? #f)))))) 1897 (when (or no-specific-collections? 1898 (make-tidy)) 1899 (unless (avoid-main-installation) 1900 (tidy-libs #f 1901 (find-target-dir) 1902 (if receipt-at-dest? 1903 (find-target-dir) 1904 (find-lib-dir)) 1905 installed-libs 1906 ccs-to-compile)) 1907 (when (make-user) 1908 (tidy-libs #t 1909 (find-user-target-dir) 1910 (if receipt-at-dest? 1911 (find-user-target-dir) 1912 (find-user-lib-dir)) 1913 installed-libs 1914 ccs-to-compile))) 1915 (for-each fixup-lib (hash-keys dests))) 1916 1917 (define (same-content? a b) 1918 (cond 1919 [(file-exists? a) 1920 (cond 1921 [(file-exists? b) 1922 (call-with-input-file* 1923 a 1924 (lambda (a) 1925 (call-with-input-file* 1926 b 1927 (lambda (b) 1928 (define as (make-bytes 4096)) 1929 (define bs (make-bytes 4096)) 1930 (let loop () 1931 (define an (read-bytes! as a)) 1932 (define bn (read-bytes! bs b)) 1933 (and (equal? an bn) 1934 (equal? as bs) 1935 (or (eof-object? an) 1936 (loop))))))))] 1937 [else #f])] 1938 [(directory-exists? a) 1939 (cond 1940 [(directory-exists? b) 1941 (define (path<? a b) (bytes<? (path->bytes a) (path->bytes b))) 1942 (define al (sort (directory-list a) path<?)) 1943 (define bl (sort (directory-list b) path<?)) 1944 (and (equal? al bl) 1945 (andmap same-content? 1946 (map (lambda (f) (build-path a f)) al) 1947 (map (lambda (f) (build-path b f)) bl)))] 1948 [else #f])] 1949 [else #f])) 1950 1951 (define (record-lib receipt-path name coll coll-path) 1952 (let ([ht (read-receipt-hash receipt-path)]) 1953 (define lib-key (path-element->bytes name)) 1954 (define lib-val (map path->string coll)) 1955 (unless (equal? (hash-ref ht lib-key #f) 1956 lib-val) 1957 (let ([ht (hash-set ht lib-key lib-val)]) 1958 (write-receipt-hash receipt-path ht))) 1959 lib-key)) 1960 1961 (define (tidy-libs user? target-dir receipt-dir installed-libs ccs-to-compile) 1962 (clean-previous-delete-failures receipt-dir path->relative-string/*) 1963 (define receipt-path (build-path receipt-dir receipt-file)) 1964 (define ht (read-receipt-hash receipt-path)) 1965 (define ht2 (for/fold ([ht (hash)]) ([(k v) (in-hash ht)]) 1966 (define coll-path (and (pair? v) 1967 (list? v) 1968 (andmap path-string? v) 1969 (apply collection-path v #:fail (lambda (s) #f)))) 1970 (cond 1971 [(hash-ref installed-libs k #f) 1972 ;; just installed it, so keep it 1973 (hash-set ht k v)] 1974 [(and coll-path 1975 ;; If we set up this collection, then the lib 1976 ;; must be in the installed list if it's to be kept: 1977 (let ([coll (map string->path v)]) 1978 (not 1979 (for/or ([cc (in-list ccs-to-compile)]) 1980 (equal? coll (cc-collection cc)))))) 1981 ;; keep the lib 1982 (hash-set ht k v)] 1983 [else 1984 ;; remove the lib 1985 (define lib-path (build-dest-path target-dir (bytes->path-element k))) 1986 (when (or (file-exists? lib-path) 1987 (directory-exists? lib-path)) 1988 (setup-printf "deleting" (string-append what " ~a") 1989 (path->relative-string/* lib-path)) 1990 (delete-directory/files/hard lib-path)) 1991 ht]))) 1992 (unless (equal? ht ht2) 1993 (setup-printf "updating" (format "~a list" what)) 1994 (write-receipt-hash receipt-path ht2))) 1995 1996 make-libs-step) 1997 1998 (define make-foreign-libs-step 1999 (make-copy/move-step "foreign library" 2000 "foreign libraries" 2001 "foreign library setup" 2002 'copy-foreign-libs 2003 'move-foreign-libs 2004 find-lib-dir 2005 get-cross-lib-extra-search-dirs 2006 find-user-lib-dir 2007 path->relative-string/lib 2008 "libs.rktd" #t 2009 (lambda (l) 2010 (unless (list-of relative-path-string? l) 2011 (error "entry is not a list of relative path strings:" l))) 2012 build-path 2013 this-platform? 2014 (case (cross-system-type) 2015 [(macosx) 2016 adjust-dylib-path/install] 2017 [else void]) 2018 (case (cross-system-type) 2019 [(unix) 2020 copy-file/install-elf-rpath] 2021 [else copy-file]))) 2022 2023 (define make-shares-step 2024 (make-copy/move-step "shared file" 2025 "shared files" 2026 "share files setup" 2027 'copy-shared-files 2028 'move-shared-files 2029 find-share-dir 2030 get-share-extra-search-dirs 2031 find-user-share-dir 2032 path->relative-string/share 2033 "shares.rktd" #t 2034 (lambda (l) 2035 (unless (list-of relative-path-string? l) 2036 (error "entry is not a list of relative path strings:" l))) 2037 build-path 2038 this-platform? 2039 void 2040 copy-file)) 2041 2042 (define make-mans-step 2043 (make-copy/move-step "man page" 2044 "man pages" 2045 "man page setup" 2046 'copy-man-pages 2047 'move-man-pages 2048 find-man-dir 2049 get-man-extra-search-dirs 2050 find-user-man-dir 2051 path->relative-string/man 2052 "mans.rktd" #f 2053 (lambda (l) 2054 (unless (list-of (lambda (p) 2055 (and (relative-path-string? p) 2056 (filename-extension p))) 2057 l) 2058 (error 2059 "entry is not a list of relative path strings,each with a non-empty extension:" 2060 l))) 2061 (lambda (d n) 2062 (build-path d 2063 (bytes->path-element (bytes-append #"man" (filename-extension n))) 2064 n)) 2065 (lambda (info) #t) 2066 void 2067 copy-file)) 2068 2069 (define setup-delete-prefix #"raco-setup-delete-") 2070 2071 (define (delete-directory/files/hard dest) 2072 (cond 2073 [(and (eq? 'windows (system-type)) 2074 (file-exists? dest)) 2075 ;; To handle DLLs that may be opened, try moving and then 2076 ;; deleting. The delete may well fail, but at least the 2077 ;; file will be out of the way for another try. 2078 (define-values (base name dir?) (split-path dest)) 2079 (define delete-dest (build-path base 2080 (bytes->path-element 2081 (bytes-append 2082 setup-delete-prefix 2083 (path-element->bytes name))))) 2084 (rename-file-or-directory dest delete-dest #t) 2085 (try-delete-file delete-dest)] 2086 [else 2087 (delete-directory/files dest #:must-exist? #f)])) 2088 2089 (define (try-delete-file f) 2090 (with-handlers ([exn:fail:filesystem? 2091 (lambda (exn) 2092 (setup-printf 2093 "WARNING" 2094 "error deleteing file: ~a" 2095 (exn-message exn)))]) 2096 (delete-file f))) 2097 2098 (define (clean-previous-delete-failures lib-dir path->relative-string/*) 2099 (when (and (eq? 'windows (system-type)) 2100 (directory-exists? lib-dir)) 2101 (for ([f (in-list (directory-list lib-dir))]) 2102 (define bstr (path-element->bytes f)) 2103 (when (equal? (subbytes bstr 0 (min (bytes-length setup-delete-prefix) 2104 (bytes-length bstr))) 2105 setup-delete-prefix) 2106 (define p (build-path lib-dir f)) 2107 (setup-printf "deleting" (path->relative-string/* p)) 2108 (try-delete-file (build-path lib-dir f)))))) 2109 2110 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2111 ;; Package-dependency checking ;; 2112 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2113 2114 (define (do-check-package-dependencies) 2115 (setup-printf #f (add-time (format "--- checking package dependencies ---"))) 2116 (unless (check-package-dependencies (map cc-path ccs-to-compile) 2117 (map cc-collection ccs-to-compile) 2118 (map cc-main? ccs-to-compile) 2119 ;; If "test" or "scribblings" is this collection's name, 2120 ;; then it's build-mode code, otherwise it's test mode: 2121 (let ([tests-path (string->path "tests")] 2122 [scribblings-path (string->path "scribblings")]) 2123 (for/list ([cc (in-list ccs-to-compile)]) 2124 (and (cc-collection cc) ; #f for a PLaneT package 2125 (if (or (member tests-path (cc-collection cc)) 2126 (member scribblings-path (cc-collection cc))) 2127 'build 2128 'run)))) 2129 setup-printf setup-fprintf 2130 (lambda (exn) 2131 (set! exit-code 1) 2132 (setup-printf #f "check failure: ~a" (exn->string exn))) 2133 (check-unused-dependencies) 2134 (fix-dependencies) 2135 (verbose) 2136 (not no-specific-collections?) 2137 (always-check-dependencies)) 2138 (set! exit-code 1))) 2139 2140 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2141 ;; setup Body ;; 2142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2143 2144 (setup-printf "version" "~a" (version)) 2145 (setup-printf "platform" "~a [~a]" (cross-system-library-subpath #f) (cross-system-type 'gc)) 2146 (setup-printf "target machine" "~a" (or (current-compile-target-machine) 2147 (and (cross-multi-compile? (current-compiled-file-roots)) 2148 (cross-system-type 'target-machine)) 2149 'any)) 2150 (when (cross-installation?) 2151 (setup-printf "cross-installation" "yes")) 2152 (setup-printf "installation name" "~a" (get-installation-name)) 2153 (setup-printf "variants" "~a" (string-join (map symbol->string (available-mzscheme-variants)) ", ")) 2154 (setup-printf "main collects" "~a" main-collects-dir) 2155 (setup-printf "collects paths" (if (null? (current-library-collection-paths)) " empty!" "")) 2156 (for ([p (current-library-collection-paths)]) 2157 (setup-printf #f " ~a" p)) 2158 (setup-printf "main pkgs" "~a" (find-pkgs-dir)) 2159 (setup-printf "pkgs paths" "") 2160 (for ([p (get-pkgs-search-dirs)]) 2161 (setup-printf #f " ~a" p)) 2162 (setup-printf #f " ~a" (find-user-pkgs-dir)) 2163 (setup-printf "links files" "") 2164 (for ([p (get-links-search-files)]) 2165 (setup-printf #f " ~a" p)) 2166 (when (use-user-specific-search-paths) 2167 (setup-printf #f " ~a" (find-user-links-file))) 2168 (let ([roots (current-compiled-file-roots)]) 2169 (unless (or (equal? roots '(same)) 2170 (equal? roots (build-path 'same))) 2171 (setup-printf "compiled-file roots" "") 2172 (for ([p roots]) 2173 (setup-printf #f " ~a" p)))) 2174 (setup-printf "main docs" "~a" (find-doc-dir)) 2175 2176 (when (and (not (null? (archives))) no-specific-collections?) 2177 (done)) 2178 2179 (when (make-info-domain) (make-info-domain-step)) 2180 2181 (when (clean) (clean-step)) 2182 (when (make-zo) 2183 (compiler:option:verbose (compiler-verbose)) 2184 (compiler:option:compile-subcollections #f)) 2185 2186 (do-install-part 'pre) 2187 2188 (when (make-foreign-libs) 2189 (make-foreign-libs-step) 2190 (make-shares-step)) 2191 2192 (when (make-zo) (make-zo-step)) 2193 2194 (when (make-launchers) (make-launchers-step)) 2195 (when (make-launchers) 2196 (unless (eq? 'windows (cross-system-type)) 2197 (make-mans-step))) 2198 2199 (when make-docs? 2200 (make-docs-step)) 2201 (when (doc-pdf-dest) (doc-pdf-dest-step)) 2202 2203 (do-install-part 'general) 2204 (do-install-part 'post) 2205 2206 (when (and (check-dependencies) 2207 (or no-specific-collections? 2208 (always-check-dependencies))) 2209 (do-check-package-dependencies)) 2210 2211 (done)) 2212