suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

raco pkg install: fix tmp-directory clean-up

Browse Source 
Fix when installing from a non-directory in `--source` or
`--binary` mode, and fix clean up of a GitHub-generated archive
when using a path within the archive.
This commit is contained in:
Matthew Flatt 2014-06-04 14:27:50 +01:00
parent 02d53d29fb
commit 0ed142b78f
2 changed files with 47 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
racket/collects/pkg/lib.rkt
View File

@ -1079,12 +1079,12 @@
['github
(unless checksum
(pkg-error
(~a "could not find checksum for github package source, which implies it doesn't exist\n"
(~a "could not find checksum for GitHub package source, which implies it doesn't exist\n"
" source: ~a")
pkg))
(when (equal? checksum "")
(pkg-error
(~a "cannot use empty checksum for github package source\n"
(~a "cannot use empty checksum for GitHub package source\n"
" source: ~a")
pkg))
(match-define (list* user repo branch path)
@ -1108,8 +1108,6 @@
"~a-"
(format "~a.~a" repo branch))
'directory))
(define package-path
(apply build-path tmp-dir path))
(dynamic-wind
void
@ -1122,8 +1120,17 @@
void
(λ ()
(untar tmp.tgz tmp-dir #:strip-components 1)
(unless (null? path)
(unless (directory-exists? (apply build-path tmp-dir path))
(pkg-error
(~a "specified directory is not in GitHub respository archive\n"
" path: ~a"
(apply build-path path))))
(lift-directory-content tmp-dir path))
(begin0
(stage-package/info (path->string package-path)
(stage-package/info tmp-dir
'dir
pkg-name
#:given-checksum checksum
@ -1133,13 +1140,13 @@
download-printf
metadata-ns
#:strip strip-mode
#:in-place? (not strip-mode)
#:in-place? #t
#:in-place-clean? #t)
(set! staged? #t)))
(λ ()
(when (and use-cache? (not staged?))
(clean-cache new-url checksum))
(unless (and staged? (not strip-mode))
(unless staged?
(delete-directory/files tmp-dir)))))
(λ ()
(delete-directory/files tmp.tgz)))]
@ -1269,7 +1276,7 @@
(define pkg-dir
(make-temporary-file (string-append "~a-" pkg-name)
'directory))
(define staged? #t)
(define staged? #f)
(dynamic-wind
void
(λ ()

32
racket/collects/pkg/util.rkt
View File

@ -7,6 +7,7 @@
racket/match
racket/format
racket/string
racket/set
net/url
json)
@ -163,4 +164,35 @@
(failure bytes))))
(lambda () (failure #f)))))
(define (lift-directory-content pkg-dir path)
(define orig-sub (let ([s (car path)])
(if (string? s)
(string->path s)
s)))
;; Delete everything except `orig-sub`:
(for ([f (in-list (directory-list pkg-dir))])
(unless (equal? f orig-sub)
(delete-directory/files (build-path pkg-dir f))))
;; Get list of files and directories to move:
(define sub-l (directory-list (apply build-path pkg-dir path)))
;; Make sure `sub` doesn't match a name we want to move here:
(define sub
(let loop ([sub orig-sub] [i 0])
(cond
[(member sub sub-l)
;; pick a new name:
(loop (string->path (format "sub~a" i)) (add1 i))]
[(not (equal? sub orig-sub))
(rename-file-or-directory (build-path pkg-dir orig-sub)
(build-path pkg-dir sub))
sub]
[else sub])))
;; Move content of `sub` out:
(define sub-path (apply build-path (cons sub (cdr path))))
(for ([f (in-list sub-l)])
(rename-file-or-directory (build-path pkg-dir sub-path f)
(build-path pkg-dir f)))
;; Remove directory that we moved files out of:
(delete-directory/files (build-path pkg-dir sub)))
(provide (all-defined-out))