~ chicken-core (chicken-5) fddf8a7c1790786e031f42e5ead898d3c59392f3
commit fddf8a7c1790786e031f42e5ead898d3c59392f3
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Jun 14 09:23:17 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Jun 14 09:23:17 2011 +0200
chicken-install -list
diff --git a/chicken-install.scm b/chicken-install.scm
index 178ff007..117247b3 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -178,7 +178,7 @@
(cond ((assoc name *aliases*) =>
(lambda (a)
(let ((new (cdr a)))
- (print "resolving alias `" name "' to: " new)
+ ;(print "resolving alias `" name "' to: " new)
(resolve-location new))))
(else name)))
@@ -301,22 +301,30 @@
[e ()
(abort e) ] ) )
- (define (try-default-sources name version)
+ (define (with-default-sources proc)
(let trying-sources ([defs (known-default-sources)])
(if (null? defs)
- (values #f "")
+ (proc #f #f)
(let* ([def (car defs)]
[locn (resolve-location
(cadr (or (assq 'location def)
(error "missing location entry" def))))]
[trans (cadr (or (assq 'transport def)
(error "missing transport entry" def)))])
- (let-values ([(dir ver) (try-extension name version trans locn)])
- (if dir
- (values dir ver)
- (begin
+ (proc trans locn
+ (lambda ()
(invalidate-default-source! def)
- (trying-sources (cdr defs)) ) ) ) ) ) ) )
+ (trying-sources (cdr defs)) ) ) ) ) ) )
+
+ (define (try-default-sources name version)
+ (with-default-sources
+ (lambda (trans locn next)
+ (if (not trans)
+ (values #f "")
+ (let-values (((dir ver) (try-extension name version trans locn)))
+ (if dir
+ (values dir ver)
+ (next)))))))
(define (make-replace-extension-question e+d+v upgrade)
(string-concatenate
@@ -662,6 +670,20 @@
(glob (make-pathname (repo-path) "*" "setup-info")))
equal?))
+ (define (list-available-extensions trans locn)
+ (with-default-sources
+ (lambda (trans locn next)
+ (if trans
+ (list-extensions
+ trans locn
+ quiet: #t
+ username: *username*
+ password: *password*
+ proxy-host: *proxy-host*
+ proxy-port: *proxy-port*
+ proxy-user-pass: *proxy-user-pass*)
+ (next)))))
+
(define (command fstr . args)
(let ((cmd (apply sprintf fstr args)))
(print " " cmd)
@@ -683,6 +705,7 @@ usage: chicken-install [OPTION | EXTENSION[:VERSION]] ...
-r -retrieve only retrieve egg into current directory, don't install
-n -no-install do not install, just build (implies `-keep')
-p -prefix PREFIX change installation prefix to PREFIX
+ -list list extensions available over selected transport and location
-host when cross-compiling, compile extension only for host
-target when cross-compiling, compile extension only for target
-test run included test-cases, if available
@@ -725,6 +748,7 @@ EOF
(define (main args)
(let ((update #f)
(scan #f)
+ (listeggs #f)
(rx (irregex "([^:]+):(.+)")))
(setup-proxy (get-environment-variable "http_proxy"))
(let loop ((args args) (eggs '()))
@@ -737,28 +761,29 @@ EOF
(else
(let ((defaults (load-defaults)))
(when (null? eggs)
- (if *reinstall*
- (let ((egginfos (installed-extensions)))
- (if (or *force*
- (yes-or-no?
- (sprintf
- "About to re-install all ~a currently installed extensions - do you want to proceed?"
- (length egginfos))
- abort: #f))
- (set! eggs (map info->egg egginfos))
- (exit 1)))))
- (when (null? eggs)
- (let ((setups (glob "*.setup")))
- (cond ((pair? setups)
- (set! *eggs+dirs+vers*
- (append
- (map
- (lambda (s) (cons (pathname-file s) (list "." "")))
- setups)
- *eggs+dirs+vers*)))
- (else
- (print "no setup-scripts to process")
- (exit 1))) ) )
+ (cond (*reinstall*
+ (let ((egginfos (installed-extensions)))
+ (if (or *force*
+ (yes-or-no?
+ (sprintf
+ "About to re-install all ~a currently installed extensions - do you want to proceed?"
+ (length egginfos))
+ abort: #f))
+ (set! eggs (map info->egg egginfos))
+ (exit 1))))
+ ((not listeggs)
+ (let ((setups (glob "*.setup")))
+ (cond ((pair? setups)
+ (set! *eggs+dirs+vers*
+ (append
+ (map
+ (lambda (s)
+ (cons (pathname-file s) (list "." "")))
+ setups)
+ *eggs+dirs+vers*)))
+ (else
+ (print "no setup-scripts to process")
+ (exit 1))) ) )))
(unless defaults
(unless *default-transport*
(error
@@ -766,7 +791,10 @@ EOF
(unless *default-location*
(error
"no default location defined - please use `-location' option")))
- (install (apply-mappings (reverse eggs)))))))
+ (if listeggs
+ (list-available-extensions
+ *default-transport* *default-location*)
+ (install (apply-mappings (reverse eggs))))))))
(else
(let ((arg (car args)))
(cond ((or (string=? arg "-help")
@@ -872,6 +900,9 @@ EOF
((string=? "-keep-going" arg)
(set! *keep-going* #t)
(loop (cdr args) eggs))
+ ((string=? "-list" arg)
+ (set! listeggs #t)
+ (loop (cdr args) eggs))
((string=? "-csi" arg)
(unless (pair? (cdr args)) (usage 1))
(set! *csi* (cadr args))
diff --git a/manual/Extensions b/manual/Extensions
index 7aa6f4af..d820a9a7 100644
--- a/manual/Extensions
+++ b/manual/Extensions
@@ -562,6 +562,7 @@ Available options:
; {{-k -keep}} : keep temporary files
; {{-l -location LOCATION}} : install from given location instead of default
; {{-t -transport TRANSPORT}} : use given transport instead of default
+; {{-list}} : list extensions available
; {{-proxy HOST[:PORT]}} : connect via HTTP proxy
; {{-s -sudo}} : use {{sudo(1)}} for installing or removing files
; {{-r -retrieve}} : only retrieve egg into current directory, don't install
diff --git a/setup-download.scm b/setup-download.scm
index 3ac1f342..57264c03 100644
--- a/setup-download.scm
+++ b/setup-download.scm
@@ -285,7 +285,7 @@
(define (match-chunked-transfer-encoding ln)
(irregex-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )
- (define (http-fetch host port locn dest proxy-host proxy-port proxy-user-pass)
+ (define (http-connect host port locn proxy-host proxy-port proxy-user-pass)
(d "connecting to host ~s, port ~a ~a...~%" host port
(if proxy-host
(sprintf "(via ~a:~a) " proxy-host proxy-port)
@@ -325,29 +325,48 @@
(let ([data (read-chunks in)])
(close-input-port in)
(set! in (open-input-string data))) ) )
- (d "reading files ...~%")
- (let get-files ([files '()])
- (let ([name (read in)])
- (cond [(and (pair? name) (eq? 'error (car name)))
- (throw-server-error (cadr name) (cddr name))]
- [(or (eof-object? name) (not name))
- (close-input-port in)
- (close-output-port out)
- (reverse files) ]
- [(not (string? name))
- (error "invalid file name - possibly corrupt transmission" name) ]
- [(string-suffix? "/" name)
- (read in) ; skip size
- (d " ~a~%" name)
- (create-directory (make-pathname dest name))
- (get-files files) ]
- [else
- (d " ~a~%" name)
- (let* ([size (read in)]
- [_ (read-line in)]
- [data (read-string size in)] )
- (with-output-to-file (make-pathname dest name) (cut display data) ) )
- (get-files (cons name files)) ] ) ) ) ) )
+ (values in out)))
+
+ (define (http-retrieve-files in out dest)
+ (d "reading files ...~%")
+ (let get-files ([files '()])
+ (let ([name (read in)])
+ (cond [(and (pair? name) (eq? 'error (car name)))
+ (throw-server-error (cadr name) (cddr name))]
+ [(or (eof-object? name) (not name))
+ (close-input-port in)
+ (close-output-port out)
+ (reverse files) ]
+ [(not (string? name))
+ (error "invalid file name - possibly corrupt transmission" name) ]
+ [(string-suffix? "/" name)
+ (read in) ; skip size
+ (d " ~a~%" name)
+ (create-directory (make-pathname dest name))
+ (get-files files) ]
+ [else
+ (d " ~a~%" name)
+ (let* ([size (read in)]
+ [_ (read-line in)]
+ [data (read-string size in)] )
+ (with-output-to-file (make-pathname dest name) (cut display data) ) )
+ (get-files (cons name files)) ] ) ) ) )
+
+ (define (http-fetch host port locn dest proxy-host proxy-port proxy-user-pass)
+ (let-values (((in out)
+ (http-connect host port locn proxy-host proxy-port proxy-user-pass)))
+ (http-retrieve-files in out dest)))
+
+ (define (list-eggs/http location proxy-host proxy-port proxy-user-pass)
+ (let-values ([(host port locn) (deconstruct-url location)])
+ (let-values (((in out)
+ (http-connect
+ host port
+ (string-append locn "?list=1")
+ proxy-host proxy-port proxy-user-pass)))
+ (display (read-all in))
+ (close-input-port in)
+ (close-output-port out))))
(define (throw-server-error msg args)
(abort
@@ -392,13 +411,16 @@
(else
(error "cannot retrieve extension unsupported transport" transport) ) ) ) )
- (define (list-extensions transport location #!key quiet username password)
+ (define (list-extensions transport location #!key quiet username password
+ proxy-host proxy-port proxy-user-pass)
(fluid-let ((*quiet* quiet))
(case transport
((local)
(list-eggs/local location) )
((svn)
(list-eggs/svn location username password) )
+ ((http)
+ (list-eggs/http location proxy-host proxy-port proxy-user-pass))
(else
(error "cannot list extensions - unsupported transport" transport) ) ) ) )
Trap