131 lines
4.9 KiB
Common Lisp
131 lines
4.9 KiB
Common Lisp
;;;; client.lisp
|
|
|
|
(in-package #:quicklisp-client)
|
|
|
|
(defvar *quickload-verbose* nil
|
|
"When NIL, show terse output when quickloading a system. Otherwise,
|
|
show normal compile and load output.")
|
|
|
|
(defvar *quickload-prompt* nil
|
|
"When NIL, quickload systems without prompting for enter to
|
|
continue, otherwise proceed directly without user intervention.")
|
|
|
|
(defvar *quickload-explain* t)
|
|
|
|
(define-condition system-not-quickloadable (error)
|
|
((system
|
|
:initarg :system
|
|
:reader not-quickloadable-system)))
|
|
|
|
(defun maybe-silence (silent stream)
|
|
(or (and silent (make-broadcast-stream)) stream))
|
|
|
|
(defgeneric quickload (systems &key verbose silent prompt explain &allow-other-keys)
|
|
(:documentation
|
|
"Load SYSTEMS the quicklisp way. SYSTEMS is a designator for a list
|
|
of things to be loaded.")
|
|
(:method (systems &key
|
|
(prompt *quickload-prompt*)
|
|
(silent nil)
|
|
(verbose *quickload-verbose*) &allow-other-keys)
|
|
(let ((*standard-output* (maybe-silence silent *standard-output*))
|
|
(*trace-output* (maybe-silence silent *trace-output*)))
|
|
(unless (listp systems)
|
|
(setf systems (list systems)))
|
|
(dolist (thing systems systems)
|
|
(flet ((ql ()
|
|
(autoload-system-and-dependencies thing :prompt prompt)))
|
|
(if verbose
|
|
(ql)
|
|
(call-with-quiet-compilation #'ql)))))))
|
|
|
|
(defmethod quickload :around (systems &key verbose prompt explain
|
|
&allow-other-keys)
|
|
(declare (ignorable systems verbose prompt explain))
|
|
(with-consistent-dists
|
|
(call-next-method)))
|
|
|
|
(defun system-list ()
|
|
(provided-systems t))
|
|
|
|
(defun update-dist (dist &key (prompt t))
|
|
(when (stringp dist)
|
|
(setf dist (find-dist dist)))
|
|
(let ((new (available-update dist)))
|
|
(cond (new
|
|
(show-update-report dist new)
|
|
(when (or (not prompt) (press-enter-to-continue))
|
|
(update-in-place dist new)))
|
|
((not (subscribedp dist))
|
|
(format t "~&You are not subscribed to ~S."
|
|
(name dist)))
|
|
(t
|
|
(format t "~&You already have the latest version of ~S: ~A.~%"
|
|
(name dist)
|
|
(version dist))))))
|
|
|
|
(defun update-all-dists (&key (prompt t))
|
|
(let ((dists (remove-if-not 'subscribedp (all-dists))))
|
|
(format t "~&~D dist~:P to check.~%" (length dists))
|
|
(dolist (old dists)
|
|
(with-simple-restart (skip "Skip update of dist ~S" (name old))
|
|
(update-dist old :prompt prompt)))))
|
|
|
|
(defun available-dist-versions (name)
|
|
(available-versions (find-dist-or-lose name)))
|
|
|
|
(defun help ()
|
|
"For help with Quicklisp, see http://www.quicklisp.org/beta/")
|
|
|
|
(defun uninstall (system-name)
|
|
(let ((system (find-system system-name)))
|
|
(cond (system
|
|
(ql-dist:uninstall system))
|
|
(t
|
|
(warn "Unknown system ~S" system-name)
|
|
nil))))
|
|
|
|
(defun uninstall-dist (name)
|
|
(let ((dist (find-dist name)))
|
|
(when dist
|
|
(ql-dist:uninstall dist))))
|
|
|
|
(defun write-asdf-manifest-file (output-file &key (if-exists :rename-and-delete)
|
|
exclude-local-projects)
|
|
"Write a list of system file pathnames to OUTPUT-FILE, one per line,
|
|
in order of descending QL-DIST:PREFERENCE."
|
|
(when (or (eql output-file nil)
|
|
(eql output-file t))
|
|
(setf output-file (qmerge "manifest.txt")))
|
|
(with-open-file (stream output-file
|
|
:direction :output
|
|
:if-exists if-exists)
|
|
(unless exclude-local-projects
|
|
(register-local-projects)
|
|
(dolist (system-file (list-local-projects))
|
|
(let* ((enough (enough-namestring system-file output-file))
|
|
(native (native-namestring enough)))
|
|
(write-line native stream))))
|
|
(with-consistent-dists
|
|
(let ((systems (provided-systems t))
|
|
(already-seen (make-hash-table :test 'equal)))
|
|
(dolist (system (sort systems #'>
|
|
:key #'preference))
|
|
;; FIXME: find-asdf-system-file does another find-system
|
|
;; behind the scenes. Bogus. Should be a better way to go
|
|
;; from system object to system file.
|
|
(let* ((system-file (find-asdf-system-file (name system)))
|
|
(enough (and system-file (enough-namestring system-file
|
|
output-file)))
|
|
(native (and enough (native-namestring enough))))
|
|
(when (and native (not (gethash native already-seen)))
|
|
(setf (gethash native already-seen) native)
|
|
(format stream "~A~%" native)))))))
|
|
(probe-file output-file))
|
|
|
|
(defun where-is-system (name)
|
|
"Return the pathname to the source directory of ASDF system with the
|
|
given NAME, or NIL if no system by that name can be found known."
|
|
(let ((system (asdf:find-system name nil)))
|
|
(when system
|
|
(asdf:system-source-directory system))))
|