Commit 6c501be1 authored by Eric Timmons's avatar Eric Timmons
Browse files

Document and improve bundle install

parent 06d1a4d8
......@@ -5,6 +5,7 @@
(uiop:define-package #:clpm/bundle
(:use #:cl
#:alexandria
#:clpm/clpmfile
#:clpm/context
#:clpm/install
......@@ -23,12 +24,13 @@
:sources (clpmfile-sources clpmfile)
:requirements (clpmfile-all-requirements clpmfile)))
(defun build-lockfile (clpmfile)
(defun build-lockfile (clpmfile &key local)
"Given a clpmfile instance, make a lockfile context for it."
(let* ((lockfile (create-empty-lockfile clpmfile))
(lockfile-pathname (clpmfile-lockfile-pathname clpmfile)))
(log:info "syncing sources")
(mapc #'sync-source (clpmfile-sources clpmfile))
(unless local
(log:info "syncing sources")
(mapc #'sync-source (clpmfile-sources clpmfile)))
(log:info "Resolving requirements")
(setf lockfile (resolve-requirements lockfile))
(with-open-file (stream lockfile-pathname
......@@ -36,25 +38,32 @@
(serialize-context-to-stream lockfile stream))
lockfile))
(defun load-lockfile (pathname)
(defun load-lockfile (pathname &key local)
(handler-bind
((source-no-such-object
(lambda (c)
(when (find-restart 'sync-and-retry)
(when (and (find-restart 'sync-and-retry) (not local))
(log:info "Syncing source and retrying")
(invoke-restart 'sync-and-retry c)))))
(load-anonymous-context-from-pathname pathname)))
(defun bundle-install (clpmfile-designator)
(defun bundle-install (clpmfile-designator &key local (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))
(setf lockfile (build-lockfile clpmfile)))
(mapc #'install-release (context-releases lockfile))))
(setf lockfile (load-lockfile lockfile-pathname :local local))
(setf lockfile (create-empty-lockfile clpmfile)))
(unless local
(mapc #'sync-source (clpmfile-sources clpmfile)))
(setf lockfile (install-requirements (clpmfile-all-requirements clpmfile)
:context lockfile :validate validate))
(with-open-file (stream lockfile-pathname
:direction :output
:if-exists :supersede)
(serialize-context-to-stream lockfile stream))))
(defun bundle-update (clpmfile-designator &key
update-projects (validate (constantly t)))
......
......@@ -12,7 +12,8 @@
#:clpm/utils)
(:import-from #:adopt)
(:import-from #:cl-ppcre)
(:export #:*group-bundle*))
(:export #:*group-bundle*
#:*option-bundle-local*))
(in-package #:clpm/cli/bundle/common)
......@@ -25,6 +26,13 @@
:help "The path to the clpmfile"
:reduce #'adopt:last))
(defparameter *option-bundle-local*
(adopt:make-option
:bundle-local
:long "local"
:help "Do not sync remote sources, use only the data located in the local cache"
:reduce (constantly t)))
(defparameter *group-bundle*
(adopt:make-group
:bundle
......
......@@ -8,7 +8,9 @@
#:clpm/bundle
#:clpm/cli/bundle/common
#:clpm/cli/common-args
#:clpm/cli/defs
#:clpm/cli/subcommands
#:clpm/context
#:clpm/log)
(:import-from #:adopt))
......@@ -16,17 +18,39 @@
(setup-logger)
(define-string *help-string*
"Install a bundle described in a clpmfile.
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, but preference is given to installing the releases that already
exist in the lock file.")
(defparameter *bundle-install-ui*
(adopt:make-interface
:name "clpm bundle install"
:summary "Common Lisp Package Manager Bundle Install"
:usage "bundle install [options]"
:help "Install a bundle"
:help *help-string*
:contents (list *group-common*
*group-bundle*)))
*group-bundle*
*option-bundle-local*)))
(defun make-validate-fun (yes-p output)
(lambda (diff)
(unless (equal output "sexp")
;; We can't print this in a sexp format at the moment.
(print-context-diff diff *standard-output*))
(or yes-p (y-or-n-p "Proceed?"))))
(define-cli-command (("bundle" "install") *bundle-install-ui*) (args options)
(let ((clpmfile-pathname (merge-pathnames (gethash :bundle-file options)
(uiop:getcwd))))
(bundle-install clpmfile-pathname)
(bundle-install clpmfile-pathname :local (gethash :bundle-local options)
:validate (make-validate-fun (gethash :yes options)
(gethash :output options)))
t))
......@@ -11,6 +11,7 @@
#:*option-context*
#:*option-help*
#:*option-output*
#:*option-yes*
#:*option-verbose*))
(in-package #:clpm/cli/common-args)
......@@ -21,6 +22,14 @@
:help "Display help and exit"
:reduce (constantly t)))
(defparameter *option-yes*
(adopt:make-option
:yes
:short #\y
:long "yes"
:help "Answer yes to all questions"
:reduce (constantly t)))
(defparameter *option-verbose*
(adopt:make-option :verbose
:long "verbose"
......
......@@ -53,14 +53,6 @@
:help "Install a project instead of a system"
:reduce (constantly t)))
(defparameter *option-install-yes*
(adopt:make-option
:install-yes
:short #\y
:long "yes"
:help "Answer yes to all questions"
:reduce (constantly t)))
(defparameter *option-install-no-deps*
(adopt:make-option
:install-no-deps
......@@ -107,7 +99,7 @@
*option-install-source*
*option-install-project*
*option-install-no-deps*
*option-install-yes*
*option-yes*
*option-install-branch*
*option-install-tag*
*option-install-commit*
......@@ -129,7 +121,7 @@
(no-deps-p (gethash :install-no-deps options))
(context-name (or (gethash :context options)
"default"))
(yes-p (gethash :install-yes options))
(yes-p (gethash :yes options))
(commit (gethash :install-commit options))
(branch (gethash :install-branch options))
(tag (gethash :install-tag options))
......@@ -152,7 +144,8 @@
:commit commit
:branch branch
:tag tag
:validate (make-validate-fun yes-p output))))
:validate (make-validate-fun yes-p output)
:save-context-p t)))
(when (equal output "sexp")
(uiop:with-safe-io-syntax ()
(prin1 (context-asd-pathnames updated-context)))))
......
......@@ -99,7 +99,8 @@
(and (ecase type
(:project (or (typep req 'project-requirement)
(typep req 'vcs-project-requirement)))
(:system (typep req 'system-requirement)))
(:system (typep req 'system-requirement))
(:asd-system (typep req 'fs-system-requirement)))
(equal name (requirement/name req))))
(context-requirements context)))
......@@ -188,8 +189,8 @@ in place with the same name. Return the new requirement if it was modified."
(added-releases (set-difference new-releases old-releases))
(removed-releases (set-difference old-releases new-releases)))
(make-instance 'context-diff
:added-releases added-releases
:removed-releases removed-releases)))
:added-releases (remove 'fs-release added-releases :key #'type-of)
:removed-releases (remove 'fs-release removed-releases :key #'type-of))))
(defun context-diff-has-diff-p (diff)
(or (context-diff-added-releases diff)
......@@ -268,7 +269,11 @@ in place with the same name. Return the new requirement if it was modified."
(defun print-context-diff (diff stream)
;; Compute the maximum project length.
(flet ((max-length (list &key (key 'identity))
(reduce #'max list :key (compose 'length key)
(reduce #'max list :key (compose (lambda (x)
(if (stringp x)
(length x)
(length (format nil "~A" x))))
key)
:initial-value 0)))
(let* ((plist (context-diff-to-plist diff :stringify-commits-p t))
(max-name-length (max (length "Project")
......
......@@ -14,13 +14,13 @@
#:clpm/source
#:clpm/version-strings)
(:export #:install
#:install-release))
#:install-release
#:install-requirements))
(in-package #:clpm/install)
(setup-logger)
(defun make-requirement (type name
&key version-spec source no-deps-p commit branch tag)
(let* ((source (get-source source))
......@@ -53,21 +53,28 @@
(defun install (type name &key version-spec source context no-deps-p
commit branch tag
(validate (constantly t)))
(validate (constantly t))
save-context-p)
(let ((requirement (make-requirement type name
:version-spec version-spec :source source
:no-deps-p no-deps-p :commit commit
:branch branch :tag tag)))
(install-requirements (list requirement) :context context :validate validate
:save-context-p save-context-p)))
(defun install-requirements (reqs &key
context
(validate (constantly t))
save-context-p)
(let* ((orig-context (get-context context))
(context (copy-context orig-context))
(requirement (make-requirement type name
:version-spec version-spec :source source
:no-deps-p no-deps-p :commit commit
:branch branch :tag tag))
(update-projects nil)
(add-result (context-add-requirement! context requirement)))
(when (and (or commit branch tag) add-result)
(push name update-projects))
(let* ((new-context (resolve-requirements context :update-projects update-projects))
(diff (context-diff orig-context new-context)))
(when (funcall validate diff)
(mapc #'install-release (context-releases new-context))
(new-context (copy-context orig-context))
(update-projects nil))
(dolist (r reqs)
(context-add-requirement! new-context r))
(setf new-context (resolve-requirements new-context :update-projects update-projects))
(when (funcall validate (context-diff orig-context new-context))
(mapc #'install-release (context-releases new-context))
(when save-context-p
(context-write-asdf-files new-context)
(save-global-context new-context))
new-context)))
(save-global-context new-context)))
new-context))
......@@ -88,7 +88,8 @@
&key
(unresolved-reqs nil unresolved-reqs-p)
(unresolved-grovel-reqs nil unresolved-grovel-reqs-p)
(system-files-pending-groveling nil system-files-pending-groveling-p))
(system-files-pending-groveling nil system-files-pending-groveling-p)
(groveler (node-groveler node)))
"Given a search node, return a shallow copy of it."
(make-instance 'node
:unresolved-reqs (if unresolved-reqs-p
......@@ -104,7 +105,7 @@
system-files-pending-groveling
(node-system-files-pending-groveling node)))
:groveler-loaded-asds (node-groveler-loaded-asds node)
:groveler (node-groveler node)))
:groveler groveler))
(defun collapse-system-files-needing-groveling (left right)
(if (or (eql left t)
......@@ -171,9 +172,10 @@ incompatible, a new one is created."
(push asd-namestring (node-groveler-loaded-asds node)))
(t
;; Grovelers are incompatible. Need to launch a new one.
(log:debug "Starting new groveler.~%search node asds: ~S~%groveler asds:~S"
(log:debug "Starting new groveler.~%search node asds: ~S~%groveler asds: ~S~%Add: ~S"
(node-groveler-loaded-asds node)
(groveler-loaded-asds (node-groveler node)))
(groveler-loaded-asds (node-groveler node))
asd-pathname)
(setf (node-groveler node) (make-groveler))
(dolist (f (reverse (node-groveler-loaded-asds node)))
(groveler-load-asd! (node-groveler node) f))
......
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