ASDF-Install patch

Back to unCLog.

Index: defpackage.lisp
===================================================================
RCS file: /cvsroot/cclan/asdf-install/defpackage.lisp,v
retrieving revision 1.4
diff -u -w -u -r1.4 defpackage.lisp
Index: installer.lisp
===================================================================
RCS file: /cvsroot/cclan/asdf-install/installer.lisp,v
retrieving revision 1.14
diff -u -w -u -r1.14 installer.lisp
--- installer.lisp	20 Mar 2006 14:11:21 -0000	1.14
+++ installer.lisp	20 Mar 2006 16:42:17 -0000
@@ -176,13 +176,6 @@
 ;;;---------------------------------------------------------------------------
 ;;; Conditions.
 
-(define-condition shell-error (error)
-  ()
-  (:report (lambda (c s)
-             (declare (ignore c))
-             (format s "Call to GPG failed.  Perhaps GPG is not~
-installed or not in the path."))))
-
 (define-condition download-error (error)
   ((url :initarg :url :reader download-url)
    (response :initarg :response :reader download-response))
@@ -202,6 +195,13 @@
 	     (format s "GPG failed with error status:~%~S"
 		     (gpg-error-message c)))))
 
+(define-condition shell-error (error)
+  ()
+  (:report (lambda (c s)
+             (declare (ignore c))
+             (format s "Call to GPG failed. Perhaps GPG is not installed or not~
+ in the path."))))
+
 (define-condition no-signature (gpg-error) ())
 
 (define-condition key-not-found (gpg-error)
@@ -354,7 +354,6 @@
 	       (return-from got (list response headers stream)))
 	     (close stream)
 	     (setf url (cdr (assoc :LOCATION headers))))))
-      (with-open-stream (stream stream)
 	(when (>= response 400)
 	  (error 'download-error :url url :response response))
 	(let ((length (parse-integer (or (cdr (assoc :CONTENT-LENGTH headers)) "")
@@ -366,14 +365,19 @@
 	  (force-output)
 	  #+:clisp (setf (stream-element-type stream)
 			 '(unsigned-byte 8))
-	  (with-open-file (o file-name :direction :output
+        (with-open-file 
+          #-(and allegro-version>= (not (version>= 8 0)))
+          (o file-name :direction :output
 			     #+(or :clisp :digitool (and :lispworks :win32))
 			     :element-type
 			     #+(or :clisp :digitool (and :lispworks :win32))
 			     '(unsigned-byte 8)
-			     #+:sbcl #+:sbcl
-			     :external-format :latin1
+             #+:sbcl #+:sbcl :external-format :latin1
 			     :if-exists :supersede)
+          ;; for Allegro  versions  < 8.0,  the above  #+sbcl #+sbcl
+          ;; will cause an error [2006/01/09:rpg]
+          #+(and allegro-version>= (not (version>= 8 0)))
+          (o file-name :direction :output :if-exists :supersede)
 	    #+(or :cmu :digitool)
 	    (copy-stream stream o)
 	    #-(or :cmu :digitool)
@@ -384,12 +388,13 @@
 		  #-:clisp (read-sequence buf stream)
 		  #+:clisp (ext:read-byte-sequence buf stream :no-hang nil)
 		  (write-sequence buf o))
-		(copy-stream stream o)))))
+            (copy-stream stream o))))
+      (close stream)
       (terpri)
       (restart-case 
 	  (verify-gpg-signature/url url file-name)
 	(skip-gpg-check (&rest rest)
-	                :report "Don't ckeck GPG signature for this package"
+	                :report "Don't check GPG signature for this package"
                         (declare (ignore rest))
 	                nil)))))
 
@@ -416,6 +421,7 @@
 			      data) tags)))
       (ignore-errors
         (close gpg-stream)))
+    ;; test that command returned something 
     (unless tags
       (error 'shell-error))
     ;; test for obvious key/sig problems
@@ -553,7 +559,6 @@
             (symlink-files sysfile target))
 	  collect sysfile)))
 
