X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf-install%2Finstaller.lisp;h=db89bf4463ad9b8c1fb6fe16c8340c34fe60e974;hb=3eb0a28fe6a7912d6ff2b97221325c0e3bfc5703;hp=3672523fdba6cc57fbb1de1bb6a2ab2b47b13761;hpb=7f55cdab81d65acd8e7a4acf0f614b4b25f866fd;p=sbcl.git

diff --git a/contrib/asdf-install/installer.lisp b/contrib/asdf-install/installer.lisp
index 3672523..db89bf4 100644
--- a/contrib/asdf-install/installer.lisp
+++ b/contrib/asdf-install/installer.lisp
@@ -23,19 +23,6 @@
 
 (defparameter *trusted-uids* nil)
 
-
-(defun verify-gpg-signatures-p (url)
-  (labels ((prefixp (prefix string)
-             (let ((m (mismatch prefix string)))
-               (or (not m) (>= m (length prefix))))))
-    (case *verify-gpg-signatures*
-      (nil nil)
-      (:unknown-locations
-       (notany
-        (lambda (x) (prefixp x url))
-        (cons *cclan-mirror* *safe-url-prefixes*)))
-      (t t))))
-
 (defvar *locations*
   `((,(merge-pathnames "site/" *sbcl-home*)
      ,(merge-pathnames "site-systems/" *sbcl-home*)
@@ -66,7 +53,7 @@
 (define-condition gpg-error (error)
   ((message :initarg :message :reader gpg-error-message))
   (:report (lambda (c s)
-             (format t "GPG failed with error status:~%~S"
+             (format s "GPG failed with error status:~%~S"
                      (gpg-error-message c)))))
 
 (define-condition no-signature (gpg-error) ())
@@ -119,7 +106,8 @@
           (socket-connect
            s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url)))))
            (url-port (or  *proxy* url)))
-          (let ((stream (socket-make-stream s :input t :output t :buffering :full :external-format :iso-8859-1)))
+          (let ((stream (socket-make-stream s :input t :output t :buffering :full
+                                            :element-type :default :external-format :iso-8859-1)))
             ;; we are exceedingly unportable about proper line-endings here.
             ;; Anyone wishing to run this under non-SBCL should take especial care
             (format stream "GET ~A HTTP/1.0~c~%~
@@ -146,6 +134,13 @@
                  (socket-open-p s))
         (socket-close s)))))
 
+
+(defun copy-stream (in out)
+  (let ((buf (make-array 8192 :element-type (stream-element-type in))))
+    (loop for pos = (read-sequence buf in)
+          until (zerop pos)
+          do (write-sequence buf out :end pos))))
+
 (defun download-files-for-package (package-name-or-url file-name)
   (let ((url
          (if (= (mismatch package-name-or-url "http://") 7)
@@ -168,25 +163,24 @@
         (format t "Downloading ~A bytes from ~A ..."
                 (if length length "some unknown number of") url)
         (force-output)
-        (with-open-file (o file-name :direction :output :external-format :iso-8859-1)
+        (with-open-file (out file-name :direction :output
+                             :element-type '(unsigned-byte 8))
           (if length
-              (let ((buf (make-array length
-                                     :element-type
-                                     (stream-element-type stream))))
+              (let ((buf (make-array length :element-type '(unsigned-byte 8))))
                 (read-sequence buf stream)
-                (write-sequence buf o))
-              (sb-executable:copy-stream stream o))))
+                (write-sequence buf out))
+              (copy-stream stream out))))
       (close stream)
       (terpri)
       (restart-case
           (verify-gpg-signature/url url file-name)
-        (skip-gpg-check (&rest rest)
+        (skip-gpg-check ()
           :report "Don't check GPG signature for this package"
           nil)))))
 
 (defun read-until-eof (stream)
   (with-output-to-string (o)
-    (sb-executable:copy-stream stream o)))
+    (copy-stream stream o)))
 
 (defun verify-gpg-signature/string (string file-name)
   (let* ((proc
@@ -197,13 +191,13 @@
             (namestring file-name))
            :output :stream :error :stream :search t
            :input (make-string-input-stream string) :wait t))
-         (ret (process-exit-code proc))
          (err (read-until-eof (process-error proc)))
          tags)
     (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)
+               (declare (ignore _))
                (pushnew (cons (intern tag :keyword)
                               data) tags)))
     ;; test for obvious key/sig problems
@@ -228,7 +222,7 @@
                    (error 'author-not-trusted
                           :key-user-name name
                           :key-id id :gpg-err nil))
-             (add-key (&rest rest)
+             (add-key ()
                :report "Add to package supplier list"
                (pushnew (list id name) *trusted-uids*)))
          (return))))))
@@ -262,8 +256,8 @@
 
 (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 )
+  (ensure-directories-exist source)
+    (ensure-directories-exist system)
   (let* ((tar
           (with-output-to-string (o)
             (or
@@ -291,6 +285,7 @@
                             system)))
                (when (probe-file target)
                  (sb-posix:unlink target))
+               #-win32
                (sb-posix:symlink asd target))
           collect (pathname-name asd))))
 
@@ -313,6 +308,7 @@
              (with-open-file (f p) (read f))))))
     (unwind-protect
          (destructuring-bind (source system name) (where)
+           (declare (ignore name))
            (labels ((one-iter (packages)
                       (dolist (asd
                                 (loop for p in (mapcar 'string packages)
@@ -342,6 +338,7 @@
                                (with-simple-restart
                                    (retry "Retry installation")
                                  (asdf:operate 'asdf:load-op asd))
+                             (declare (ignore ret))
                              (unless restart-p (return))))))))
              (one-iter packages)))
       (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*)))