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

raco pkg install: work around un-deletable directories

Browse Source 
When installing a package "P" and the usual directory already exists
and cannot be deleted, then use the path "P+1", etc., and record the
alternate path in the package database.
This commit is contained in:
Matthew Flatt 2013-10-14 18:17:11 -06:00
parent a2e75d1ff2
commit 304d72fc6f
4 changed files with 109 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/racket-pkgs/racket-test/tests/pkg/test.rkt
View File

@ -50,4 +50,5 @@
"platform"
"raco"
"binary"
"catalogs")
"catalogs"
"failure")

36
pkgs/racket-pkgs/racket-test/tests/pkg/tests-failure.rkt Normal file
View File

@ -0,0 +1,36 @@
#lang racket/base
(require rackunit
racket/system
pkg/util
"shelly.rkt"
"util.rkt")
(pkg-tests
(shelly-begin
(initialize-catalogs)
(with-fake-root
(shelly-case
"failure on remove"
$ "raco pkg install test-pkgs/pkg-test1.zip" =exit> 0
$ "raco pkg show -u -a -d" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source +Directory\npkg-test1 +[a-f0-9]+ .*pkg-test1\n"
$ "racket -e '(require pkg-test1)'" =exit> 0
$ "racket -e '(file-or-directory-permissions (collection-path \"pkg-test1\") #o500)'"
$ "raco pkg remove pkg-test1" =exit> 1
$ "racket -e '(require pkg-test1)'" =exit> 1)
(shelly-case
"re-install must go to \"+1\""
$ "raco pkg install test-pkgs/pkg-test1.zip" =exit> 0
$ "raco pkg show -u -a -d" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source +Directory\npkg-test1 +[a-f0-9]+ .*pkg-test1[+]1\n"
$ "racket -e '(require pkg-test1)'" =exit> 0
$ "raco pkg remove pkg-test1" =exit> 0
$ "racket -e '(require pkg-test1)'" =exit> 1)
(shelly-case
"re-install can go back to original place"
$ "racket -l racket/base -l setup/dirs -e '(file-or-directory-permissions (build-path (find-user-pkgs-dir) \"pkg-test1/pkg-test1\") #o700)'"
$ "raco pkg install test-pkgs/pkg-test1.zip" =exit> 0
$ "raco pkg show -u -a -d" =stdout> #rx"Package\\[\\*=auto\\] +Checksum +Source +Directory\npkg-test1 +[a-f0-9]+ .*pkg-test1\n"
$ "racket -e '(require pkg-test1)'" =exit> 0
$ "raco pkg remove pkg-test1" =exit> 0))))

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

