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

raco pkg migrate: fix cross-version locking

Browse Source
This commit is contained in:
Matthew Flatt 2016-03-17 15:16:05 -06:00
parent b1ff73155f
commit b94e77a062
2 changed files with 19 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
racket/collects/pkg/private/lock.rkt
View File

@ -10,7 +10,9 @@
with-pkg-lock with-pkg-lock
with-pkg-lock/read-only with-pkg-lock/read-only
;; Checks that the lock is held: ;; Checks that the lock is held:
write-file-hash!) write-file-hash!
;; For migrate:
call-with-separate-lock)
(define pkg-lock-held (make-parameter #f)) (define pkg-lock-held (make-parameter #f))
(define pkg-lock-scope (make-parameter #f)) (define pkg-lock-scope (make-parameter #f))
@ -62,6 +64,13 @@
(define-syntax-rule (with-pkg-lock/read-only e ...) (define-syntax-rule (with-pkg-lock/read-only e ...)
(with-pkg-lock* #t (λ () e ...))) (with-pkg-lock* #t (λ () e ...)))
;; Intended for use with `pkg-migrate`, which needs to
;; read a different version than it writes to:
(define (call-with-separate-lock f)
(parameterize ([pkg-lock-held #f]
[pkg-lock-scope #f])
(f)))
(define (write-file-hash! file new-db) (define (write-file-hash! file new-db)
(unless (eq? (pkg-lock-held) 'exclusive) (unless (eq? (pkg-lock-held) 'exclusive)
(pkg-error "attempt to write package database without write lock")) (pkg-error "attempt to write package database without write lock"))

13
racket/collects/pkg/private/migrate.rkt
View File

@ -9,7 +9,8 @@
"params.rkt" "params.rkt"
"install.rkt" "install.rkt"
"repo-path.rkt" "repo-path.rkt"
"dirs.rkt") "dirs.rkt"
"print.rkt")
(provide pkg-migrate) (provide pkg-migrate)
@ -26,8 +27,12 @@
#:force-strip? [force-strip? #f] #:force-strip? [force-strip? #f]
#:dry-run? [dry-run? #f]) #:dry-run? [dry-run? #f])
(define from-db (define from-db
(parameterize ([current-pkg-scope-version from-version]) ((if (equal? (current-pkg-scope-version) from-version)
(installed-pkg-table #:scope 'user))) (lambda (f) (f))
call-with-separate-lock)
(lambda ()
(parameterize ([current-pkg-scope-version from-version])
(installed-pkg-table #:scope 'user)))))
(define installed-dir (define installed-dir
(parameterize ([current-pkg-scope 'user]) (parameterize ([current-pkg-scope 'user])
(pkg-installed-dir))) (pkg-installed-dir)))
@ -81,4 +86,4 @@
#:force-strip? force-strip? #:force-strip? force-strip?
#:dry-run? dry-run?) #:dry-run? dry-run?)
(unless quiet? (unless quiet?
(printf "Packages migrated\n"))))) (printf "Packages migrated~a\n" (dry-run-explain dry-run?))))))