~ chicken-core (chicken-5) 2f067cdb09f27a1086b97661cd7469e5caf848bd
commit 2f067cdb09f27a1086b97661cd7469e5caf848bd
Author: Mario Domenech Goulart <mario.goulart@gmail.com>
AuthorDate: Fri Dec 14 15:18:33 2012 -0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Dec 21 22:51:40 2012 +0100
chicken-status: add -eggs command line option
Currently, chicken-status lists information about extensions. Eggs can
contain one or more extensions. This patch adds a -eggs (or -e)
command line option to chicken-status, so it can list eggs instead of
extensions.
It is possible to make eggs install multiple extensions with different
versions. chicken-install only stores versions of extensions in the
local repo. It does not store information about egg versions. Thus,
this patch does not address egg versions, since chicken-status is
unable to determine them. It simply lists egg names.
(felix) removed reference to non-existent -dump option in error
message.
Signed-off-by: felix <felix@call-with-current-continuation.org>
diff --git a/NEWS b/NEWS
index 719b96d2..dd8de6fa 100644
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,10 @@
- Fixed EINTR handling in process-wait and when reading from file ports.
- Irregex is updated to 0.9.2, which includes bugfixes and faster submatches.
+- Core tools
+ - chicken-status
+ - Added -eggs command line option to list installed eggs
+
4.8.0
- Security fixes
diff --git a/chicken-status.scm b/chicken-status.scm
index 8872c1cb..cc0e89a6 100644
--- a/chicken-status.scm
+++ b/chicken-status.scm
@@ -48,13 +48,27 @@
(define (grep rx lst)
(filter (cut irregex-search rx <>) lst))
- (define (gather-eggs patterns)
- (let ((eggs (gather-all-eggs)))
+ (define (gather-extensions patterns)
+ (let ((extensions (gather-all-extensions)))
(delete-duplicates
- (concatenate (map (cut grep <> eggs) patterns))
+ (concatenate (map (cut grep <> extensions) patterns))
string=?)))
- (define (gather-all-eggs)
+ (define (gather-eggs patterns)
+ (define (egg-name extension)
+ (and-let* ((egg (assq 'egg-name (read-info extension (repo-path)))))
+ (cadr egg)))
+ (let loop ((eggs '())
+ (extensions (gather-extensions patterns)))
+ (if (null? extensions)
+ eggs
+ (let ((egg (egg-name (car extensions))))
+ (loop (if (and egg (not (member egg eggs)))
+ (cons egg eggs)
+ eggs)
+ (cdr extensions))))))
+
+ (define (gather-all-extensions)
(map pathname-file (glob (make-pathname (repo-path) "*" "setup-info"))))
(define (format-string str cols #!optional right (padc #\space))
@@ -75,39 +89,42 @@
(min default-width w)))
default-width)))))
- (define (list-installed-eggs eggs)
+ (define (list-installed-extensions extensions)
(let ((w (quotient (- (get-terminal-width) 2) 2)))
(for-each
- (lambda (egg)
- (let ((version (assq 'version (read-info egg (repo-path)))))
+ (lambda (extension)
+ (let ((version (assq 'version (read-info extension (repo-path)))))
(if version
(print
- (format-string (string-append egg " ") w #f #\.)
+ (format-string (string-append extension " ") w #f #\.)
(format-string
(string-append " version: " (->string (cadr version)))
w #t #\.))
- (print egg))))
- (sort eggs string<?))))
+ (print extension))))
+ (sort extensions string<?))))
- (define (list-installed-files eggs)
+ (define (list-installed-eggs eggs)
+ (for-each print eggs))
+
+ (define (list-installed-files extensions)
(for-each
print
(sort
(append-map
- (lambda (egg)
- (let ((files (assq 'files (read-info egg (repo-path)))))
+ (lambda (extension)
+ (let ((files (assq 'files (read-info extension (repo-path)))))
(if files
(cdr files)
'())))
- eggs)
+ extensions)
string<?)))
(define (dump-installed-versions)
(for-each
- (lambda (egg)
- (let ((version (assq 'version (read-info egg (repo-path)))))
- (pp (list (string->symbol egg) (->string (and version (cadr version)))))))
- (gather-all-eggs)))
+ (lambda (extension)
+ (let ((version (assq 'version (read-info extension (repo-path)))))
+ (pp (list (string->symbol extension) (->string (and version (cadr version)))))))
+ (gather-all-extensions)))
(define (usage code)
(print #<<EOF
@@ -119,7 +136,8 @@ usage: chicken-status [OPTION | PATTERN] ...
-exact treat PATTERN as exact match (not a pattern)
-host when cross-compiling, show status of host extensions only
-target when cross-compiling, show status of target extensions only
- -list dump installed eggs and their versions in "override" format
+ -list dump installed extensions and their versions in "override" format
+ -e -eggs list installed eggs
EOF
);|
(exit code))
@@ -128,33 +146,41 @@ EOF
(define (main args)
(let ((files #f)
+ (eggs #f)
(dump #f)
(exact #f))
(let loop ((args args) (pats '()))
(if (null? args)
- (let ((status
- (lambda ()
- (let* ((patterns
- (map
- irregex
- (cond ((null? pats) '(".*"))
- (exact (map (lambda (p)
- (string-append "^" (irregex-quote p) "$"))
- pats))
- (else (map ##sys#glob->regexp pats)))))
- (eggs (gather-eggs patterns)))
- (if (null? eggs)
- (print "(none)")
- ((if files list-installed-files list-installed-eggs)
- eggs))))))
- (cond (dump (dump-installed-versions))
- ((and *host-extensions* *target-extensions*)
- (print "host at " (repo-path) ":\n")
- (status)
- (fluid-let ((*host-extensions* #f))
- (print "\ntarget at " (repo-path) ":\n")
- (status)))
- (else (status))))
+ (if (and eggs (or dump files))
+ (begin
+ (with-output-to-port (current-error-port)
+ (cut print "-eggs cannot be used with -list."))
+ (exit 1))
+ (let ((status
+ (lambda ()
+ (let* ((patterns
+ (map
+ irregex
+ (cond ((null? pats) '(".*"))
+ (exact (map (lambda (p)
+ (string-append "^" (irregex-quote p) "$"))
+ pats))
+ (else (map ##sys#glob->regexp pats)))))
+ (eggs/exts ((if eggs gather-eggs gather-extensions) patterns)))
+ (if (null? eggs/exts)
+ (print "(none)")
+ ((cond (eggs list-installed-eggs)
+ (files list-installed-files)
+ (else list-installed-extensions))
+ eggs/exts))))))
+ (cond (dump (dump-installed-versions))
+ ((and *host-extensions* *target-extensions*)
+ (print "host at " (repo-path) ":\n")
+ (status)
+ (fluid-let ((*host-extensions* #f))
+ (print "\ntarget at " (repo-path) ":\n")
+ (status)))
+ (else (status)))))
(let ((arg (car args)))
(cond ((or (string=? arg "-help")
(string=? arg "-h")
@@ -175,6 +201,9 @@ EOF
((or (string=? arg "-f") (string=? arg "-files"))
(set! files #t)
(loop (cdr args) pats))
+ ((or (string=? arg "-e") (string=? arg "-eggs"))
+ (set! eggs #t)
+ (loop (cdr args) pats))
((string=? arg "-version")
(print (chicken-version))
(exit 0))
Trap