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

Fix error reported by Sam

Browse Source 
svn: r7580
This commit is contained in:
Jacob Matthews 2007-10-27 21:36:23 +00:00
parent 05e2b658ef
commit c161c7f958
4 changed files with 71 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/planet/planet.ss
View File

@ -179,16 +179,16 @@ PLANNED FEATURES:
(min (string->number minstr)))
(unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0))
(fail "Invalid major/minor version"))
(unless (remove-pkg owner pkg maj min)
(fail "Could not find package"))))
(with-handlers ([exn:fail:planet? (λ (e) (fail (exn-message e)))])
(remove-pkg owner pkg maj min))))
(define (erase owner pkg majstr minstr)
(let ((maj (string->number majstr))
(min (string->number minstr)))
(unless (and (integer? maj) (integer? min) (> maj 0) (>= min 0))
(fail "Invalid major/minor version"))
(unless (erase-pkg owner pkg maj min)
(fail "Could not find package"))))
(with-handlers ([exn:fail:planet? (λ (e) (fail (exn-message e)))])
(erase-pkg owner pkg maj min))))
(define (show-installed-packages)
(let ([normal-packages (get-installed-planet-archives)]

41
collects/planet/private/planet-shared.ss
View File

@ -36,14 +36,21 @@ Various common pieces of code that both the client and server need to access
core-version ; string
)
(make-inspector))
; PKG : string (listof string) Nat Nat path
(define-struct pkg (name route maj min path))
; PKG : string (listof string) Nat Nat path ORIGIN
(define-struct pkg (name route maj min path origin))
; UNINSTALLED-PKG : path FULL-PKG-SPEC Nat Nat
(define-struct uninstalled-pkg (path spec maj min))
; PKG-PROMISE : PKG | UNINSTALLED-PKG
; ORIGIN : 'normal | 'development-link
(define (pkg-promise? p) (or (pkg? p) (uninstalled-pkg? p)))
(define (normally-installed-pkg? p)
(eq? (pkg-origin p) 'normal))
(define (development-link-pkg? p)
(eq? (pkg-origin p) 'development-link))
; ==========================================================================================
; CACHE LOGIC
; Handles checking the cache for an appropriate module
@ -140,7 +147,8 @@ Various common pieces of code that both the client and server need to access
(pkg-spec-path pkg)
maj min
the-path
min-core-version))
min-core-version
'normal))
#f)))
(if (directory-exists? path)
@ -176,7 +184,7 @@ Various common pieces of code that both the client and server need to access
(define (get-hard-link-table)
(verify-well-formed-hard-link-parameter!)
(if (file-exists? (HARD-LINK-FILE))
(map (lambda (item) (update-element 4 bytes->path item))
(map (lambda (item) (update/create-element 6 (λ (_) 'development-link) (update-element 4 bytes->path item)))
(with-input-from-file (HARD-LINK-FILE) read-all))
'()))
@ -217,7 +225,7 @@ Various common pieces of code that both the client and server need to access
(let ([complete-dir (path->complete-path dir)])
(let* ([original-table (get-hard-link-table)]
[new-table (cons
(make-assoc-table-row name path maj min complete-dir #f)
(make-assoc-table-row name path maj min complete-dir #f 'development-link)
(filter
(lambda (row) (not (points-to? row name path maj min)))
original-table))])
@ -239,6 +247,17 @@ Various common pieces of code that both the client and server need to access
[(zero? n) (cons (f (car l)) (cdr l))]
[else (cons (car l) (update-element (sub1 n) f (cdr l)))]))
(define (update/create-element n f l)
(cond
[(and (null? l) (zero? n))
(list (f #f))]
[(and (null? l) (not (zero? n)))
(error 'update/create-element "Index too large")]
[(and (not (null? l)) (zero? n))
(cons (f (car l)) (cdr l))]
[else (cons (car l) (update/create-element (sub1 n) f (cdr l)))]))
; add-to-table assoc-table (listof assoc-table-row) -> assoc-table
(define add-to-table append)
@ -258,11 +277,12 @@ Various common pieces of code that both the client and server need to access
assoc-table-row->maj
assoc-table-row->min
assoc-table-row->dir
assoc-table-row->required-version)
(first-n-list-selectors 6))
assoc-table-row->required-version
assoc-table-row->type)
(first-n-list-selectors 7))
(define (make-assoc-table-row name path maj min dir required-version)
(list name path maj min dir required-version))
(define (make-assoc-table-row name path maj min dir required-version type)
(list name path maj min dir required-version type))
(define-struct mz-version (major minor))
@ -342,7 +362,8 @@ Various common pieces of code that both the client and server need to access
(pkg-spec-path spec)
(assoc-table-row->maj best-row)
(assoc-table-row->min best-row)
(assoc-table-row->dir best-row)))))))
(assoc-table-row->dir best-row)
(assoc-table-row->type best-row)))))))
;; get-installed-package : string string nat nat -> PKG | #f

2
collects/planet/resolver.ss
View File

@ -599,7 +599,7 @@ an appropriate subdirectory.
(parameterize ((current-namespace (make-namespace)))
(let ([ipp (dynamic-require '(lib "plt-single-installer.ss" "setup") 'install-planet-package)])
(ipp path the-dir (list owner (pkg-spec-name pkg) extra-path maj min))))))
(make-pkg (pkg-spec-name pkg) (pkg-spec-path pkg) maj min the-dir)))))
(make-pkg (pkg-spec-name pkg) (pkg-spec-path pkg) maj min the-dir 'normal)))))
; download-package : FULL-PKG-SPEC -> RESPONSE
; RESPONSE ::= (list #f string) | (list #t path[file] Nat Nat)

41
collects/planet/util.ss
View File

@ -28,11 +28,10 @@
force-package-building?
get-installed-planet-archives
get-hard-linked-packages
remove-pkg
unlink-all
lookup-package-by-keys
resolve-planet-path)
resolve-planet-path
(struct exn:fail:planet ()))
(provide/contract
[download/install-pkg
@ -41,8 +40,10 @@
(-> string? string? natural-number/c natural-number/c path? void?)]
[remove-hard-link
(-> string? string? natural-number/c natural-number/c void?)]
[remove-pkg
(-> string? string? natural-number/c natural-number/c void?)]
[erase-pkg
(-> string? string? natural-number/c natural-number/c boolean?)])
(-> string? string? natural-number/c natural-number/c void?)])
;; download/install-pkg : string string nat nat -> pkg | #f
(define (download/install-pkg owner name maj min)
@ -66,10 +67,17 @@
;; -- remove relevant infodomain cache entries
;; -- delete files from cache directory
;; -- remove any existing linkage for package
;; returns #t if the removal worked; #f if no package existed.
;; returns void if the removal worked; raises an exception if no package existed.
(define-struct (exn:fail:planet exn:fail) ())
(define (remove-pkg owner name maj min)
(let ((p (get-installed-package owner name maj min)))
(and p
(unless p
(raise (make-exn:fail:planet "Could not find package" (current-continuation-marks))))
(unless (normally-installed-pkg? p)
(raise (make-exn:fail:planet "Not a normally-installed package, can't remove" (current-continuation-marks))))
(let ((path (pkg-path p)))
(with-logging
(LOG-FILE)
@ -79,7 +87,7 @@
(erase-metadata p)
(delete-directory/files path)
(trim-directory (CACHE-DIR) path)
#t))))
(void))))
;; erase-metadata : pkg -> void
;; clears out any references to the given package in planet's metadata files
@ -135,16 +143,17 @@
(define (erase-pkg owner name maj min)
(let* ([uninstalled-pkg-dir
(build-path (UNINSTALLED-PACKAGE-CACHE) owner name (number->string maj) (number->string min))]
[uninstalled-pkg-file (build-path uninstalled-pkg-dir name)])
(let ([removed-something? (remove-pkg owner name maj min)]
[erased-something?
(if (file-exists? uninstalled-pkg-file)
(begin
[uninstalled-pkg-file (build-path uninstalled-pkg-dir name)]
[uninstalled-file-exists? (file-exists? uninstalled-pkg-file)])
(when uninstalled-file-exists?
(delete-file uninstalled-pkg-file)
(trim-directory (UNINSTALLED-PACKAGE-CACHE) uninstalled-pkg-dir)
#t)
#f)])
(or removed-something? erased-something?))))
(trim-directory (UNINSTALLED-PACKAGE-CACHE) uninstalled-pkg-dir))
(with-handlers ([exn:fail:planet?
(λ (e) (if uninstalled-file-exists?
;; not really a failure, just return
(void)
(raise e)))])
(remove-pkg owner name maj min))))
;; listof X * listof X -> nonempty listof X
;; returns de-prefixed version of l2 if l1 is a proper prefix of l2;