@ -658,14 +658,34 @@
[`(,(or 'link 'static-link) ,orig-pkg-dir)
(path->complete-path orig-pkg-dir (pkg-installed-dir))]
[_
(build-path (pkg-installed-dir) pkg-name)]))))
(build-path (pkg-installed-dir)
(or (cond
[(pkg-info/alt? info)
(pkg-info/alt-dir-name info)]
[(sc-pkg-info/alt? info)
(sc-pkg-info/alt-dir-name info)]
[else #f])
pkg-name))]))))
(define (make-pkg-info orig-pkg checksum auto? single-collect alt-dir-name)
;; Picks the right structure subtype
(if single-collect
(if alt-dir-name
(sc-pkg-info/alt orig-pkg checksum auto? single-collect alt-dir-name)
(sc-pkg-info orig-pkg checksum auto? single-collect))
(if alt-dir-name
(pkg-info/alt orig-pkg checksum auto? alt-dir-name)
(pkg-info orig-pkg checksum auto?))))
(define (update-auto this-pkg-info auto?)
(match-define (pkg-info orig-pkg checksum _) this-pkg-info)
(if (sc-pkg-info? this-pkg-info)
(sc-pkg-info orig-pkg checksum auto?
(sc-pkg-info-collect this-pkg-info))
(pkg-info orig-pkg checksum auto?)))
(make-pkg-info orig-pkg checksum auto?
(and (sc-pkg-info? this-pkg-info)
(sc-pkg-info-collect this-pkg-info))
(or (and (sc-pkg-info/alt? this-pkg-info)
(sc-pkg-info/alt-dir-name this-pkg-info))
(and (pkg-info/alt? this-pkg-info)
(pkg-info/alt-dir-name this-pkg-info)))))
(define (demote-packages quiet? pkg-names)
(define db (read-pkg-db))
@ -1567,7 +1587,8 @@
(define final-pkg-dir
(cond
[clean?
(define final-pkg-dir (build-path (pkg-installed-dir) pkg-name))
(define final-pkg-dir (select-package-directory
(build-path (pkg-installed-dir) pkg-name)))
(make-parent-directory* final-pkg-dir)
(copy-directory/files pkg-dir final-pkg-dir #:keep-modify-seconds? #t)
(clean!)
@ -1589,10 +1610,13 @@
#:root? (not single-collect)
#:static-root? (and (pair? orig-pkg)
(eq? 'static-link (car orig-pkg))))
(define alt-dir-name
;; If we had to pick an alternate dir name, then record it:
(let-values ([(base name dir?) (split-path final-pkg-dir)])
(and (regexp-match? #rx"[+]" name)
(path->string name))))
(define this-pkg-info
(if single-collect
(sc-pkg-info orig-pkg checksum auto? single-collect)
(pkg-info orig-pkg checksum auto?)))
(make-pkg-info orig-pkg checksum auto? single-collect alt-dir-name))
(log-pkg-debug "updating db with ~e to ~e" pkg-name this-pkg-info)
(update-pkg-db! pkg-name this-pkg-info))]))
(define metadata-ns (make-metadata-namespace))
@ -1730,6 +1754,35 @@
(loop new-check
(set-union setup-pkgs new-check))])))
(define (select-package-directory dir #:counter [counter 0])
(define full-dir (if (zero? counter)
dir
(let-values ([(base name dir?) (split-path dir)])
(define new-name (bytes->path
(bytes-append (path->bytes name)
(string->bytes/utf-8
(~a "+" counter)))))
(if (path? base)
(build-path base new-name)
new-name))))
(cond
[(directory-exists? full-dir)
;; If the directory exists, assume that we'd like to replace it.
;; Maybe the directory couldn't be deleted when a package was
;; uninstalled, and maybe it will work now (because some process
;; has completed on Windows or some other filesystem with locks).
(with-handlers ([exn:fail:filesystem?
(lambda (exn)
(log-pkg-warning "error deleting old directory: ~a"
(exn-message exn))
(select-package-directory dir #:counter (add1 counter)))])
(delete-directory/files full-dir)
;; delete succeeded:
full-dir)]
[else
;; all clear to use the selected name:
full-dir]))
(define (snoc l x)
(append l (list x)))

11
racket/collects/pkg/path.rkt
View File

@ -2,7 +2,9 @@
(require setup/dirs)
(provide (struct-out pkg-info)
(struct-out pkg-info/alt)
(struct-out sc-pkg-info)
(struct-out sc-pkg-info/alt)
get-pkgs-dir
read-pkgs-db
read-pkg-file-hash
@ -11,7 +13,9 @@
path->pkg+subpath+collect)
(struct pkg-info (orig-pkg checksum auto?) #:prefab)
(struct pkg-info/alt pkg-info (dir-name) #:prefab) ; alternate installation directory
(struct sc-pkg-info pkg-info (collect) #:prefab) ; a pkg with a single collection
(struct sc-pkg-info/alt sc-pkg-info (dir-name) #:prefab) ; alternate installation
(define (check-scope who scope)
(unless (or (eq? scope 'user)
@ -103,10 +107,13 @@
[(sub-path? < p d)
;; Under the installation mode's package directory.
;; We assume that no one else writes there, so the
;; next path element is the package name.
;; next path element is the package name (or the package
;; name followed by "+<n>")
(define len (length d))
(define pkg-name (path-element->string (list-ref p len)))
(values pkg-name
(values (if (regexp-match? #rx"[+]" pkg-name) ; +<n> used as an alternate path, sometimes
(regexp-replace #rx"[+].*$" pkg-name "")
pkg-name)
(build-path* (list-tail p (add1 len)))
(and want-collect?
(let ([i (hash-ref (read-pkg-db/cached) pkg-name #f)])