Commit 3537989e authored by Eric Timmons's avatar Eric Timmons
Browse files

Fixup bundle update command

parent 380d677a
......@@ -24,11 +24,11 @@
:sources (clpmfile-sources clpmfile)
:requirements (clpmfile-all-requirements clpmfile)))
(defun build-lockfile (clpmfile &key local)
(defun build-lockfile (clpmfile &key localp)
"Given a clpmfile instance, make a lockfile context for it."
(let* ((lockfile (create-empty-lockfile clpmfile))
(lockfile-pathname (clpmfile-lockfile-pathname clpmfile)))
(unless local
(unless localp
(log:info "syncing sources")
(mapc #'sync-source (clpmfile-sources clpmfile)))
(log:info "Resolving requirements")
......@@ -38,25 +38,25 @@
(serialize-context-to-stream lockfile stream))
(defun load-lockfile (pathname &key local)
(defun load-lockfile (pathname &key localp)
(lambda (c)
(when (and (find-restart 'sync-and-retry) (not local))
(when (and (find-restart 'sync-and-retry) (not localp))
(log:info "Syncing source and retrying")
(invoke-restart 'sync-and-retry c)))))
(load-anonymous-context-from-pathname pathname)))
(defun bundle-install (clpmfile-designator &key local (validate (constantly t)))
(defun bundle-install (clpmfile-designator &key localp (validate (constantly t)))
"Given a clpmfile instance, install all releases from its lock file, creating
the lock file if necessary."
(let* ((clpmfile (get-clpmfile clpmfile-designator))
(lockfile-pathname (clpmfile-lockfile-pathname clpmfile))
(lockfile nil))
(if (probe-file lockfile-pathname)
(setf lockfile (load-lockfile lockfile-pathname :local local))
(setf lockfile (load-lockfile lockfile-pathname :localp localp))
(setf lockfile (create-empty-lockfile clpmfile)))
(unless local
(unless localp
(mapc #'sync-source (clpmfile-sources clpmfile)))
(setf lockfile (install-requirements (clpmfile-all-requirements clpmfile)
:context lockfile :validate validate))
......@@ -66,22 +66,32 @@ the lock file if necessary."
(serialize-context-to-stream lockfile stream))))
(defun bundle-update (clpmfile-designator &key
update-projects (validate (constantly t)))
update-projects (validate (constantly t))
(let* ((clpmfile (get-clpmfile clpmfile-designator))
(lockfile-pathname (clpmfile-lockfile-pathname clpmfile))
(lockfile nil))
(log:info "syncing sources")
(mapc #'sync-source (clpmfile-sources clpmfile))
(if (probe-file lockfile-pathname)
;; Load the existing lockfile
(setf lockfile (load-lockfile lockfile-pathname))
;; No lock file is present. Create an empty context.
(setf lockfile (create-empty-lockfile clpmfile)))
;; Resolve the requirements, allowing for updates.
(let* ((new-lockfile (resolve-requirements lockfile :update-projects (or update-projects t)))
(diff (context-diff lockfile new-lockfile)))
(when (funcall validate diff)
(mapc #'install-release (context-releases new-lockfile))
(with-open-file (stream lockfile-pathname
:direction :output :if-exists :supersede)
(serialize-context-to-stream new-lockfile stream))))))
(unless (probe-file lockfile-pathname)
;; There is no lock file currently. Just fall back to BUNDLE-INSTALL.
(return-from bundle-update
(bundle-install clpmfile :localp localp :validate validate)))
;; Load the existing lockfile
(setf lockfile (load-lockfile lockfile-pathname :localp localp))
(unless localp
(mapc #'sync-source (clpmfile-sources clpmfile)))
;; Map all update systems to their projects.
(dolist (system update-systems)
(when-let* ((system-release (find system (context-system-releases lockfile)
:key (compose #'system-name #'system-release-system)
:test #'equal))
(release (system-release-release system-release))
(project-name (project-name (release-project release))))
(pushnew project-name update-projects :test #'equal)))
(setf lockfile (install-requirements (clpmfile-all-requirements clpmfile)
:context lockfile :validate validate
:update-projects update-projects))
(with-open-file (stream lockfile-pathname
:direction :output
:if-exists :supersede)
(serialize-context-to-stream lockfile stream))))
......@@ -50,7 +50,7 @@ exist in the lock file.")
(define-cli-command (("bundle" "install") *bundle-install-ui*) (args options)
(let ((clpmfile-pathname (merge-pathnames (gethash :bundle-file options)
(bundle-install clpmfile-pathname :local (gethash :bundle-local options)
(bundle-install clpmfile-pathname :localp (gethash :bundle-local options)
:validate (make-validate-fun (gethash :yes options)
(gethash :output options)))
......@@ -8,7 +8,9 @@
(:import-from #:adopt))
......@@ -16,17 +18,48 @@
(define-string *help-string*
"Update a bundle described in a clpmfile. Can either update the whole bundle
or a subset.
If no clpmfile.lock file exists, one is created by first syncing all sources in
the clpmfile and using the requirements to resolve a set of project releases
that satisfy them all. All of the releases are then installed locally and the
lock file is written.
If a lock file does exist, all sources are synced and the requirements
re-resolved from scratch. If a list of systems to update is provided, then the
preference for unrelated projects is to keep them at the same version as
currently in the lock file. If no systems to update are provided then the
preference is to update everything to the latest version possible.")
(defparameter *bundle-update-ui*
:name "clpm bundle update"
:summary "Common Lisp Package Manager Bundle Update"
:usage "bundle update [options] <PROJECTS*>"
:help "Update a bundle"
:usage "bundle update [options] <SYSTEM>*"
:help *help-string*
:contents (list *group-common*
(defun make-validate-fun (yesp output)
(lambda (diff)
(format t "~S~%" (context-diff-to-plist diff))
(unless (equal output "sexp")
;; We can't print this in a sexp format at the moment.
(print-context-diff diff *standard-output*))
(or yesp (y-or-n-p "Proceed?"))))
(define-cli-command (("bundle" "update") *bundle-update-ui*) (args options)
(let ((clpmfile-pathname (merge-pathnames (gethash :bundle-file options)
(bundle-update clpmfile-pathname)
(localp (gethash :bundle-local options))
(yesp (gethash :yes options))
(output (gethash :output options)))
(bundle-update clpmfile-pathname :update-systems args
:localp localp
:validate (make-validate-fun yesp output))
......@@ -65,10 +65,10 @@
(defun install-requirements (reqs &key
(validate (constantly t))
(let* ((orig-context (get-context context))
(new-context (copy-context orig-context))
(update-projects nil))
(new-context (copy-context orig-context)))
(dolist (r reqs)
(context-add-requirement! new-context r))
(setf new-context (resolve-requirements new-context :update-projects update-projects))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment