X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=contrib%2Fasdf-install%2Finstaller.lisp;h=3acb93a1c77736c1534232f2c7fa3f8e5fd49224;hb=bc19622c8c9b6af2635da30ed9c88665012d3361;hp=639fcdce72a64fdbd1a4cefbfaacd0bcf619e90c;hpb=d4e910b9a2851d52117c4c7fd9f847e5b54414a0;p=sbcl.git

diff --git a/contrib/asdf-install/installer.lisp b/contrib/asdf-install/installer.lisp
index 639fcdc..3acb93a 100644
--- a/contrib/asdf-install/installer.lisp
+++ b/contrib/asdf-install/installer.lisp
@@ -11,9 +11,9 @@
   (let ((path (pathname name)))
     (if (pathname-name path)
 	(merge-pathnames
-	 (make-pathname :directory `(:relative ,(pathname-name path))
-			:name "")
-	 path)
+	 (make-pathname :directory `(:relative ,(pathname-name path)))
+	 (make-pathname :directory (pathname-directory path)
+			:host (pathname-host path)))
 	path)))
 
 (defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME")))
@@ -99,7 +99,7 @@
 (defun url-port (url)
   (assert (string-equal url "http://" :end1 7))
   (let ((port-start (position #\: url :start 7)))
-    (if port-start (parse-integer url :start port-start :junk-allowed t) 80)))
+    (if port-start (parse-integer url :start (1+ port-start) :junk-allowed t) 80)))
 
 (defun url-connection (url)
   (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
@@ -109,7 +109,7 @@
     (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)))
+    (let ((stream (socket-make-stream s :input t :output t :buffering :full :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~%Host: ~A~%Cookie: CCLAN-SITE=~A~%~%"
@@ -150,11 +150,11 @@
 	(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)
+	(with-open-file (o file-name :direction :output :external-format :iso-8859-1)
 	  (if length
 	      (let ((buf (make-array length
 				     :element-type
-				     (stream-element-type stream)  )))
+				     (stream-element-type stream))))
 		(read-sequence buf stream)
 		(write-sequence buf o)) 
 	      (sb-executable:copy-stream stream o))))
@@ -163,7 +163,7 @@
       (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"
 	  nil)))))
 
 (defun read-until-eof (stream)
@@ -216,6 +216,7 @@
 	 (return))))))
 
 
+
 (defun verify-gpg-signature/url (url file-name)
   (destructuring-bind (response headers stream)
       (url-connection (concatenate 'string url ".asc"))
@@ -248,7 +249,8 @@
   (let* ((tar
 	  (with-output-to-string (o)
 	    (or
-	     (sb-ext:run-program "tar"
+	     (sb-ext:run-program #-darwin "tar"
+				 #+darwin "gnutar"
 				 (list "-C" (namestring source)
 				       "-xzvf" (namestring packagename))
 				 :output o
@@ -325,8 +327,24 @@
 			     (unless restart-p (return))))))))
 	     (one-iter packages)))
       (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*)))
-	(with-open-file (out p :direction :output)
+	(ensure-directories-exist p)
+	(with-open-file (out p :direction :output :if-exists :supersede)
 	  (with-standard-io-syntax
 	    (prin1 *trusted-uids* out))))
       (dolist (l *temporary-files*)
 	(when (probe-file l) (delete-file l))))))
+
+(defun uninstall (system &optional (prompt t))
+  (let* ((asd (asdf:system-definition-pathname system))
+	 (system (asdf:find-system system))
+	 (dir (asdf::pathname-sans-name+type
+	       (asdf::resolve-symlinks asd))))
+    (when (or (not prompt)
+	      (y-or-n-p
+	       "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?"
+	       system asd dir))
+      (delete-file asd)
+      (asdf:run-shell-command "rm -r ~A" (namestring dir)))))
+      
+;;; some day we will also do UPGRADE, but we need to sort out version
+;;; numbering a bit better first