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

Create multiple VCS-SOURCEs per context

parent 96cb639f
Pipeline #4591 passed with stages
in 29 minutes and 33 seconds
...@@ -62,7 +62,8 @@ the lock file if necessary." ...@@ -62,7 +62,8 @@ the lock file if necessary."
;; from the clpmfile. ;; from the clpmfile.
(setf (context-requirements lockfile) nil) (setf (context-requirements lockfile) nil)
(setf (context-user-sources lockfile) (context-user-sources clpmfile) (setf (context-user-sources lockfile) (context-user-sources clpmfile)
(context-fs-sources-ht lockfile) (context-fs-sources-ht clpmfile)) (context-fs-sources-ht lockfile) (context-fs-sources-ht clpmfile)
(context-vcs-sources-ht lockfile) (context-vcs-sources-ht clpmfile))
(setf lockfile (install-requirements (context-requirements clpmfile) (setf lockfile (install-requirements (context-requirements clpmfile)
:context lockfile :context lockfile
:validate validate :validate validate
...@@ -96,7 +97,9 @@ the lock file if necessary." ...@@ -96,7 +97,9 @@ the lock file if necessary."
;; Nuke the lockfile's requirements so that we pick up deletions ;; Nuke the lockfile's requirements so that we pick up deletions
;; from the clpmfile. ;; from the clpmfile.
(setf (context-requirements lockfile) nil) (setf (context-requirements lockfile) nil)
(setf (context-user-sources lockfile) (context-user-sources clpmfile)) (setf (context-user-sources lockfile) (context-user-sources clpmfile)
(context-fs-sources-ht lockfile) (context-fs-sources-ht clpmfile)
(context-vcs-sources-ht lockfile) (context-vcs-sources-ht clpmfile))
(install-requirements (context-requirements clpmfile) (install-requirements (context-requirements clpmfile)
:context lockfile :context lockfile
:validate validate :validate validate
......
...@@ -111,10 +111,12 @@ source." ...@@ -111,10 +111,12 @@ source."
instance." instance."
(destructuring-bind (name &key (host "github.com") path branch commit tag systems) (destructuring-bind (name &key (host "github.com") path branch commit tag systems)
args args
(let ((source (context-vcs-source clpmfile)) (let* ((repo-description (list :github :host host :path path))
(repo (make-repo-from-description (list :github :host host :path path)))) (repo (make-repo-from-description repo-description))
;; Register the git project. (vcs-sources-ht (context-vcs-sources-ht clpmfile))
(vcs-source-register-project! source repo name) (source (ensure-gethash (repo-to-form repo) vcs-sources-ht
(make-source 'vcs-source :repo repo-description
:project-name name))))
(assert (xor branch commit tag)) (assert (xor branch commit tag))
(push (make-instance 'vcs-project-requirement (push (make-instance 'vcs-project-requirement
:systems systems :systems systems
...@@ -132,10 +134,12 @@ instance." ...@@ -132,10 +134,12 @@ instance."
instance." instance."
(destructuring-bind (name &key (host "gitlab.com") path branch commit tag systems) (destructuring-bind (name &key (host "gitlab.com") path branch commit tag systems)
args args
(let ((source (context-vcs-source clpmfile)) (let* ((repo-description (list :gitlab :host host :path path))
(repo (make-repo-from-description (list :gitlab :host host :path path)))) (repo (make-repo-from-description repo-description))
;; Register the git project. (vcs-sources-ht (context-vcs-sources-ht clpmfile))
(vcs-source-register-project! source repo name) (source (ensure-gethash (repo-to-form repo) vcs-sources-ht
(make-source 'vcs-source :repo repo-description
:project-name name))))
(assert (xor branch commit tag)) (assert (xor branch commit tag))
(push (make-instance 'vcs-project-requirement (push (make-instance 'vcs-project-requirement
:systems systems :systems systems
......
...@@ -37,7 +37,8 @@ ...@@ -37,7 +37,8 @@
#:context-to-asdf-source-registry-form #:context-to-asdf-source-registry-form
#:context-to-asdf-source-registry.d-forms #:context-to-asdf-source-registry.d-forms
#:context-user-sources #:context-user-sources
#:context-vcs-source #:context-vcs-sources
#:context-vcs-sources-ht
#:context-visible-primary-system-names #:context-visible-primary-system-names
#:context-write-asdf-files #:context-write-asdf-files
#:copy-context #:copy-context
...@@ -67,10 +68,12 @@ pathname (if this is an anonymous context).") ...@@ -67,10 +68,12 @@ pathname (if this is an anonymous context).")
:accessor context-fs-sources-ht :accessor context-fs-sources-ht
:documentation :documentation
"The implicit filesystem sources rooted for this context.") "The implicit filesystem sources rooted for this context.")
(vcs-source (vcs-sources-ht
:accessor context-vcs-source :initarg :vcs-sources-ht
:initform (make-hash-table :test 'equal)
:accessor context-vcs-sources-ht
:documentation :documentation
"A VCS source to where raw vcs requirements can be homed.") "The implicit VCS sources rooted for this context.")
(user-sources (user-sources
:initform nil :initform nil
:initarg :user-sources :initarg :user-sources
...@@ -97,13 +100,12 @@ pathname (if this is an anonymous context).") ...@@ -97,13 +100,12 @@ pathname (if this is an anonymous context).")
in the context, the requirements that gave rise to those releases, etc. Contexts in the context, the requirements that gave rise to those releases, etc. Contexts
can be named, global contexts, or anonymous.")) can be named, global contexts, or anonymous."))
(defmethod initialize-instance :after ((context context) &key &allow-other-keys)
(setf (context-vcs-source context)
(make-source 'vcs-source :name :implicit-vcs)))
(defmethod context-fs-sources ((context context)) (defmethod context-fs-sources ((context context))
(hash-table-values (context-fs-sources-ht context))) (hash-table-values (context-fs-sources-ht context)))
(defmethod context-vcs-sources ((context context))
(hash-table-values (context-vcs-sources-ht context)))
(defgeneric context-name (context)) (defgeneric context-name (context))
(defmethod context-name ((context pathname)) (defmethod context-name ((context pathname))
...@@ -137,6 +139,7 @@ can be named, global contexts, or anonymous.")) ...@@ -137,6 +139,7 @@ can be named, global contexts, or anonymous."))
:reverse-dependencies (copy-alist (context-reverse-dependencies context)) :reverse-dependencies (copy-alist (context-reverse-dependencies context))
:user-sources (copy-list (context-user-sources context)) :user-sources (copy-list (context-user-sources context))
:fs-sources-ht (copy-hash-table (context-fs-sources-ht context)) :fs-sources-ht (copy-hash-table (context-fs-sources-ht context))
:vcs-sources-ht (copy-hash-table (context-vcs-sources-ht context))
:system-releases (copy-tree (context-system-releases context)))) :system-releases (copy-tree (context-system-releases context))))
(defun global-context-pathname (name) (defun global-context-pathname (name)
...@@ -158,7 +161,7 @@ can be named, global contexts, or anonymous.")) ...@@ -158,7 +161,7 @@ can be named, global contexts, or anonymous."))
(defun context-sources (context) (defun context-sources (context)
(append (context-fs-sources context) (append (context-fs-sources context)
(list (context-vcs-source context)) (context-vcs-sources context)
(context-user-sources context))) (context-user-sources context)))
(defun make-vcs-override-fun (root-pathname) (defun make-vcs-override-fun (root-pathname)
...@@ -428,7 +431,8 @@ in place with the same name. Return the new requirement if it was modified." ...@@ -428,7 +431,8 @@ in place with the same name. Return the new requirement if it was modified."
((or branch tag commit ref) ((or branch tag commit ref)
(make-instance 'vcs-project-requirement (make-instance 'vcs-project-requirement
:name name :name name
:source (get-source source) :source (when (eql source :implicit-vcs)
(get-vcs-source-for-project name))
:commit commit :commit commit
:branch branch :branch branch
:tag tag :tag tag
...@@ -447,9 +451,13 @@ in place with the same name. Return the new requirement if it was modified." ...@@ -447,9 +451,13 @@ in place with the same name. Return the new requirement if it was modified."
(defmethod process-form (context (section (eql :releases)) form) (defmethod process-form (context (section (eql :releases)) form)
(destructuring-bind (name &key version source systems) form (destructuring-bind (name &key version source systems) form
(let* ((source (if (eql source :implicit-file) (let* ((source (cond
(get-source name) ((eql source :implicit-file)
(get-source source))) (get-source name))
((eql source :implicit-vcs)
(get-vcs-source-for-project name))
(t
(get-source source))))
(release (source-project-release source name version))) (release (source-project-release source name version)))
(push release (push release
(context-releases context)) (context-releases context))
...@@ -463,9 +471,13 @@ in place with the same name. Return the new requirement if it was modified." ...@@ -463,9 +471,13 @@ in place with the same name. Return the new requirement if it was modified."
(case (first form) (case (first form)
(:implicit-vcs (:implicit-vcs
(dolist (project-description (getf (rest form) :projects)) (dolist (project-description (getf (rest form) :projects))
(vcs-source-register-project! (context-vcs-source context) (let* ((project-name (car project-description))
(make-repo-from-description (rest project-description)) (repo-description (cdr project-description))
(first project-description)))) (repo (make-repo-from-description repo-description)))
(ensure-gethash (repo-to-form repo)
(context-vcs-sources-ht context)
(make-source 'vcs-source :repo repo-description
:project-name project-name)))))
(:implicit-file (:implicit-file
(dolist (sf (getf (rest form) :system-files)) (dolist (sf (getf (rest form) :system-files))
(ensure-gethash sf (context-fs-sources-ht context) (ensure-gethash sf (context-fs-sources-ht context)
...@@ -545,17 +557,6 @@ in place with the same name. Return the new requirement if it was modified." ...@@ -545,17 +557,6 @@ in place with the same name. Return the new requirement if it was modified."
(format stream ":sources~%") (format stream ":sources~%")
(dolist (source (context-sources context)) (dolist (source (context-sources context))
(let ((form (source-to-form source))) (let ((form (source-to-form source)))
(when (typep source 'vcs-source)
;; Strip out the projects that aren't installed
(setf (getf (rest form) :projects)
(remove-if-not (lambda (x)
(when-let ((release (find x (context-releases context)
:test #'equal
:key (compose #'project-name
#'release-project))))
(equal source (release-source release))))
(getf (rest form) :projects)
:key #'car)))
(format stream "~S~%" form))) (format stream "~S~%" form)))
(terpri stream) (terpri stream)
(terpri stream) (terpri stream)
...@@ -606,10 +607,14 @@ in place with the same name. Return the new requirement if it was modified." ...@@ -606,10 +607,14 @@ in place with the same name. Return the new requirement if it was modified."
`(,(project-name (release-project release)) `(,(project-name (release-project release))
:version ,(release-version release) :version ,(release-version release)
;; TODO: Bundle v0.4 maybe replace with the .asd pathname instead of ;; TODO: Bundle v0.4 maybe replace with the .asd pathname instead of
;; :IMPLICIT-FILE? ;; :IMPLICIT-FILE? Same with :IMPLICIT-VCS.
:source ,(if (typep (release-source release) 'fs-source) :source ,(typecase (release-source release)
:implicit-file (fs-source
(source-name (release-source release))) :implicit-file)
(vcs-source
:implicit-vcs)
(t
(source-name (release-source release))))
:systems ,(safe-sort system-names #'string<))) :systems ,(safe-sort system-names #'string<)))
(defun context-reverse-deps-to-form (release-and-reverse-deps) (defun context-reverse-deps-to-form (release-and-reverse-deps)
......
...@@ -205,15 +205,24 @@ represents.")) ...@@ -205,15 +205,24 @@ represents."))
(defgeneric requirement-to-plist (req)) (defgeneric requirement-to-plist (req))
;; TODO: context version 0.4, get rid of :implicit-vcs.
(defun backward-compatible-source-name (source)
(typecase source
(clpm-source
;; HACK to avoid circular dep.
(if (string-equal 'vcs-source (class-name (class-of source)))
:implicit-vcs
(source-name source)))
(t
source)))
(defmethod requirement-to-plist ((req versioned-requirement)) (defmethod requirement-to-plist ((req versioned-requirement))
(append (append
(list :name (requirement-name req)) (list :name (requirement-name req))
(awhen (requirement-version-spec req) (awhen (requirement-version-spec req)
(list :version it)) (list :version it))
(awhen (requirement-source req) (awhen (requirement-source req)
(list :source (if (typep it 'clpm-source) (list :source (backward-compatible-source-name it)))
(source-name it)
it)))
(awhen (requirement-no-deps-p req) (awhen (requirement-no-deps-p req)
(list :no-deps-p it)))) (list :no-deps-p it))))
...@@ -229,9 +238,7 @@ represents.")) ...@@ -229,9 +238,7 @@ represents."))
(awhen (requirement-ref req) (awhen (requirement-ref req)
(list :ref it)) (list :ref it))
(awhen (requirement-source req) (awhen (requirement-source req)
(list :source (if (typep it 'clpm-source) (list :source (backward-compatible-source-name it)))
(source-name it)
it)))
(awhen (requirement-no-deps-p req) (awhen (requirement-no-deps-p req)
(list :no-deps-p it)))) (list :no-deps-p it))))
......
...@@ -101,7 +101,7 @@ ...@@ -101,7 +101,7 @@
set of installed releases is updated to be the minimum set that satisfies all set of installed releases is updated to be the minimum set that satisfies all
the requirements." the requirements."
(with-sources ((context-sources context)) (with-sources ((context-sources context))
(vcs-source-clear-visible-releases (context-vcs-source context)) (mapc #'vcs-source-clear-visible-releases (context-vcs-sources context))
(let* ((*releases-sort-function* (unless (eql update-projects t) (let* ((*releases-sort-function* (unless (eql update-projects t)
(make-result-sorter context update-projects))) (make-result-sorter context update-projects)))
(reqs (rewrite-vcs-reqs (context-requirements context) context update-projects)) (reqs (rewrite-vcs-reqs (context-requirements context) context update-projects))
......
...@@ -17,6 +17,7 @@ ...@@ -17,6 +17,7 @@
(:reexport #:clpm/sources/fs) (:reexport #:clpm/sources/fs)
(:reexport #:clpm/sources/vcs) (:reexport #:clpm/sources/vcs)
(:export #:get-source (:export #:get-source
#:get-vcs-source-for-project
#:sources #:sources
#:with-sources)) #:with-sources))
...@@ -44,6 +45,14 @@ ...@@ -44,6 +45,14 @@
(error "Unable to find source named ~S" source-designator)) (error "Unable to find source named ~S" source-designator))
source)))) source))))
(defun get-vcs-source-for-project (project-name &optional (errorp t))
(or
(loop :for vcs-source :in (remove-if-not (lambda (x) (typep x 'vcs-source)) (sources))
:when (equal project-name (project-name (vcs-source-project vcs-source)))
:do (return vcs-source))
(when errorp
(error "Unable to find VCS source for project ~S" project-name))))
(defun call-with-sources (sources thunk) (defun call-with-sources (sources thunk)
(let ((*visible-sources* sources)) (let ((*visible-sources* sources))
(funcall thunk))) (funcall thunk)))
......
...@@ -30,7 +30,7 @@ ...@@ -30,7 +30,7 @@
#:vcs-remote-release #:vcs-remote-release
#:vcs-source #:vcs-source
#:vcs-source-clear-visible-releases #:vcs-source-clear-visible-releases
#:vcs-source-register-project! #:vcs-source-project
#:vcs-system)) #:vcs-system))
(in-package #:clpm/sources/vcs) (in-package #:clpm/sources/vcs)
...@@ -44,10 +44,12 @@ ...@@ -44,10 +44,12 @@
((name ((name
:initarg :name :initarg :name
:reader source-name) :reader source-name)
(projects-by-name (repo
:initform (make-hash-table :test 'equal) :initarg :repo
:accessor vcs-source-projects-by-name :reader vcs-source-repo)
:documentation "hash table mapping project names to project objects.") (project
:accessor vcs-source-project
:documentation "The single project for the source.")
(systems-by-name (systems-by-name
:initform (make-hash-table :test 'equalp) :initform (make-hash-table :test 'equalp)
:accessor vcs-source-systems-by-name :accessor vcs-source-systems-by-name
...@@ -56,38 +58,22 @@ ...@@ -56,38 +58,22 @@
"A source for any bare VCS projects. Projects must be registered with the "A source for any bare VCS projects. Projects must be registered with the
source using VCS-SOURCE-REGISTER_PROJECT!.")) source using VCS-SOURCE-REGISTER_PROJECT!."))
(defmethod make-source ((type (eql 'vcs-source)) &rest initargs &key name projects) (defmethod make-source ((type (eql 'vcs-source)) &key repo project-name)
(with-clpm-session (:key `(make-source ,type ,name)) (let* ((repo-object (make-repo-from-description repo))
(aprog1 (apply #'make-instance (name (repo-to-form repo-object)))
type (format t "~S~%" project-name)
initargs) (with-clpm-session (:key `(make-source ,type ,name))
(dolist (project projects) (make-instance type :name name
(destructuring-bind (project-name . repo-form) project :project-name project-name
(vcs-source-register-project! it (make-repo-from-description repo-form) project-name)))))) :repo repo-object))))
(defmethod initialize-instance :after ((source vcs-source) (defmethod initialize-instance :after ((source vcs-source) &key project-name)
&rest initargs (setf (vcs-source-project source) (make-instance 'vcs-project
&key projects :source source
&allow-other-keys) :name project-name)))
(declare (ignore initargs))
(dolist (project projects)
(destructuring-bind (project-name . repo-form) project
(vcs-source-register-project! source (make-repo-from-description repo-form) project-name))))
(defun vcs-source-clear-visible-releases (vcs-source) (defun vcs-source-clear-visible-releases (vcs-source)
(maphash (lambda (k v) (setf (vcs-project-visible-releases (vcs-source-project vcs-source)) nil))
(declare (ignore k))
(setf (vcs-project-visible-releases v) nil))
(vcs-source-projects-by-name vcs-source)))
(defun vcs-source-register-project! (vcs-source repo project-name)
"Registers a project with the vcs source and returns it."
(let ((projects-by-name (vcs-source-projects-by-name vcs-source)))
(ensure-gethash project-name projects-by-name
(make-instance 'vcs-project
:repo repo
:source vcs-source
:name project-name))))
(defmethod source-ensure-system ((source vcs-source) system-name) (defmethod source-ensure-system ((source vcs-source) system-name)
(ensure-gethash (ensure-gethash
...@@ -100,7 +86,8 @@ source using VCS-SOURCE-REGISTER_PROJECT!.")) ...@@ -100,7 +86,8 @@ source using VCS-SOURCE-REGISTER_PROJECT!."))
t) t)
(defmethod source-project ((source vcs-source) project-name &optional (error t)) (defmethod source-project ((source vcs-source) project-name &optional (error t))
(or (gethash project-name (vcs-source-projects-by-name source)) (if (equal project-name (project-name (vcs-source-project source)))
(vcs-source-project source)
(when error (when error
(error 'source-missing-project (error 'source-missing-project
:source source :source source
...@@ -108,27 +95,20 @@ source using VCS-SOURCE-REGISTER_PROJECT!.")) ...@@ -108,27 +95,20 @@ source using VCS-SOURCE-REGISTER_PROJECT!."))
(defmethod source-system ((source vcs-source) system-name &optional (error t)) (defmethod source-system ((source vcs-source) system-name &optional (error t))
(or (gethash system-name (vcs-source-systems-by-name source)) (or (gethash system-name (vcs-source-systems-by-name source))
(some (lambda (project) (some (lambda (release)
(some (lambda (release) (when-let ((system-release (release-system-release release system-name nil)))
(when-let ((system-release (release-system-release release system-name nil))) (system-release-system system-release)))
(system-release-system system-release))) (project-releases (vcs-source-project source)))
(project-releases project)))
(hash-table-values (vcs-source-projects-by-name source)))
(when error (when error
(error 'source-missing-system (error 'source-missing-system
:source source :source source
:system-name system-name)))) :system-name system-name))))
(defmethod source-to-form ((source vcs-source)) (defmethod source-to-form ((source vcs-source))
(let ((projects nil)) (let ((project (vcs-source-project source)))
(maphash (lambda (project-name project) `(:implicit-vcs
(push (cons project-name :type :vcs
(repo-to-form (project-repo project))) :projects ((,(project-name project) . ,(repo-to-form (project-repo project)))))))
projects))
(vcs-source-projects-by-name source))
(list (source-name source)
:type :vcs
:projects (safe-sort projects #'string< :key #'car))))
(defmethod sync-source ((source vcs-source)) (defmethod sync-source ((source vcs-source))
nil) nil)
...@@ -168,9 +148,6 @@ local override when requesting a VCS release.") ...@@ -168,9 +148,6 @@ local override when requesting a VCS release.")
(name (name
:initarg :name :initarg :name
:reader project-name) :reader project-name)
(repo
:initarg :repo
:reader project-repo)
(visible-releases (visible-releases
:initform nil :initform nil
:accessor vcs-project-visible-releases) :accessor vcs-project-visible-releases)
...@@ -178,6 +155,9 @@ local override when requesting a VCS release.") ...@@ -178,6 +155,9 @@ local override when requesting a VCS release.")
:initform (make-hash-table :test 'equal) :initform (make-hash-table :test 'equal)
:accessor vcs-project-releases-by-spec))) :accessor vcs-project-releases-by-spec)))
(defmethod project-repo ((project vcs-project))
(vcs-source-repo (project-source project)))
(defmethod project-releases ((project vcs-project)) (defmethod project-releases ((project vcs-project))
(vcs-project-visible-releases project)) (vcs-project-visible-releases project))
......
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