Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: a48ed2b35f
Fetching contributors…

Cannot retrieve contributors at this time

117 lines (104 sloc) 4.908 kb
;;;; dist-update.lisp
(in-package #:ql-dist)
(defgeneric available-update (dist)
(:documentation "If an update is available for DIST, return the
update as an uninstalled dist object. Otherwise, return NIL."))
(defgeneric update-release-differences (old-dist new-dist)
(:documentation "Compare OLD-DIST to NEW-DIST and return three lists
as multiple values: new releases \(present in NEW-DIST but not
OLD-DIST), changed releases \(present in both dists but different in
some way), and removed releases \(present in OLD-DIST but not
NEW-DIST). The list of changed releases is a list of two-element
lists, with each two-element list having first the old release
object and then the new release object."))
(defgeneric show-update-report (old-dist new-dist)
(:documentation "Display a description of the update from OLD-DIST
to NEW-DIST."))
(defgeneric update-in-place (old-dist new-dist)
(:documentation "Update OLD-DIST to NEW-DIST in place."))
(defmethod available-update ((dist dist))
(let ((url (distinfo-subscription-url dist))
(target (qmerge "tmp/distinfo-update/distinfo.txt")))
(when url
(ensure-directories-exist target)
(fetch url target :quietly t)
(let ((new (make-dist-from-file target)))
(setf (base-directory new) (directory-namestring target))
(when (and (string= (name dist) (name new))
(string/= (version dist) (version new)))
new)))))
(defmethod update-release-differences ((old-dist dist)
(new-dist dist))
(let ((old-releases (provided-releases old-dist))
(new-releases (provided-releases new-dist))
(new '())
(updated '())
(removed '())
(old-by-name (make-hash-table :test 'equalp)))
(dolist (release old-releases)
(setf (gethash (name release) old-by-name)
release))
(dolist (new-release new-releases)
(let* ((name (name new-release))
(old-release (gethash name old-by-name)))
(remhash name old-by-name)
(cond ((not old-release)
(push new-release new))
((not (equal (archive-content-sha1 new-release)
(archive-content-sha1 old-release)))
(push (list old-release new-release) updated)))))
(maphash (lambda (name old-release)
(declare (ignore name))
(push old-release removed))
old-by-name)
(values (nreverse new)
(nreverse updated)
(sort removed #'string< :key #'prefix))))
(defmethod show-update-report ((old-dist dist) (new-dist dist))
(multiple-value-bind (new updated removed)
(update-release-differences old-dist new-dist)
(format t "Changes from ~A ~A to ~A ~A:~%"
(name old-dist)
(version old-dist)
(name new-dist)
(version new-dist))
(when new
(format t "~& New projects:~%")
(format t "~{ ~A~%~}" (mapcar #'prefix new)))
(when updated
(format t "~% Updated projects:~%")
(loop for (old-release new-release) in updated
do (format t " ~A -> ~A~%"
(prefix old-release)
(prefix new-release))))
(when removed
(format t "~% Removed projects:~%")
(format t "~{ ~A~%~}" (mapcar #'prefix removed)))))
(defmethod update-in-place :after ((old-dist dist) (new-dist dist))
;; XXX Is this too nasty?
(clrhash asdf::*defined-systems*))
(defmethod update-in-place ((old-dist dist) (new-dist dist))
(flet ((remove-installed (type)
(let ((wild (merge-pathnames (make-pathname :directory
(list :relative
"installed"
type)
:name :wild
:type "txt")
(base-directory old-dist))))
(dolist (file (directory wild))
(delete-file file)))))
(let ((reinstall-releases (installed-releases old-dist)))
(remove-installed "systems")
(remove-installed "releases")
(delete-file-if-exists (relative-to old-dist "releases.txt"))
(delete-file-if-exists (relative-to old-dist "systems.txt"))
(replace-file (local-distinfo-file new-dist)
(local-distinfo-file old-dist))
(setf new-dist (find-dist (name new-dist)))
(dolist (old-release reinstall-releases)
(let* ((name (name old-release))
(new-release (find-release-in-dist name new-dist)))
(if new-release
(ensure-installed new-release)
(warn "~S is not available in ~A" name new-dist)))))))
Jump to Line
Something went wrong with that request. Please try again.