>From d2aa22f7e547c478b0f431e388c8d6fc7639fe91 Mon Sep 17 00:00:00 2001
From: Mario Domenech Goulart <address@hidden>
Date: Fri, 14 Dec 2012 15:18:33 -0200
Subject: [PATCH] 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.
---
 NEWS               |    4 ++
 chicken-status.scm |  113 +++++++++++++++++++++++++++++++++-------------------
 2 files changed, 75 insertions(+), 42 deletions(-)

diff --git a/NEWS b/NEWS
index 719b96d..dd8de6f 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 8872c1c..0c7eccc 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 or -dump."))
+                  (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))
-- 
1.7.10.4