-
 (defun temp-file-name (p)
   (let* ((pos-slash (position #\/ p :from-end t))
 	 (pos-dot (position #\. p :start (or pos-slash 0))))
@@ -568,11 +573,13 @@
 ;;; This is the external entry point.
 
 (defun install (&rest packages)
-  (let ((*temporary-files* nil)
+  (let* ((*temporary-files* nil)
+         (trusted-uid-file 
+          (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*))
 	(*trusted-uids*
-	 (let ((p (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*)))
-	   (when (probe-file p)
-	     (with-open-file (f p) (read f)))))
+          (when (probe-file trusted-uid-file)
+            (with-open-file (f trusted-uid-file) (read f))))
+         (old-uids (copy-list *trusted-uids*))
         ;; (installed-packages nil)
         )
     (unwind-protect
@@ -591,14 +598,17 @@
                                        (setf p tmp))
                                   end
                                   do (installer-msg t "Installing ~A in ~A, ~A"
-                                                    p
-                                                    source
-                                                    system)
-                                  append (install-package source
-                                                          system
-                                                          p)))
+                                                  p source system)
+                                append (install-package source system p)))
                            )
-                     (dolist (sysfile installed-package-sysfiles)
+                     (declare (ignore installed-package-sysfiles))
+                     (dolist
+                       ;; 20 Mar 2006
+                       ;; only install the packages we asked for
+                       (package packages) 
+                       #+old-asdf-behavior
+                       ;; install every package we downloaded
+                       (sysfile installed-package-sysfiles)
                        (handler-bind
                            (
                            #+asdf
@@ -629,23 +639,37 @@
                          (loop (multiple-value-bind (ret restart-p)
                                    (with-simple-restart
                                        (retry "Retry installation")
-                                     (load-system-definition sysfile))
+                                                      (load-package package))
                                  (declare (ignore ret))
                                  (unless restart-p (return))))
                          ))))
                    )
             (one-iter packages)))
-      (let ((p (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*)))
-        (when (probe-file p)
-	  (with-open-file (out p
+      
+      ;; cleanup
+      (unless (equal old-uids *trusted-uids*)
+        (let ((create-file-p nil))
+	  (unless (probe-file trusted-uid-file)
+	    (installer-msg t "Trusted UID file ~A does not exist"
+			   (namestring trusted-uid-file))
+	    (setf create-file-p
+		  (y-or-n-p "Do you want to create the file?")))
+          (when (or create-file-p (probe-file trusted-uid-file))
+	    (with-open-file (out trusted-uid-file
                                :direction :output
                                :if-exists :supersede)
 	    (with-standard-io-syntax
-	      (prin1 *trusted-uids* out)))))
+	        (prin1 *trusted-uids* out))))))
+      
       (dolist (l *temporary-files* t)
 	(when (probe-file l) (delete-file l))))))
 
 
+(defun load-package (package)
+  #+asdf
+  (asdf:operate 'asdf:load-op package))
+
+#+Old
 (defun load-system-definition (sysfile)
   (declare (type pathname sysfile))
   #+asdf
Index: load-asdf-install.lisp
===================================================================
RCS file: /cvsroot/cclan/asdf-install/load-asdf-install.lisp,v
retrieving revision 1.1
diff -u -w -u -r1.1 load-asdf-install.lisp
Index: port.lisp
===================================================================
RCS file: /cvsroot/cclan/asdf-install/port.lisp,v
retrieving revision 1.9
diff -u -w -u -r1.9 port.lisp
--- port.lisp	18 Oct 2005 11:58:33 -0000	1.9
+++ port.lisp	20 Mar 2006 16:42:18 -0000
@@ -106,10 +106,12 @@
      s (car (sb-bsd-sockets:host-ent-addresses
              (sb-bsd-sockets:get-host-by-name (url-host url))))
      (url-port url))
-    (sb-bsd-sockets:socket-make-stream s
+    (sb-bsd-sockets:socket-make-stream 
+     s
                                        :input t
                                        :output t
-                                       :buffering :full))
+     :buffering :full
+     :external-format :iso-8859-1))
   #+:cmu
   (sys:make-fd-stream (ext:connect-to-inet-socket (url-host url) (url-port url))
                       :input t :output t :buffering :full)
Index: split-sequence.lisp
===================================================================
RCS file: /cvsroot/cclan/asdf-install/split-sequence.lisp,v
retrieving revision 1.2
diff -u -w -u -r1.2 split-sequence.lisp
--- split-sequence.lisp	20 Mar 2006 14:11:21 -0000	1.2
+++ split-sequence.lisp	20 Mar 2006 16:42:18 -0000
@@ -55,7 +55,7 @@
   (:nicknames #:partition)
   (:export #:split-sequence #:split-sequence-if #:split-sequence-if-not
 	   #:partition #:partition-if #:partition-if-not)
-  (:documentation "the split-sequence package provides functionality for common lisp sequences analagous to perl's split operator."))
+  (:documentation "the SPLIT-SEQUENCE package provides functionality for common lisp sequences analagous to perl's split operator."))
 
 (in-package #:split-sequence)