Commit aba89d0f authored by Eric Timmons's avatar Eric Timmons
Browse files

Rework signaling to sources they should look at installed only information

parent 784b861b
......@@ -41,12 +41,11 @@
(define-cli-command (("bundle" "exec") *bundle-exec-ui*) (args options)
(let* ((clpmfile-pathname (bundle-clpmfile-pathname))
(clpmfile (get-clpmfile clpmfile-pathname :installed-only-p t))
(clpmfile (get-clpmfile clpmfile-pathname))
(lockfile-pathname (clpmfile-lockfile-pathname clpmfile))
(include-client-p (gethash :bundle-exec-with-client options))
(cl-source-registry-form (bundle-source-registry clpmfile-pathname
:include-client-p include-client-p
:installed-only-p t))
:include-client-p include-client-p))
(output-translations-form (bundle-output-translations clpmfile-pathname))
(lockfile (bundle-context clpmfile))
(installed-system-names (sort (mapcar #'system-name (context-installed-systems lockfile)) #'string<))
......
......@@ -72,8 +72,8 @@ bound to PN's folder."
(when override
(merge-pathnames override clpmfile-directory))))))
(defun load-lockfile (pathname &key installed-only-p)
(load-anonymous-context-from-pathname pathname :installed-only-p installed-only-p))
(defun load-lockfile (pathname)
(load-anonymous-context-from-pathname pathname))
(defun bundle-context (clpmfile-designator)
(let* ((clpmfile (get-clpmfile clpmfile-designator))
......@@ -150,27 +150,27 @@ the lock file if necessary."
nil))))
(defun bundle-source-registry (clpmfile-designator
&key include-client-p ignore-missing-releases
installed-only-p)
(let* ((*fetch-repo-automatically* nil)
(clpmfile (get-clpmfile clpmfile-designator))
(lockfile-pathname (clpmfile-lockfile-pathname clpmfile))
(*vcs-project-override-fun* (make-vcs-override-fun (clpmfile-pathname clpmfile)))
lockfile)
(unless (probe-file lockfile-pathname)
(error "Lockfile ~A does not exist" lockfile-pathname))
(setf lockfile (load-lockfile lockfile-pathname :installed-only-p installed-only-p))
(unless ignore-missing-releases
(let* ((releases (context-releases lockfile))
(missing-releases (remove-if #'release-installed-p releases)))
(when missing-releases
(error "The following releases are not installed: ~{~S~^, ~}"
(mapcar (compose #'project-name #'release-project) missing-releases)))))
(context-to-asdf-source-registry-form
lockfile
:extra-forms
(when include-client-p
`((:directory ,(uiop:pathname-directory-pathname (client-asd-pathname))))))))
&key include-client-p ignore-missing-releases)
(with-sources-using-installed-only ()
(let* ((*fetch-repo-automatically* nil)
(clpmfile (get-clpmfile clpmfile-designator))
(lockfile-pathname (clpmfile-lockfile-pathname clpmfile))
(*vcs-project-override-fun* (make-vcs-override-fun (clpmfile-pathname clpmfile)))
lockfile)
(unless (probe-file lockfile-pathname)
(error "Lockfile ~A does not exist" lockfile-pathname))
(setf lockfile (load-lockfile lockfile-pathname))
(unless ignore-missing-releases
(let* ((releases (context-releases lockfile))
(missing-releases (remove-if #'release-installed-p releases)))
(when missing-releases
(error "The following releases are not installed: ~{~S~^, ~}"
(mapcar (compose #'project-name #'release-project) missing-releases)))))
(context-to-asdf-source-registry-form
lockfile
:extra-forms
(when include-client-p
`((:directory ,(uiop:pathname-directory-pathname (client-asd-pathname)))))))))
(defun bundle-update (clpmfile-designator &key
update-projects (validate (constantly t))
......
......@@ -32,12 +32,6 @@
:accessor clpmfile-pathname
:documentation
"The pathname to this file.")
(installed-only-p
:initarg :installed-only-p
:initform nil
:reader clpmfile-installed-only-p
:documentation
"If sources should be created to only look at their installed releases.")
(user-global-sources
:initarg :user-global-sources
:initform nil
......@@ -118,17 +112,16 @@ clpmfile is located."
(clpmfile-vcs-source clpmfile)
(clpmfile-user-global-sources clpmfile)))
(defgeneric get-clpmfile (clpmfile-designator &key installed-only-p))
(defgeneric get-clpmfile (clpmfile-designator))
(defmethod get-clpmfile ((clpmfile-designator clpmfile) &key installed-only-p)
(declare (ignore installed-only-p))
(defmethod get-clpmfile ((clpmfile-designator clpmfile))
clpmfile-designator)
(defmethod get-clpmfile ((clpmfile-designator pathname) &key installed-only-p)
(read-clpmfile clpmfile-designator :installed-only-p installed-only-p))
(defmethod get-clpmfile ((clpmfile-designator pathname))
(read-clpmfile clpmfile-designator))
(defmethod get-clpmfile ((clpmfile-designator string) &key installed-only-p)
(get-clpmfile (pathname clpmfile-designator) :installed-only-p installed-only-p))
(defmethod get-clpmfile ((clpmfile-designator string))
(get-clpmfile (pathname clpmfile-designator)))
;; * Deserializing
......@@ -230,7 +223,7 @@ instance."
"Load a :source statement from a clpmfile and add it to the list of sources."
(unless (stringp (first args))
(error "The first argument to :SOURCE must be a string"))
(push (load-source-from-form args :installed-only-p (clpmfile-installed-only-p clpmfile))
(push (load-source-from-form args)
(clpmfile-user-global-sources clpmfile)))
(defmethod parse-clpmfile-form (clpmfile (type (eql :system)) args)
......@@ -246,9 +239,8 @@ instance."
:why t)
(clpmfile-user-requirements clpmfile))))
(defun read-clpmfile-from-stream (stream pathname &key installed-only-p)
(let ((clpmfile (make-instance 'clpmfile :pathname pathname
:installed-only-p installed-only-p))
(defun read-clpmfile-from-stream (stream pathname)
(let ((clpmfile (make-instance 'clpmfile :pathname pathname))
(source-allowed-p t))
(uiop:with-safe-io-syntax ()
;; The first form in the stream must be an API declaration.
......@@ -270,11 +262,11 @@ instance."
(nreversef (clpmfile-user-requirements clpmfile))
clpmfile)))
(defun read-clpmfile (pathname &key installed-only-p)
(defun read-clpmfile (pathname)
"Read a ~clpmfile~ instance from ~pathname~."
(let* ((*default-pathname-defaults* (uiop:pathname-directory-pathname pathname)))
(with-open-file (stream pathname)
(read-clpmfile-from-stream stream pathname :installed-only-p installed-only-p))))
(read-clpmfile-from-stream stream pathname))))
(defmethod print-object ((obj clpmfile) stream)
(print-unreadable-object (obj stream :type t)
......
......@@ -20,7 +20,6 @@
#:context-asd-pathnames
#:context-find-system-asd-pathname
#:context-installed-systems
#:context-installed-only-p
#:context-output-translations
#:context-releases
#:context-requirements
......@@ -49,13 +48,6 @@
:documentation
"The name of the context. Either a string (if this is a global context) or a
pathname (if this is an anonymous context).")
(installed-only-p
:initarg :installed-only-p
:initform nil
:reader context-installed-only-p
:documentation
"Hack (hopefully temporary) to indicate that sources should be instantiated
to read only from their local data.")
(requirements
:initform nil
:initarg :requirements
......@@ -263,9 +255,9 @@ in place with the same name. Return the new requirement if it was modified."
;; * Deserializing
(defun load-anonymous-context-from-pathname (pn &key installed-only-p)
(defun load-anonymous-context-from-pathname (pn)
(with-open-file (s pn)
(load-context-from-stream s :installed-only-p installed-only-p)))
(load-context-from-stream s)))
(defun context-downselect-sources (name sources)
(let ((allowed-source-names (config-value :contexts name :sources)))
......@@ -350,24 +342,22 @@ in place with the same name. Return the new requirement if it was modified."
(defmethod process-form (context (section (eql :reverse-dependencies)) form))
(defmethod process-form (context (section (eql :sources)) form)
(let ((source (load-source-from-form form :installed-only-p (context-installed-only-p context))))
(let ((source (load-source-from-form form)))
(when (typep source 'fs-source)
(push (project-release (source-project source :all) :newest)
(context-releases context)))
(unless (or (source-can-lazy-sync-p source)
(config-value :local)
(context-installed-only-p context))
(config-value :local))
(sync-source source))
(setf (context-sources context) (append (context-sources context) (list source)))))
(defun load-context-from-stream (stream &key installed-only-p)
(defun load-context-from-stream (stream)
(uiop:with-safe-io-syntax ()
;; The first form in the stream must be an API declaration.
(let ((f (read stream nil)))
(unless (equal f '(:api-version "0.3"))
(error "Unknown context API version")))
(let ((out (make-instance 'context
:installed-only-p installed-only-p)))
(let ((out (make-instance 'context)))
;; The next forms are either tags or lists. The tags denote sections.
(loop
:with section := nil
......
......@@ -18,7 +18,8 @@
#:read-file-form
#:with-safe-io-syntax)
(:export #:load-global-sources
#:load-source-from-form))
#:load-source-from-form
#:with-sources-using-installed-only))
(in-package #:clpm/sources/config)
......@@ -35,7 +36,18 @@
(:vcs
'vcs-source)))
(defun load-source-from-form (f &key installed-only-p)
(defvar *sources-use-installed-only-p* nil)
(defun call-with-sources-using-installed-only (thunk)
(let ((*sources-use-installed-only-p* t))
(funcall thunk)))
(defmacro with-sources-using-installed-only (() &body body)
"Execute BODY in a context where sources are configured to have only installed
information visible."
`(call-with-sources-using-installed-only (lambda () ,@body)))
(defun load-source-from-form (f)
(destructuring-bind (name &rest args &key type &allow-other-keys)
f
(assert (or (eql type :file-system)
......@@ -45,7 +57,7 @@
(apply #'make-source
(resolve-type type)
:name name
:installed-only-p installed-only-p
:installed-only-p *sources-use-installed-only-p*
(remove-from-plist args :type))))
(defun load-global-sources ()
......
......@@ -117,7 +117,11 @@
(defclass clpm-source ()
((synced-p
:initform nil
:accessor source-synced-p))
:accessor source-synced-p)
(installed-only-p
:initform nil
:initarg :installed-only-p
:accessor source-installed-only-p))
(:documentation "Base class for any CLPM source. A source contains projects
and systems."))
......@@ -185,7 +189,9 @@ initargs and a :type as a keyword."))
(:documentation "Synchronize the local source metadata with the upstream
metadata. Returns T if the local data has changed, NIL otherwise.")
(:method :around (source)
(multiple-value-prog1 (unless (source-synced-p source) (call-next-method))
(multiple-value-prog1 (unless (or (source-installed-only-p source)
(source-synced-p source))
(call-next-method))
(setf (source-synced-p source) t))))
......
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