From cc8a8a1a2d40e00c92d53c3a06c2191ebc6b2646 Mon Sep 17 00:00:00 2001 From: obicons Date: Mon, 30 Apr 2018 09:14:56 -0400 Subject: [PATCH 1/2] New feature: `uninstall` now accepts a key to indicate that all dependencies of a package should be removed if they are no longer required. Modified `uninstall` to support multiple system deletes at once. --- quicklisp/client.lisp | 50 +++++++++++++++++++++++++++++++++++++----- quicklisp/package.lisp | 4 +++- quicklisp/utils.lisp | 13 +++++++++++ 3 files changed, 61 insertions(+), 6 deletions(-) diff --git a/quicklisp/client.lisp b/quicklisp/client.lisp index 7b67834..9df2f1d 100644 --- a/quicklisp/client.lisp +++ b/quicklisp/client.lisp @@ -48,6 +48,9 @@ (defun system-list () (provided-systems t)) +(defun all-installed-systems () + (filter #'installedp (system-list))) + (defun update-dist (dist &key (prompt t)) (when (stringp dist) (setf dist (find-dist dist))) @@ -77,13 +80,50 @@ (defun help () "For help with Quicklisp, see http://www.quicklisp.org/beta/") -(defun uninstall (system-name) +(defun uninstall (systems &key remove-dependencies) + (unless (consp systems) + (setf systems (list systems))) + (dolist (system-name systems systems) + (let ((system (find-system system-name))) + (cond ((and system remove-dependencies) + (uninstall-system-dependencies system-name)) + (system + (ql-dist:uninstall system)) + (t + (warn "Unknown system ~S" system-name) + nil))))) + +(defun uninstall-system-dependencies (system-name) + "Uninstalls the dependencies of system-name." + (when (symbolp system-name) + (setf system-name (string-downcase (symbol-name system-name)))) (let ((system (find-system system-name))) - (cond (system - (ql-dist:uninstall system)) + (cond ((not system) + (warn "Unknown system ~S" system-name)) + ((not (installedp system)) + (warn "System ~S is not installed" system-name)) (t - (warn "Unknown system ~S" system-name) - nil)))) + ;; consider the set X of `system` dependencies + ;; if any piece of installed software depends on a member of this set + ;; and is not a member of X, then we cannot delete that member + (let* ((system-dependencies (remove-duplicates (mapcar #'name (flatten (dependency-tree system))) :test #'string=)) + (installed-systems (all-installed-systems)) + (all-other-dependencies + (remove-duplicates + (flatten (mapcar #'required-systems + (filter + #'(lambda (system) + (not (member (name system) + (cons system-name system-dependencies) + :test #'string=))) + installed-systems))) + :test #'string=))) + (dolist (system system-dependencies) + (unless (member system all-other-dependencies :test #'string=) + (format t "To uninstall: ~S~%" system) + (ql-dist:uninstall (find-system system)) + (finish-output))) + (ql-dist:uninstall system)))))) (defun uninstall-dist (name) (let ((dist (find-dist name))) diff --git a/quicklisp/package.lisp b/quicklisp/package.lisp index da68cd2..39d026c 100644 --- a/quicklisp/package.lisp +++ b/quicklisp/package.lisp @@ -16,7 +16,9 @@ #:file-size #:safely-read #:safely-read-file - #:make-versions-url)) + #:make-versions-url + #:filter + #:flatten)) (defpackage #:ql-setup (:documentation diff --git a/quicklisp/utils.lisp b/quicklisp/utils.lisp index 71a89ef..917cea9 100644 --- a/quicklisp/utils.lisp +++ b/quicklisp/utils.lisp @@ -122,3 +122,16 @@ http://foo/bar-versions.txt." (subseq url 0 suffix-pos) "-versions" extension)))) + +(defun filter (predicate list) + (loop for x in list + when (funcall predicate x) + collecting x)) + +(defun flatten (list) + (when list + (cond ((atom (car list)) + (cons (car list) (flatten (cdr list)))) + (t (append (flatten (car list)) + (flatten (cdr list))))))) + From fd805f8dc9ab01f174d95a4894b51cc4acb47309 Mon Sep 17 00:00:00 2001 From: obicons Date: Wed, 2 May 2018 11:43:03 -0400 Subject: [PATCH 2/2] * Refactored code to track releases better * General refactor to improve discoverability --- quicklisp/client.lisp | 81 ++++++++++++++++++++++++------------------ quicklisp/package.lisp | 1 - quicklisp/utils.lisp | 5 --- 3 files changed, 46 insertions(+), 41 deletions(-) diff --git a/quicklisp/client.lisp b/quicklisp/client.lisp index 9df2f1d..2f64c9d 100644 --- a/quicklisp/client.lisp +++ b/quicklisp/client.lisp @@ -49,7 +49,10 @@ (provided-systems t)) (defun all-installed-systems () - (filter #'installedp (system-list))) + (remove-if-not #'installedp (system-list))) + +(defun releases-included-by (system) + (mapcar #'release (flatten (dependency-tree system)))) (defun update-dist (dist &key (prompt t)) (when (stringp dist) @@ -80,50 +83,58 @@ (defun help () "For help with Quicklisp, see http://www.quicklisp.org/beta/") -(defun uninstall (systems &key remove-dependencies) +(defun uninstall (systems &key remove-dependencies (prompt t)) + "uninstalls the system(s) from quicklisp. + When remove-dependencies is specified, all dependencies of the system are also + removed when they are not required by another system. + You are prompted before uninstalling each dependency unless prompt is set to nil." (unless (consp systems) (setf systems (list systems))) - (dolist (system-name systems systems) - (let ((system (find-system system-name))) - (cond ((and system remove-dependencies) - (uninstall-system-dependencies system-name)) - (system - (ql-dist:uninstall system)) - (t - (warn "Unknown system ~S" system-name) - nil))))) - -(defun uninstall-system-dependencies (system-name) - "Uninstalls the dependencies of system-name." + (let ((uninstalled-systems nil)) + (dolist (system-name systems uninstalled-systems) + (let ((system (find-system system-name))) + (cond ((and system remove-dependencies) + (mapcar #'(lambda (sys) + (when (or (not prompt) (y-or-n-p "Uninstall ~S?~%" sys)) + (push sys uninstalled-systems) + (uninstall sys))) + (removable-system-dependencies system-name))) + (system + (ql-dist:uninstall system) + (push system uninstalled-systems)) + (t + (warn "Unknown system ~S" system-name) + nil)))))) + +(defun all-releases (ignore-set) + (apply #'append + (mapcar #'(lambda (system) + (releases-included-by system)) + (remove-if + #'(lambda (system) + (member (name (release system)) ignore-set :test #'string=)) + (all-installed-systems))))) + +(defun removable-system-dependencies (system-name) + "Returns a list of safely removable dependencies of system-name." (when (symbolp system-name) (setf system-name (string-downcase (symbol-name system-name)))) (let ((system (find-system system-name))) (cond ((not system) - (warn "Unknown system ~S" system-name)) + (warn "Unknown system ~S~%" system-name)) ((not (installedp system)) (warn "System ~S is not installed" system-name)) (t - ;; consider the set X of `system` dependencies - ;; if any piece of installed software depends on a member of this set - ;; and is not a member of X, then we cannot delete that member - (let* ((system-dependencies (remove-duplicates (mapcar #'name (flatten (dependency-tree system))) :test #'string=)) - (installed-systems (all-installed-systems)) + ;; consider the set X of system dependencies + ;; if any piece of installed software S depends on a member of X + ;; and is not itself a member of X, then we cannot delete S + (let* ((system-releases (mapcar #'name (releases-included-by system))) (all-other-dependencies - (remove-duplicates - (flatten (mapcar #'required-systems - (filter - #'(lambda (system) - (not (member (name system) - (cons system-name system-dependencies) - :test #'string=))) - installed-systems))) - :test #'string=))) - (dolist (system system-dependencies) - (unless (member system all-other-dependencies :test #'string=) - (format t "To uninstall: ~S~%" system) - (ql-dist:uninstall (find-system system)) - (finish-output))) - (ql-dist:uninstall system)))))) + (mapcar #'name (all-releases system-releases))) + (to-remove (list system-name))) + (dolist (release system-releases (remove-duplicates to-remove :test #'string=)) + (unless (member release all-other-dependencies :test #'string=) + (push release to-remove)))))))) (defun uninstall-dist (name) (let ((dist (find-dist name))) diff --git a/quicklisp/package.lisp b/quicklisp/package.lisp index 39d026c..69f7989 100644 --- a/quicklisp/package.lisp +++ b/quicklisp/package.lisp @@ -17,7 +17,6 @@ #:safely-read #:safely-read-file #:make-versions-url - #:filter #:flatten)) (defpackage #:ql-setup diff --git a/quicklisp/utils.lisp b/quicklisp/utils.lisp index 917cea9..87483f5 100644 --- a/quicklisp/utils.lisp +++ b/quicklisp/utils.lisp @@ -123,11 +123,6 @@ http://foo/bar-versions.txt." "-versions" extension)))) -(defun filter (predicate list) - (loop for x in list - when (funcall predicate x) - collecting x)) - (defun flatten (list) (when list (cond ((atom (car list))