ian/dotfiles
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

sbcl stuff

Browse source
This commit is contained in:
Ian Keane 2020-01-20 14:13:08 -05:00
parent 1d1dbc34df
commit 5d91dbb667
335 changed files with 119806 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

164
sbcl/.quicklisp/quicklisp/dist-update.lisp Normal file
View file

@ -0,0 +1,164 @@
;;;; 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"))
(update-directory (qmerge "tmp/distinfo-update/")))
(when (probe-directory update-directory)
(delete-directory-tree (qmerge "tmp/distinfo-update/")))
(when url
(ensure-directories-exist target)
(fetch url target :quietly t)
(let ((new (make-dist-from-file target)))
(setf (base-directory new)
(make-pathname :name nil
:type nil
:version nil
:defaults 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)))))
(defun clear-dist-systems (dist)
(dolist (system (provided-systems dist))
(asdf:clear-system (name system))))
(defmethod update-in-place :before ((old-dist dist) (new-dist dist))
;; Make sure ASDF will reload any systems at their new locations
(clear-dist-systems old-dist))
(defmethod update-in-place :after ((old-dist dist) (new-dist dist))
(clean new-dist))
(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"))
(delete-file-if-exists (relative-to old-dist "releases.cdb"))
(delete-file-if-exists (relative-to old-dist "systems.cdb"))
(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)))))))
(defun install-dist (url &key (prompt t) replace)
(block nil
(setf url (url url))
(let ((temp-file (qmerge "tmp/install-dist-distinfo.txt")))
(ensure-directories-exist temp-file)
(delete-file-if-exists temp-file)
(fetch url temp-file)
(let* ((new-dist (make-dist-from-file temp-file))
(old-dist (find-dist (name new-dist))))
(when old-dist
(if replace
(uninstall old-dist)
(restart-case
(error "A dist named ~S is already installed."
(name new-dist))
(replace ()
:report "Replace installed dist with new dist"
(uninstall old-dist)))))
(format t "Installing dist ~S version ~S.~%"
(name new-dist)
(version new-dist))
(when (or (not prompt)
(press-enter-to-continue))
(ensure-directories-exist (base-directory new-dist))
(copy-file temp-file (relative-to new-dist "distinfo.txt"))
(ensure-release-index-file new-dist)
(ensure-system-index-file new-dist)
(enable new-dist)
(setf (preference new-dist) (get-universal-time))
(when old-dist
(clear-dist-systems old-dist))
(clear-dist-systems new-dist)
new-dist)))))