sb-bsd-sockets: Add a test for interruptible I/O

[sbcl.git] / contrib / asdf-install / installer.lisp

diff --git a/contrib/asdf-install/installer.lisp b/contrib/asdf-install/installer.lisp
index db89bf4..5d76644 100644 (file)
--- a/contrib/asdf-install/installer.lisp
+++ b/contrib/asdf-install/installer.lisp
@@ -2,8 +2,9 @@
 
 (defvar *proxy* (posix-getenv "http_proxy"))
 (defvar *cclan-mirror*
-  (or (posix-getenv "CCLAN_MIRROR")
-      "http://ftp.linux.org.uk/pub/lisp/cclan/"))
+  (let ((mirror (posix-getenv "CCLAN_MIRROR")))
+    (or (and (not (string= mirror "")) mirror)
+        "http://ftp.linux.org.uk/pub/lisp/cclan/")))
 
 (defun directorify (name)
   ;; input name may or may not have a training #\/, but we know we
@@ -13,7 +14,8 @@
         (merge-pathnames
          (make-pathname :directory `(:relative ,(pathname-name path)))
          (make-pathname :directory (pathname-directory path)
-                        :host (pathname-host path)))
+                        :host (pathname-host path)
+                        :device (pathname-device path)))
         path)))
 
 (defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME")))
@@ -31,11 +33,13 @@
      ,(merge-pathnames "systems/" *dot-sbcl*)
      "Personal installation")))
 
-(let* ((*package* (find-package :asdf-install-customize))
-       (file (probe-file (merge-pathnames
-                          (make-pathname :name ".asdf-install")
-                          (user-homedir-pathname)))))
-  (when file (load file)))
+(unless (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
+  ;; Not during build, thanks.
+  (let* ((*package* (find-package :asdf-install-customize))
+         (file (probe-file (merge-pathnames
+                            (make-pathname :name ".asdf-install")
+                            (user-homedir-pathname)))))
+    (when file (load file))))
 
 (define-condition download-error (error)
   ((url :initarg :url :reader download-url)
@@ -136,7 +140,7 @@
 
 
 (defun copy-stream (in out)
-  (let ((buf (make-array 8192 :element-type (stream-element-type in))))
+  (let ((buf (make-array 8192 :element-type (stream-element-type out))))
     (loop for pos = (read-sequence buf in)
           until (zerop pos)
           do (write-sequence buf out :end pos))))
@@ -196,7 +200,7 @@
     (loop for l = (read-line (process-output proc) nil nil)
           while l
           when (> (mismatch l "[GNUPG:]") 6)
-          do (destructuring-bind (_ tag &rest data) (asdf::split l)
+          do (destructuring-bind (_ tag &rest data) (asdf::split-string l)
                (declare (ignore _))
                (pushnew (cons (intern tag :keyword)
                               data) tags)))
@@ -254,29 +258,50 @@
     (when (> response 0)
       (elt *locations* (1- response)))))
 
+(defparameter *tar-program*
+  ;; Please do not "clean this up" by using a bunch of #+'s and one
+  ;; #-. When the conditional is written this way, adding a new
+  ;; special case only involves one change. If #- is used, two changes
+  ;; are needed. -- JES, 2007-02-12
+  (progn
+    "tar"
+    #+darwin "gnutar"
+    #+(or sunos netbsd) "gtar"))
+
+(defun get-tar-directory (packagename)
+  (let* ((tar (with-output-to-string (o)
+                (or
+                 (sb-ext:run-program *tar-program*
+                                     (list "-tzf" (namestring packagename))
+                                     :output o
+                                     :search t
+                                     :wait t)
+                 (error "can't list archive"))))
+         (first-line (subseq tar 0 (position #\newline tar))))
+    (if (find #\/ first-line)
+        (subseq first-line 0 (position #\/ first-line))
+        first-line)))
+
+(defun untar-package (source packagename)
+  (with-output-to-string (o)
+    (or
+     (sb-ext:run-program *tar-program*
+                         (list "-C" (namestring source)
+                               "-xzvf" (namestring packagename))
+                         :output o
+                         :search t
+                         :wait t)
+     (error "can't untar"))))
+
 (defun install-package (source system packagename)
   "Returns a list of asdf system names for installed asdf systems"
   (ensure-directories-exist source)
-    (ensure-directories-exist system)
-  (let* ((tar
-          (with-output-to-string (o)
-            (or
-             (sb-ext:run-program #-darwin "tar"
-                                 #+darwin "gnutar"
-                                 (list "-C" (namestring source)
-                                       "-xzvf" (namestring packagename))
-                                 :output o
-                                 :search t
-                                 :wait t)
-             (error "can't untar"))))
-         (dummy (princ tar))
-         (pos-slash (position #\/ tar))
+  (ensure-directories-exist system)
+  (let* ((tdir (get-tar-directory packagename))
          (*default-pathname-defaults*
-          (merge-pathnames
-           (make-pathname :directory
-                          `(:relative ,(subseq tar 0 pos-slash)))
-           source)))
-    (declare (ignore dummy))
+          (merge-pathnames (make-pathname :directory `(:relative ,tdir))
+                           source)))
+    (princ (untar-package source packagename))
     (loop for asd in (directory
                       (make-pathname :name :wild :type "asd"))
           do (let ((target (merge-pathnames