fix some absolute paths in an in-place build

This commit is contained in:
Matthew Flatt 2013-07-08 19:27:55 -06:00
parent 301bdf9764
commit 267ba4c72b
5 changed files with 32 additions and 15 deletions

View File

@ -582,7 +582,7 @@
(match-define (pkg-info orig-pkg checksum _) info)
(match orig-pkg
[`(,(or 'link 'static-link) ,orig-pkg-dir)
orig-pkg-dir]
(path->complete-path orig-pkg-dir (pkg-installed-dir))]
[_
(build-path (pkg-installed-dir) pkg-name)]))))
@ -961,7 +961,10 @@
[(or (eq? type 'link)
(eq? type 'static-link))
(install-info pkg-name
`(,type ,(simple-form-path* pkg))
`(,type ,(path->string
(find-relative-path (pkg-installed-dir)
(simple-form-path pkg)
#:more-than-root? #t)))
pkg
#f #f
(directory->module-paths pkg pkg-name metadata-ns))]

View File

@ -115,6 +115,7 @@
(and i (sc-pkg-info? i) (sc-pkg-info-collect i)))))]
[else
;; Maybe it's a linked package
(define pkgs-dir (get-pkgs-dir scope))
(for/fold ([pkg #f] [subpath #f] [collect #f])
([(k v) (in-hash (read-pkg-db/cached))]
#:when (not pkg))
@ -122,7 +123,7 @@
(if (and (pair? orig)
(or (eq? 'link (car orig))
(eq? 'static-link (car orig))))
(let ([orig-pkg-dir (cadr orig)])
(let ([orig-pkg-dir (simplify-path (path->complete-path (cadr orig) pkgs-dir) #f)])
(define e (explode orig-pkg-dir))
(if (sub-path? <= p e)
(values k

View File

@ -9,7 +9,7 @@
;; "config"
(define config-dir
(delay (complete-path (find-system-path 'config-dir))))
(delay (complete-path-from-exe (find-system-path 'config-dir))))
(define (find-config-dir)
(force config-dir))
@ -39,6 +39,13 @@
[else l]))
(define (complete-path p)
(cond [(complete-path? p) p]
[else
(path->complete-path
p
(find-main-collects))]))
(define (complete-path-from-exe p)
(cond [(complete-path? p) p]
[(absolute-path? p) (exe-relative p)]
[else

View File

@ -964,9 +964,8 @@
(if (eq? (car p) 'info)
(info-relative->path p)
(main-lib-relative->path p)))
(and (complete-path? p)
;; `c' must be `(lib ...)'
(list? c)
;; `c' must be `(lib ...)'
(and (list? c)
(pair? c)
(eq? 'lib (car c))
(pair? (cdr c))
@ -1031,7 +1030,10 @@
;; Try relative to `lib':
(let ([p (path->main-lib-relative (cc-path cc))])
(if (path? p)
(path->bytes p)
;; Fall back to relative (with ".."s) to info root:
(path->bytes (find-relative-path (cc-info-root cc)
p
#:more-than-root? #t))
p))]
[else (path->bytes (cc-path cc))])
(cons (domain) (cc-shadowing-policy cc)))))

View File

@ -10,7 +10,8 @@
(define config-dir-path (build-path "racket" "etc"))
(define config-file-path (build-path config-dir-path "config.rktd"))
(define devel-pkgs-dir (build-path "racket" "lib" "devel-pkgs"))
(define devel-pkgs-rel-dir (build-path "devel-pkgs"))
(define devel-pkgs-dir (build-path "racket" "lib" devel-pkgs-rel-dir))
(define only-platform? #f)
(define sticky? #f)
@ -61,19 +62,20 @@
(newline o)))))
(define devel-pkgs-bytes
(path->bytes (path->complete-path devel-pkgs-dir)))
(path->bytes (build-path 'up devel-pkgs-rel-dir)))
(define devel-links-bytes
(path->bytes (path->complete-path (build-path devel-pkgs-dir "links.rktd"))))
(path->bytes (build-path 'up devel-pkgs-rel-dir "links.rktd")))
(when (file-exists? config-file-path)
(call-with-input-file*
config-file-path
(lambda (i)
(define r (read i))
(define (check what id bytes)
(define (check what id bytes alt-path)
(define l (hash-ref r id #f))
(unless (and (list? l)
(member bytes l))
(or (member bytes l)
(member (path->bytes (path->complete-path alt-path)) l)))
(error 'link-all
(~a "config file exists, but does not have a definition of `~a' that includes development ~a\n"
" config file: ~a\n"
@ -85,10 +87,12 @@
bytes)))
(check "packages"
'pkgs-search-dirs
devel-pkgs-bytes)
devel-pkgs-bytes
devel-pkgs-dir)
(check "links"
'links-search-files
devel-links-bytes))))
devel-links-bytes
(build-path devel-pkgs-dir "links.rktd")))))
;; found: maps each available package name to a directory
(define found (make-hash))