~ chicken-core (chicken-5) 34e46927468244553f5df14237a65df856d2d93a

commit 34e46927468244553f5df14237a65df856d2d93a
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Wed May 11 04:44:16 2011 -0400
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Wed May 11 04:44:16 2011 -0400

    -reinstall: needs internal property in setup info to handle egg installing multiple subextensions (problem pointed out by kon)

diff --git a/chicken-install.scm b/chicken-install.scm
index ce8d8039..fcffb038 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -645,9 +645,18 @@
         (error "shell command terminated with nonzero exit code" r str))))
 
   (define (installed-extensions)
-    (map (lambda (sf)
-	   (cons (pathname-file sf) (first (read-file sf))))
-	 (glob (make-pathname (repo-path) "*" "setup-info"))))
+    (delete-duplicates
+     (filter-map
+      (lambda (sf) 
+	(let ((info (first (read-file sf))))
+	  (cond ((assq 'egg-name-and-version info) => cadr)
+		(else 
+		 (warning 
+		  "installed extension has no information about the egg it belongs to"
+		  (pathname-file sf))
+		 #f))))
+      (glob (make-pathname (repo-path) "*" "setup-info")))
+     equal?))
 
   (define (command fstr . args)
     (let ((cmd (apply sprintf fstr args)))
@@ -702,10 +711,9 @@ EOF
                   (set! *proxy-port* 80)))))))
 
   (define (info->egg info)
-    (let ((version (assq 'version (cdr info))))
-      (if version
-	  (cons (car info) (->string (cadr version)))
-	  (car info))))
+    (if (member (cadr info) '("" "unknown" "trunk"))
+	(car info)
+	(cons (car info) (cadr info))))
   
   (define *short-options* '(#\h #\k #\l #\t #\s #\p #\r #\n #\v #\i #\u #\D))
 
diff --git a/setup-api.scm b/setup-api.scm
index e88dd302..60d41b0f 100644
--- a/setup-api.scm
+++ b/setup-api.scm
@@ -544,9 +544,17 @@
 	    "unknown"))))
 
 (define (supply-version info version)
-  (if (assq 'version info)
-      info
-      (cons `(version ,(what-version version)) info)))
+  (cond ((assq 'version info) => 
+	 (lambda (a)
+	   (cons 
+	    `(egg-name-and-version (,(extension-name) ,(->string (cadr a))))
+	    info)))
+	(else
+	 (let ((v (what-version version)))
+	   (cons*
+	    `(version ,v)
+	    `(egg-name-and-version (,(extension-name) ,(->string v)))
+	    info)))))
 
 
 ;;; Convenience function
@@ -763,8 +771,7 @@
                    [ensure-string (lambda (x) (if (or (not x) (null? x)) "" (->string x)))])
                (list (ensure-string nam) (ensure-string ver)) ) ]
             [else
-             (warning "invalid extension-name-and-version" x)
-             (extension-name-and-version) ] ) ) ) )
+             (error "invalid extension-name-and-version" x)]))))
 
 (define (extension-name)
   (car (extension-name-and-version)) )