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