From 959db06c7cf92c2e3c135680bd8aa56278b41bfc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Aug 2011 09:18:52 -0600 Subject: [PATCH] change "cache.rktd" format to be platform-independent The format previously included relative paths in the syntax of the platform used to run `raco setup'. While a "cache.rktd" built on Unix would work for Windows, the reverse would not be true. Also, `raco setup' under Windows would get confused because it would arrive at different relative paths for the same collection (e.g., "drracket/private" and "drracket\\private"). The portable representation of relative paths is also normalized. A "cache.rktd" file still has absolute paths for Planet packages or links installed with `raco link', but that's not a problem for packaging a distribution with a portable "cache.rktd". Also, `raco setup' cleans "cache.rtkd" by removing collections that are omitted and by not including collections that have no "info.rkt"/"info.ss" file. --- collects/setup/getinfo.rkt | 26 +++++++++--- collects/setup/setup-unit.rkt | 77 ++++++++++++++++++++++++++++------- 2 files changed, 82 insertions(+), 21 deletions(-) diff --git a/collects/setup/getinfo.rkt b/collects/setup/getinfo.rkt index 748a625ee0..7ae7b1c1ca 100644 --- a/collects/setup/getinfo.rkt +++ b/collects/setup/getinfo.rkt @@ -1,6 +1,10 @@ #lang scheme/base -(require scheme/match scheme/contract planet/cachepath syntax/modread) +(require scheme/match + scheme/contract + planet/cachepath + syntax/modread + "path-relativize.rkt") ;; in addition to infodomain/compiled/cache.rktd, getinfo will look in this ;; file to find mappings. PLaneT uses this to put info about installed @@ -118,6 +122,12 @@ (for ([f+root-dir (reverse (table-paths t))]) (let ([f (car f+root-dir)] [root-dir (cdr f+root-dir)]) + (define-values (path->info-relative + info-relative->path) + (make-relativize (lambda () root-dir) + 'info + 'path->info-relative + 'info-relative->path)) (when (file-exists? f) (for ([i (let ([l (with-input-from-file f read)]) (cond [(list? l) l] @@ -125,7 +135,7 @@ [else (error 'find-relevant-directories "bad info-domain cache file: ~a" f)]))]) (match i - [(list (? bytes? pathbytes) + [(list (and pathbytes (or (? bytes?) (list 'info (? bytes?) ...))) (list (? symbol? fields) ...) key ;; anything is okay here (? integer? maj) @@ -134,10 +144,14 @@ [new-item (make-directory-record maj min key - (let ([p (bytes->path pathbytes)]) - (if (and (relative-path? p) root-dir) - (build-path root-dir p) - p)) + (if (bytes? pathbytes) + (let ([p (bytes->path pathbytes)]) + (if (and (relative-path? p) root-dir) + ;; `raco setup' doesn't generate relative paths anyway, + ;; but it's ok to support them: + (build-path root-dir p) + p)) + (info-relative->path pathbytes)) fields)]) (hash-set! colls key ((table-insert t) new-item old-items)))] diff --git a/collects/setup/setup-unit.rkt b/collects/setup/setup-unit.rkt index 39003f9f4f..a67ffe4d19 100644 --- a/collects/setup/setup-unit.rkt +++ b/collects/setup/setup-unit.rkt @@ -26,6 +26,7 @@ "dirs.rkt" "main-collects.rkt" "path-to-relative.rkt" + "path-relativize.rkt" "private/omitted-paths.rkt" "parallel-build.rkt" "collects.rkt" @@ -792,8 +793,23 @@ ;; about those collections that exist in the same root as the ones in ;; `collections-to-compile'. (let ([ht (make-hash)] - [ht-orig (make-hash)]) + [ht-orig (make-hash)] + [roots (make-hash)]) (for ([cc ccs-to-compile]) + (define-values (path->info-relative info-relative->path) + (apply values + (hash-ref roots + (cc-info-root cc) + (lambda () + (define-values (p-> ->p) + (if (cc-info-root cc) + (make-relativize (lambda () (cc-info-root cc)) + 'info + 'path->info-relative + 'info-relative->path) + (values #f #f))) + (hash-set! roots (cc-info-root cc) (list p-> ->p)) + (list p-> ->p))))) (let* ([domain (with-handlers ([exn:fail? (lambda (x) (lambda () null))]) (dynamic-require (build-path (cc-path cc) "info.rkt") @@ -817,13 +833,16 @@ (set! all-ok? #t) (for ([i l]) (match i - [(list (? bytes? a) (list (? symbol? b) ...) c (? integer? d) (? integer? e)) - (let ([p (bytes->path a)]) + [(list (and a (or (? bytes?) (list 'info (? bytes?) ...))) + (list (? symbol? b) ...) c (? integer? d) (? integer? e)) + (let ([p (if (bytes? a) + (bytes->path a) + a)]) ;; Check that the path is suitably absolute or relative: (let ([dir (case (cc-info-path-mode cc) [(relative abs-in-relative) - (or (and (relative-path? p) - (build-path (cc-info-root cc) p)) + (or (and (list? p) + (info-relative->path p)) (and (complete-path? p) ;; `c' must be `(lib ...)' (list? c) @@ -839,11 +858,25 @@ (and (complete-path? p) p)])]) (if (and dir + (let ([omit-root + (if (path? p) + ;; absolute path => need a root for checking omits; + ;; for a collection path of length N, go up N-1 dirs: + (simplify-path (apply build-path p (for/list ([i (cddr c)]) 'up)) #f) + ;; relative path => no root needed for checking omits: + #f)]) + (not (eq? 'all (omitted-paths dir getinfo omit-root)))) (or (file-exists? (build-path dir "info.rkt")) (file-exists? (build-path dir "info.ss")))) (hash-set! t a (list b c d e)) - (set! all-ok? #f))))] - [_ (set! all-ok? #f)]))) + (begin + (when (verbose) + (printf " drop entry: ~s\n" i)) + (set! all-ok? #f)))))] + [_ + (when (verbose) + (printf " bad entry: ~s\n" i)) + (set! all-ok? #f)]))) ;; Record the table loaded for this collection root ;; in the all-roots table: (hash-set! ht (cc-info-path cc) t) @@ -854,14 +887,18 @@ (and all-ok? (hash-copy t))) t))))]) ;; Add this collection's info to the table, replacing any information - ;; already there. - (hash-set! t - (path->bytes (if (eq? (cc-info-path-mode cc) 'relative) - ;; Use relative path: - (apply build-path (cc-collection cc)) - ;; Use absolute path: - (cc-path cc))) - (cons (domain) (cc-shadowing-policy cc))))) + ;; already there, if the collection has an "info.ss" file: + (when (or (file-exists? (build-path (cc-path cc) "info.rkt")) + (file-exists? (build-path (cc-path cc) "info.ss"))) + (hash-set! t + (if (eq? (cc-info-path-mode cc) 'relative) + ;; Use relative path: + (path->info-relative (apply build-path + (cc-info-root cc) + (cc-collection cc))) + ;; Use absolute path: + (path->bytes (cc-path cc))) + (cons (domain) (cc-shadowing-policy cc)))))) ;; Write out each collection-root-specific table to a "cache.rktd" file: (hash-for-each ht (lambda (info-path ht) @@ -870,6 +907,16 @@ (make-directory* base) (let ([p info-path]) (setup-printf "updating" "~a" (path->relative-string/setup p)) + (when (verbose) + (let ([ht0 (hash-ref ht-orig info-path)]) + (when ht0 + (for ([(k v) (in-hash ht)]) + (let ([v2 (hash-ref ht0 k #f)]) + (unless (equal? v v2) + (printf " ~s -> ~s\n instead of ~s\n" k v v2)))) + (for ([(k v) (in-hash ht0)]) + (unless (hash-ref ht k #f) + (printf " ~s removed\n" k)))))) (with-handlers ([exn:fail? (warning-handler (void))]) (with-output-to-file p #:exists 'truncate/replace