0.8.6.18:

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

diff --git a/contrib/asdf-install/installer.lisp b/contrib/asdf-install/installer.lisp
index 639fcdc..656c913 100644 (file)
--- a/contrib/asdf-install/installer.lisp
+++ b/contrib/asdf-install/installer.lisp
@@ -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))
@@ -216,6 +216,7 @@
         (return))))))
 
 
+
 (defun verify-gpg-signature/url (url file-name)
   (destructuring-bind (response headers stream)
       (url-connection (concatenate 'string url ".asc"))
@@ -325,8 +326,24 @@
                             (unless restart-p (return))))))))
             (one-iter packages)))
       (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*)))
+       (ensure-directories-exist p)
        (with-open-file (out p :direction :output)
          (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