~ chicken-core (chicken-5) c1738c6caba83b0b8f6f102a35ab48a309435e54

commit c1738c6caba83b0b8f6f102a35ab48a309435e54
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Apr 21 22:25:43 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Thu Apr 21 22:25:43 2011 +0200

    chicken-install -override

diff --git a/chicken-install.scm b/chicken-install.scm
index dbca988e..c55cfc88 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -98,6 +98,7 @@
   (define *target-extension* *cross-chicken*)
   (define *debug-setup* #f)
   (define *keep-going* #f)
+  (define *override* '())
 
   (define (get-prefix #!optional runtime)
     (cond ((and *cross-chicken*
@@ -150,6 +151,11 @@
 				 (cons (car a) (cadr a))
 				 (broken x)))
 			   (cdr x)))))
+		  ((override)
+		   (set! *override* 
+		     (if (and (pair? (cdr x)) (string? (cadr x)))
+			 (read-file (cadr x))
+			 (cdr x))))
 		  (else (broken x))))
 	      (read-file deff))))
       (pair? *default-sources*) ))
@@ -304,15 +310,36 @@
       (list "The following installed extensions are outdated, because `"
             (car e+d+v)
             "' requires later versions:\n")
-      (map
+      (filter-map
        (lambda (e)
-         (conc
-          "  " (car e)
-          " (" (let ([v (assq 'version (extension-information (car e)))]) (if v (cadr v) "???"))
-               " -> " (cdr e) ")"
-          #\newline) )
-       upgrade)
-      '("\nDo you want to replace the existing extensions?"))) )
+	 (cond ((assq (string->symbol (car e)) *override*) =>
+		(lambda (a)
+		  (unless (equal? (cadr a) (cdr e))
+		    (warning
+		     (sprintf "version `~a' of extension `~a' overrides required version `~a'"
+		       (cadr a) (car a) (cdr e))))
+		  #f))
+	       (else
+		(conc
+		 "  " (car e)
+		 " (" (let ((v (assq 'version (extension-information (car e))))) 
+			(if v (cadr v) "???"))
+		 " -> " (cdr e) ")"
+		 #\newline) )
+	       upgrade)
+	 '("\nDo you want to replace the existing extensions?"))) )))
+
+  (define (override-version egg)
+    (let ((name (string->symbol (if (pair? egg) (car egg) egg))))
+      (cond ((assq name *override*) =>
+	     (lambda (a)
+	       (when (and (pair? egg) (not (equal? (cadr a) (cdr egg))))
+		 (warning
+		  (sprintf "version `~a' of extension `~a' overrides explicitly given version `~a'"
+		    (cadr a) name (cdr egg))))
+	       (cadr a)))
+	    ((pair? egg) (cdr egg))
+	    (else #f))))
 
   (define (retrieve eggs)
     (print "retrieving ...")
@@ -323,9 +350,9 @@
                 ;; push to front
                 (set! *eggs+dirs+vers* (cons a (delete a *eggs+dirs+vers* eq?))) ) ]
              [else
-              (let ([name (if (pair? egg) (car egg) egg)]
-                    [version (and (pair? egg) (cdr egg))])
-                (let-values ([(dir ver) (try-default-sources name version)])
+              (let ((name (if (pair? egg) (car egg) egg))
+                    (version (override-version egg)))
+                (let-values (((dir ver) (try-default-sources name version)))
                   (unless dir (error "extension or version not found"))
                   (print " " name " located at " dir)
                   (set! *eggs+dirs+vers* (cons (list name dir ver) *eggs+dirs+vers*)) ) ) ] ) )
@@ -335,13 +362,13 @@
        (lambda (e+d+v)
          (unless (member (car e+d+v) *checked*)
            (set! *checked* (cons (car e+d+v) *checked*))
-           (let ([mfile (make-pathname (cadr e+d+v) (car e+d+v) "meta")])
+           (let ((mfile (make-pathname (cadr e+d+v) (car e+d+v) "meta")))
              (cond [(file-exists? mfile)
-                    (let ([meta (with-input-from-file mfile read)])
+                    (let ((meta (with-input-from-file mfile read)))
 		      (print "checking platform for `" (car e+d+v) "' ...")
 		      (check-platform (car e+d+v) meta)
                       (print "checking dependencies for `" (car e+d+v) "' ...")
-                      (let-values ([(missing upgrade) (outdated-dependencies meta)])
+                      (let-values (((missing upgrade) (outdated-dependencies meta)))
 			(set! missing (apply-mappings missing)) ;XXX only missing - wrong?
 			(set! *dependencies*
 			  (cons
@@ -627,6 +654,7 @@ usage: chicken-install [OPTION | EXTENSION[:VERSION]] ...
        -debug                   enable full display of error message information
        -keep-going              continue installation even if dependency fails
        -scan DIRECTORY          scan local directory for highest available egg versions
+       -override FILENAME       override versions for installed eggs with information from file
 EOF
 );|
     (exit code))
@@ -768,6 +796,10 @@ EOF
                         (unless (pair? (cdr args)) (usage 1))
 			(set! scan (cadr args))
 			(loop (cddr args) eggs))
+		       ((string=? "-override" arg)
+                        (unless (pair? (cdr args)) (usage 1))
+			(set! *override* (read-file (cadr args)))
+			(loop (cddr args) eggs))			
 		       ((string=? "-trunk" arg)
 			(set! *trunk* #t)
 			(loop (cdr args) eggs))
diff --git a/manual/Extensions b/manual/Extensions
index 67b81b5b..52cb3b07 100644
--- a/manual/Extensions
+++ b/manual/Extensions
@@ -568,6 +568,7 @@ Available options:
 ; {{-debug}} : print full call-trace when encountering errors in the setup script
 ; {{-keep-going}} : continue installation, even if a dependency fails
 ; {{-scan DIRECTORY}} : scan local egg source repository or highest available versions
+; {{-override FILENAME}} : override versions for installed eggs with information given in {{FILENAME}}, which can be generated by {{-scan}} or by the {{-list}} option of the {{chicken-status}} program
 
 {{chicken-install}} recognizes the {{http_proxy}} environment variable, if set.