~ chicken-core (chicken-5) 177058d4e996111cd5d1b7d2815233f298a46b23

commit 177058d4e996111cd5d1b7d2815233f298a46b23
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Apr 26 11:56:42 2013 +0200
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sun Apr 28 20:43:14 2013 +0200

    when trying all available sources for egg-download, do not invalidate list-entries on failure for "local" transport. This allows using local egg-trees as "overlay" repositories. Hetwork-based transports are still invalidated once a download failed, as it is assumed that the network access is down (or timing out). This patch also fixes a bug in the handling of "local" transport, which didn't test whether the egg directory acutally existed.
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/chicken-install.scm b/chicken-install.scm
index 1ba5b978..4283d038 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -196,9 +196,6 @@
            (transport ,*default-transport*)))
         *default-sources* ) )
 
-  (define (invalidate-default-source! def)
-    (set! *default-sources* (delete def *default-sources* eq?)) )
-
   (define (deps key meta)
     (or (and-let* ((d (assq key meta)))
           (cdr d))
@@ -337,26 +334,30 @@
        (abort e) ] ) )
 
   (define (with-default-sources proc)
-    (let trying-sources ([defs (known-default-sources)])
-      (if (null? defs)
-          (proc #f #f
-                (lambda ()
-                  (with-output-to-port (current-error-port)
-                    (lambda ()
-                      (print "Could not determine a source of extensions. "
-                             "Please, specify a location and a transport for "
-                             "a source.")))
-                  (exit 1)))
-          (let* ([def (car defs)]
-                 [locn (resolve-location
-			(cadr (or (assq 'location def)
-				  (error "missing location entry" def))))]
-                 [trans (cadr (or (assq 'transport def)
-                                  (error "missing transport entry" def)))])
-	    (proc trans locn
+    (let ((sources (known-default-sources)))
+      (let trying-sources ((defs sources))
+	(if (null? defs)
+	    (proc #f #f
 		  (lambda ()
-                    (invalidate-default-source! def)
-                    (trying-sources (cdr defs)) ) ) ) ) ) )
+		    (with-output-to-port (current-error-port)
+		      (lambda ()
+			(print "Could not determine a source of extensions. "
+			       "Please specify a valid location and transport.")))
+		    (exit 1)))
+	    (let ((def (car defs)))
+	      (if def
+		  (let* ((locn (resolve-location
+				(cadr (or (assq 'location def)
+					  (error "missing location entry" def)))))
+			 (trans (cadr (or (assq 'transport def)
+					  (error "missing transport entry" def)))))
+		    (proc trans locn
+			  (lambda ()
+			    (unless (eq? 'local trans)
+			      ;; invalidate this entry in the list of sources
+			      (set-car! defs #f))
+			    (trying-sources (cdr defs)))))
+		  (trying-sources (cdr defs))))))))
 
   (define (try-default-sources name version)
     (with-default-sources
diff --git a/setup-download.scm b/setup-download.scm
index 30934c4b..06c040bf 100644
--- a/setup-download.scm
+++ b/setup-download.scm
@@ -106,7 +106,9 @@
 			   (if (and (file-exists? trunkdir) (directory? trunkdir))
 			       (values trunkdir "trunk")
 			       (values eggdir "") ) ) ) ) )
-	(cond (dest
+	(cond ((or (not (file-exists? eggdir)) (not (directory? eggdir)))
+	       (values #f ""))
+	      (dest
 	       (create-directory dest)
 	       (let ((qdest (qs (normalize-pathname dest)))
 		     (qsrc (qs (normalize-pathname src)))