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

Added package download support to the planet cmdline tool, also fixed a few error string bugs.

Browse Source 
svn: r584
This commit is contained in:
Jacob Matthews 2005-08-11 17:53:45 +00:00
parent d889daf489
commit 166abfc39e
2 changed files with 33 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
collects/planet/planet.ss
View File

@ -50,6 +50,11 @@ PLANNED FEATURES:
" (require (planet \"file.ss\" (<owner> <pkg> <maj> <min>)))"
"would install"
(set! actions (cons (lambda () (download/install owner pkg maj min)) actions)))
(("-d" "--download")
owner pkg maj min
""
"Download the given package file without installing it"
(set! actions (cons (lambda () (download/no-install owner pkg maj min)) actions)))
(("-r" "--remove")
owner pkg maj min
""
@ -67,7 +72,6 @@ PLANNED FEATURES:
""
"List the current linkage table"
(set! actions (cons show-linkage actions)))
;; unimplemented so far:
#;(("-u" "--unlink")
module
@ -79,7 +83,8 @@ PLANNED FEATURES:
;; ============================================================
;; FEATURE IMPLEMENTATIONS
(define (fail s) (raise (make-exn:fail s (current-continuation-marks))))
(define (fail s . args)
(raise (make-exn:fail (string->immutable-string (apply format s args)) (current-continuation-marks))))
(define (download/install owner pkg majstr minstr)
(let* ([maj (read-from-string majstr)]
@ -90,12 +95,26 @@ PLANNED FEATURES:
(unless (get-package-from-server full-pkg-spec)
(fail "Could not find matching package"))))
(define (download/no-install owner pkg majstr minstr)
(let* ([maj (read-from-string majstr)]
[min (read-from-string minstr)]
[full-pkg-spec (pkg-spec->full-pkg-spec (list owner pkg maj min) #f)])
(when (file-exists? pkg)
(fail "Cannot download, there is a file named ~a in the way" pkg))
(match (download-package full-pkg-spec)
[(#t path maj min)
(copy-file path pkg)
(printf "Downloaded ~a package version ~a.~a\n" pkg maj min)]
[_
(fail "Could not find matching package")])))
(define (install-plt-file filestr owner 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 (file-exists? filestr) (fail (format "File does not exist: ~a" filestr)))
(unless (file-exists? filestr) (fail "File does not exist: ~a" filestr))
(let* ([file (normalize-path filestr)]
[name (let-values ([(base name dir?) (split-path file)]) (path->string name))]
[spec (list owner name maj min)]
@ -105,7 +124,7 @@ PLANNED FEATURES:
(define (do-archive p)
(unless (directory-exists? p)
(fail (format "No such directory: ~a" p)))
(fail "No such directory: ~a" p))
(make-planet-archive (normalize-path p)))
(define (remove owner pkg majstr minstr)

13
collects/planet/resolver.ss
View File

@ -160,6 +160,7 @@ an appropriate subdirectory.
pkg-spec->full-pkg-spec
get-package-from-cache
get-package-from-server
download-package
install-pkg
get-planet-module-path/pkg)
@ -287,11 +288,15 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
"Error downloading module from PLaneT server: ~a"
(exn-message e)))
(exn-continuation-marks e))))])
(let ((download (if (USE-HTTP-DOWNLOADS?) download-package/http download-package)))
(match (download pkg)
(match (download-package pkg)
[(#t path maj min) (install-pkg pkg path maj min)]
[(#f str) #f]))))
[(#f str) #f])))
(define (download-package pkg)
((if (USE-HTTP-DOWNLOADS?)
download-package/http
download-package/planet)
pkg))
(define (current-time)
(let ((date (seconds->date (current-seconds))))
@ -336,7 +341,7 @@ attempted to load version ~a.~a while version ~a.~a was already loaded"
; the path is to a file that contains the package. If bool is #f, the package
; didn't exist and the string is the server's informative message.
; raises an exception if some protocol failure occurs in the download process
(define (download-package pkg)
(define (download-package/planet pkg)
(define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT)))