~ chicken-core (chicken-5) e090c524b782e3bc982299b4c021a5fc96db36e4

commit e090c524b782e3bc982299b4c021a5fc96db36e4
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sat Jan 16 16:30:41 2016 +0100
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sun Jan 24 11:39:00 2016 +1300

    Do not reinstall satisfied deps in deploy mode
    
    This fixes #1106
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/NEWS b/NEWS
index ca5cdb37..401a1922 100644
--- a/NEWS
+++ b/NEWS
@@ -41,6 +41,9 @@
     basic source-level debugging of compiled Scheme code.
   - A statistical profiler has been added, enabling sampling-based
     runtime profiling of compiled programs.
+  - "chicken-install"
+    - When installing eggs in deploy mode, already satisfied
+      dependencies aren't reinstalled every time (#1106).
   - "chicken-uninstall"
     - -prefix and -deploy options were added, matching chicken-install.
   - "chicken-status"
diff --git a/chicken-install.scm b/chicken-install.scm
index bc23c9dd..033a2524 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -110,9 +110,15 @@
   (define *hacks* '())
 
   (define (repo-path)
-    (if (and *cross-chicken* (not *host-extension*))
-	(make-pathname C_TARGET_LIB_HOME (sprintf "chicken/~a" C_BINARY_VERSION))
-	(repository-path)))
+    (if *deploy*
+	*prefix*
+	(if (and *cross-chicken* (not *host-extension*))
+	    (make-pathname C_TARGET_LIB_HOME (sprintf "chicken/~a" C_BINARY_VERSION))
+	    (if *prefix*
+		(make-pathname
+		 *prefix*
+		 (sprintf "lib/chicken/~a" (##sys#fudge 42)))
+		(repository-path)))))
 
   (define (get-prefix #!optional runtime)
     (cond ((and *cross-chicken*
@@ -200,7 +206,7 @@
         '()))
 
   (define (init-repository dir)
-    (let ((src (repository-path))
+    (let ((src (get-prefix))
           (copy (if *windows-shell*
                     "copy"
                     "cp -r")))
@@ -217,7 +223,12 @@
 		 (or (member xs ##sys#core-library-modules)
 		     (member xs ##sys#core-syntax-modules))))
            (chicken-version) )
-          ((extension-information x) =>
+	  ;; Duplication of (extension-information) to get custom
+	  ;; prefix.  This should be fixed.
+          ((let* ((ep (##sys#canonicalize-extension-path x 'ext-version))
+		  (sf (make-pathname (repo-path) ep "setup-info")))
+	     (and (file-exists? sf)
+		  (with-input-from-file sf read))) =>
            (lambda (info)
              (let ((a (assq 'version info)))
                (if a
@@ -233,12 +244,9 @@
 
   (define (check-dependency dep)
     (cond ((or (symbol? dep) (string? dep))
-	   (values
-	    (if *deploy*
-		(->string dep)
-		(and (not (ext-version dep))
-		     (->string dep)))
-	    #f))
+	   (values (and (not (ext-version dep))
+			(->string dep))
+		   #f))
 	  ((and (list? dep) (eq? 'or (car dep)))
 	   (let scan ((ordeps (cdr dep)) (bestm #f) (bestu #f))
 	     (if (null? ordeps)
@@ -260,10 +268,8 @@
 	  ((and (list? dep) (= 2 (length dep))
 		(or (string? (car dep)) (symbol? (car dep))))
 	   (let ((v (ext-version (car dep))))
-	     (cond ((or *deploy* (not v))
-		    (values
-		     (->string (car dep))
-		     #f))
+	     (cond ((not v)
+		    (values (->string (car dep)) #f))
 		   ((not (version>=? v (->string (cadr dep))))
 		    (cond ((string=? "chicken" (->string (car dep)))
 			   (if *force*
@@ -675,7 +681,7 @@
         (remove-directory tmpdir))))
 
   (define (update-db)
-    (let* ((files (glob (make-pathname (repository-path) "*.import.*")))
+    (let* ((files (glob (make-pathname (repo-path) "*.import.*")))
            (tmpdir (create-temporary-directory))
            (dbfile (make-pathname tmpdir +module-db+))
            (rx (irregex ".*/([^/]+)\\.import\\.(scm|so)")))
@@ -709,7 +715,7 @@
         (with-output-to-file dbfile
           (lambda ()
             (for-each (lambda (x) (write x) (newline)) db)))
-        (copy-file dbfile (make-pathname (repository-path) +module-db+))
+        (copy-file dbfile (make-pathname (repo-path) +module-db+))
         (remove-directory tmpdir))))
 
   (define (apply-mappings eggs)
@@ -850,10 +856,11 @@ EOF
       (setup-proxy (get-environment-variable "http_proxy"))
       (let loop ((args args) (eggs '()))
         (cond ((null? args)
-               (cond ((and *deploy* (not *prefix*))
-		      (error 
-		       "`-deploy' only makes sense in combination with `-prefix DIRECTORY`"))
-		     (update (update-db))
+	       (when *deploy*
+		 (unless *prefix*
+		   (error
+		    "`-deploy' only makes sense in combination with `-prefix DIRECTORY`")))
+               (cond (update (update-db))
 		     (scan (scan-directory scan))
                      (else
 		      (let ((defaults (load-defaults)))
@@ -906,7 +913,7 @@ EOF
                             (string=? arg "--help"))
                         (usage 0))
                        ((string=? arg "-repository")
-                        (print (repository-path))
+                        (print (repo-path))
                         (exit 0))
                        ((string=? arg "-force")
                         (set! *force* #t)