Commit 96cb639f authored by Eric Timmons's avatar Eric Timmons
Browse files

Create multiple FS-SOURCES per context

Instead of using a single FS-SOURCE per context, we now create one per .asd
file. Additionally, when doing a bundle operation, we replace the lockfile's
FS-SOURCEs with the ones from the clpmfile. This helps ensure that stale
sources are replaced.
parent 89b2ff6b
......@@ -61,7 +61,8 @@ 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))
(setf lockfile (install-requirements (context-requirements clpmfile)
:context lockfile
:validate validate
......
......@@ -87,9 +87,10 @@ source."
(error "The argument to :ASD must be a string"))
(unless (probe-file (merge-pathnames asd-file))
(error "The argument to :ASD must exist"))
(let ((fs-source (context-fs-source clpmfile)))
;; Register the system with the fs-source
(fs-source-register-asd fs-source asd-file)
(let* ((fs-sources-ht (context-fs-sources-ht clpmfile))
(fs-source
(ensure-gethash asd-file fs-sources-ht
(make-source 'fs-source :name asd-file))))
(if systems
(dolist (system-name systems)
(context-add-requirement! clpmfile
......
......@@ -24,7 +24,7 @@
#:context-asd-pathnames
#:context-editable-primary-system-names
#:context-find-system-asd-pathname
#:context-fs-source
#:context-fs-sources-ht
#:context-installed-primary-system-names
#:context-installed-system-names
#:context-name
......@@ -61,10 +61,12 @@ pathname (if this is an anonymous context).")
:initform nil
:initarg :requirements
:accessor context-requirements)
(fs-source
:accessor context-fs-source
(fs-sources-ht
:initarg :fs-sources-ht
:initform (make-hash-table :test 'equal)
:accessor context-fs-sources-ht
:documentation
"The implicit filesystem source rooted for this context.")
"The implicit filesystem sources rooted for this context.")
(vcs-source
:accessor context-vcs-source
:documentation
......@@ -96,12 +98,12 @@ 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-fs-source context)
(make-source 'fs-source
:name :implicit-file))
(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)))
(defgeneric context-name (context))
(defmethod context-name ((context pathname))
......@@ -134,6 +136,7 @@ can be named, global contexts, or anonymous."))
:requirements (copy-list (context-requirements context))
: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))
:system-releases (copy-tree (context-system-releases context))))
(defun global-context-pathname (name)
......@@ -154,9 +157,9 @@ can be named, global contexts, or anonymous."))
(error "Unable to translate ~S to a context object" context-designator))))
(defun context-sources (context)
(list* (context-fs-source context)
(context-vcs-source context)
(context-user-sources context)))
(append (context-fs-sources context)
(list (context-vcs-source context))
(context-user-sources context)))
(defun make-vcs-override-fun (root-pathname)
(let ((root-pathname (uiop:pathname-directory-pathname root-pathname)))
......@@ -198,9 +201,11 @@ in place with the same name. Return the new requirement if it was modified."
(let ((existing-req (context-find-requirement context (requirement-type-keyword req)
(requirement-name req))))
(when (typep req 'fs-system-file-requirement)
(fs-source-register-asd (context-fs-source context) (requirement-name req)))
(ensure-gethash (requirement-name req) (context-fs-sources-ht context)
(make-source 'fs-source :name (requirement-name req))))
(when (typep req 'fs-system-requirement)
(fs-source-register-asd (context-fs-source context) (requirement-pathname req)))
(ensure-gethash (requirement-pathname req) (context-fs-sources-ht context)
(make-source 'fs-source :name (requirement-pathname req))))
(if existing-req
(progn
(log:debug "Replacing requirement ~A with ~A" existing-req req)
......@@ -223,7 +228,7 @@ in place with the same name. Return the new requirement if it was modified."
(defun context-editable-primary-system-names (context)
(let* ((releases (context-releases context))
(editable-releases (remove-if-not (lambda (x) (eql x (context-fs-source context)))
(editable-releases (remove-if-not (lambda (x) (member x (context-fs-sources context)))
releases
:key #'release-source))
(editable-system-files (mapcan #'release-system-files editable-releases)))
......@@ -442,7 +447,9 @@ 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 (get-source source))
(let* ((source (if (eql source :implicit-file)
(get-source name)
(get-source source)))
(release (source-project-release source name version)))
(push release
(context-releases context))
......@@ -461,7 +468,8 @@ in place with the same name. Return the new requirement if it was modified."
(first project-description))))
(:implicit-file
(dolist (sf (getf (rest form) :system-files))
(fs-source-register-asd (context-fs-source context) sf)))
(ensure-gethash sf (context-fs-sources-ht context)
(make-source 'fs-source :name sf))))
(t
(let ((source (load-source-from-form form)))
(unless (or (source-can-lazy-sync-p source)
......@@ -597,7 +605,11 @@ in place with the same name. Return the new requirement if it was modified."
(defun context-release-to-form (release system-names)
`(,(project-name (release-project release))
:version ,(release-version release)
:source ,(source-name (release-source 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)))
:systems ,(safe-sort system-names #'string<)))
(defun context-reverse-deps-to-form (release-and-reverse-deps)
......
......@@ -82,8 +82,7 @@ satisfied. Returns one of :SAT, :UNSAT, or :UNKNOWN."))
(cond
((not system-release)
:unknown)
((not (eql (system-release-source system-release)
(get-source :implicit-file)))
((not (typep (system-release-source system-release) 'fs-source))
:unsat)
(t
:sat))))
......@@ -150,7 +149,7 @@ a plist. This plist can contain :system-releases or :system-files."))
(defmethod resolve-requirement ((req fs-system-requirement) node)
;; Make a release from the file system.
(let* ((system-name (requirement-name req))
(fs-source (get-source :implicit-file))
(fs-source (get-source (requirement-pathname req)))
(system (source-system fs-source system-name))
(releases (system-releases system))
(release (first releases))
......@@ -164,7 +163,7 @@ a plist. This plist can contain :system-releases or :system-files."))
(defmethod resolve-requirement ((req fs-system-file-requirement) node)
;; Make a release from the file system.
(let* ((asd-pathname (requirement-name req))
(fs-source (get-source :implicit-file))
(fs-source (get-source asd-pathname))
(release (source-project-release fs-source (namestring asd-pathname) :newest)))
(list (list release
:system-files (list (cons (release-system-file release asd-pathname) t))))))
......
;;;; Sources that are located on the file system.
;;;; Source that is located on the file system. Represents a single .asd file.
;;;;
;;;; This software is part of CLPM. See README.org for more information. See
;;;; LICENSE for license information.
......@@ -15,9 +15,7 @@
#:clpm/sources/defs
#:clpm/sources/dotted-versioned-project
#:clpm/utils)
(:export #:fs-source
#:fs-source-register-asd
#:fs-release))
(:export #:fs-source))
(in-package #:clpm/sources/fs)
......@@ -28,54 +26,51 @@
((name
:initarg :name
:accessor source-name)
(projects-by-namestring
:initform (make-hash-table :test 'equal)
:accessor fs-source-projects-by-namestring
:documentation "Maps system namestring to project instances.")
(system-files-by-primary-name
:initform (make-hash-table :test 'equalp)
:accessor fs-source-system-files-by-primary-name
:documentation "A hash table that maps system primary names to
fs-system-file objects.")
(system-files-by-namestring
:initform (make-hash-table :test 'equal)
:accessor fs-source-system-files-by-namestring
:documentation "A hash table that maps system namestrings to fs-system-file
objects.")
(project
:accessor fs-source-project
:documentation "The single project for the source. Has the same name as the
source.")
(project-release
:accessor fs-source-project-release)
(system-file
:accessor fs-source-system-file
:documentation "The single system file for the source. Has the same name as
the source.")
(systems-by-name
:initform (make-hash-table :test 'equalp)
:accessor fs-source-systems-by-name
:documentation "A hash table that maps system names to fs-system objects."))
(:documentation
"A source that contains systems located on the file system. Contains a
project for every .asd file and each project has one reelase (:NEWEST). Does not
do any autodiscovery of system files, system files must be registered with the
source using FS-SOURCE-REGISTER-ASD."))
"A source that contains systems located in a single .asd file on the file
system. Contains a single project and release (:NEWEST)."))
(defmethod make-source ((type (eql 'fs-source)) &rest initargs
&key system-files name)
&key name)
(setf name (namestring name))
(with-clpm-session (:key `(make-source ,type ,name))
(aprog1 (apply #'make-instance
type
initargs)
(dolist (system-file system-files)
(fs-source-register-asd it system-file)))))
(defmethod initialize-instance :after ((source fs-source)
&rest initargs
&key
system-files
&allow-other-keys)
(apply #'make-instance
type
initargs)))
(defmethod initialize-instance :after ((source fs-source) &key name)
"Construct the singleton project and release."
(declare (ignore initargs))
(dolist (system-file system-files)
(fs-source-register-asd source system-file)))
(setf (fs-source-project source)
(make-instance 'fs-project :source source))
(setf (fs-source-project-release source)
(make-instance 'fs-release
:version :newest
:source source))
(setf (fs-source-system-file source)
(make-instance 'fs-system-file
:enough-namestring name
:source source)))
(defmethod source-can-lazy-sync-p ((source fs-source))
t)
(defmethod source-project ((source fs-source) project-name &optional (error t))
(or (gethash (namestring project-name) (fs-source-projects-by-namestring source))
(if (equal project-name (source-name source))
(fs-source-project source)
(when error
(error 'source-missing-project
:source source
......@@ -85,18 +80,17 @@ source using FS-SOURCE-REGISTER-ASD."))
"If this system already exists, return it. Otherwise see if we have an asd
file with the same primary name and construct a new system for it."
(unless (gethash system-name (fs-source-systems-by-name source))
;; We haven't seen this particular system before. See if we have a system
;; file that could plausibly contain it.
(when-let ((system-file (gethash (asdf:primary-system-name system-name)
(fs-source-system-files-by-primary-name source))))
;; We do. Construct a new system object for it.
;; We haven't seen this particular system before. See if we could plausibly
;; contain it.
(when (equal (pathname-name (source-name source))
(asdf:primary-system-name system-name))
;; We can plausibly contain it.
(let* ((system (make-instance 'fs-system
:name system-name
:source source))
(system-release (make-instance 'fs-system-release
:source source
:system system
:release (system-file-release system-file))))
:system system)))
(setf (fs-system-system-release system) system-release)
(setf (gethash system-name (fs-source-systems-by-name source))
system))))
......@@ -106,30 +100,10 @@ file with the same primary name and construct a new system for it."
:source source
:system-name system-name))))
(defun fs-source-register-asd (fs-source asd-pathname)
"Given a pathname to an asd file, register it with the source. asd-pathname
can be relative or absolute."
(let* ((primary-name-ht (fs-source-system-files-by-primary-name fs-source))
(namestring-ht (fs-source-system-files-by-namestring fs-source))
(namestring (namestring asd-pathname))
(project-ht (fs-source-projects-by-namestring fs-source))
(project (or (gethash namestring project-ht)
(make-instance 'fs-project :name namestring :source fs-source))))
(setf (gethash namestring project-ht) project)
(aprog1 (ensure-gethash (pathname-name namestring) primary-name-ht
(make-instance 'fs-system-file
:source fs-source
:project project
:release (project-release project :newest)
:enough-namestring namestring))
(setf (gethash namestring namestring-ht) it))))
(defmethod source-to-form ((source fs-source))
(let* ((system-files (hash-table-keys (fs-source-projects-by-namestring source))))
`(,(source-name source)
:type :file-system
:system-files ,(safe-sort system-files #'string<))))
`(:implicit-file
:type :file-system
:system-files (,(source-name source))))
(defmethod sync-source ((source fs-source))
nil)
......@@ -140,27 +114,18 @@ can be relative or absolute."
(defclass fs-project (clpm-project)
((source
:initarg :source
:reader project-source)
(name
:initarg :name
:reader project-name)
(release
:accessor fs-project-release))
:reader project-source))
(:documentation "A project on the filesystem. Contains a singleton
release (that is constructed by the source.)"))
(defmethod initialize-instance :after ((project fs-project) &key name source)
(declare (ignore name))
(setf (fs-project-release project) (make-instance 'fs-release
:version :newest
:project project
:source source)))
(defmethod project-name ((project fs-project))
(source-name (project-source project)))
(defmethod project-release ((project fs-project) version-string &optional (error t))
"If the version is :newest, return our singleton release, otherwise nil."
(cond
((equal version-string :newest)
(fs-project-release project))
(fs-source-project-release (project-source project)))
(error
(error 'project-missing-version
:source (project-source project)
......@@ -169,7 +134,7 @@ release (that is constructed by the source.)"))
(t nil)))
(defmethod project-releases ((project fs-project))
(list (fs-project-release project)))
(list (fs-source-project-release (project-source project))))
;; * Release
......@@ -178,28 +143,22 @@ release (that is constructed by the source.)"))
((source
:initarg :source
:reader release-source)
(project
:initarg :project
:reader release-project)
(version
:initarg :version
:reader release-version))
(:documentation "A release on the filesystem. Each fs-source has one instance
of this created upon instantiation."))
(defmethod release-project ((release fs-release))
(fs-source-project (release-source release)))
(defmethod release-system-file ((release fs-release) system-file-namestring)
"Look at the fs-source to get the system file."
(let* ((source (release-source release))
(ht (fs-source-system-files-by-namestring source)))
(gethash (namestring system-file-namestring) ht)))
(fs-source-system-file (release-source release)))
(defmethod release-system-files ((release fs-release))
"Projects (and releases) correspond to a single system file."
(let* ((source (release-source release))
(ht (fs-source-system-files-by-namestring source))
(project (release-project release))
(namestring (project-name project)))
(list (gethash namestring ht))))
(list (fs-source-system-file (release-source release))))
(defmethod release-system-release ((release fs-release) system-name &optional (error t))
"Get the system object from the source and look up its singleton system
......@@ -228,12 +187,6 @@ release."
((source
:initarg :source
:reader system-file-source)
(project
:initarg :project
:reader fs-system-file-project)
(release
:initarg :release
:reader system-file-release)
(enough-namestring
:initarg :enough-namestring
:accessor system-file-asd-enough-namestring)
......@@ -242,6 +195,9 @@ release."
:accessor fs-system-file/groveled-p))
(:documentation "A single system file located on the file system."))
(defmethod system-file-release ((system-file fs-system-file))
(fs-source-project-release (system-file-source system-file)))
(defmethod system-file-absolute-asd-pathname ((system-file fs-system-file))
"Merge the enough pathname with the source's root dir."
(merge-pathnames (system-file-asd-enough-namestring system-file)))
......@@ -292,8 +248,7 @@ contains."
(list (fs-system-system-release system)))
(defmethod system-releases ((system fs-system))
(list (system-file-release (gethash (asdf:primary-system-name (system-name system))
(fs-source-system-files-by-primary-name (system-source system))))))
(list (system-file-release (fs-source-system-file (system-source system)))))
;; * System release
......@@ -305,9 +260,6 @@ contains."
(system
:initarg :system
:accessor system-release-system)
(release
:initarg :release
:accessor system-release-release)
(version
:accessor system-release-system-version
:documentation "The version of this system. Groveled on request.")
......@@ -316,6 +268,9 @@ contains."
:documentation "The dependencies of this system. Groveled on request."))
(:documentation "A system release for a system located on the file system."))
(defmethod system-release-release ((system-release fs-system-release))
(fs-source-project-release (system-release-source system-release)))
(defun parse-system-release-info-from-groveler! (system-release info)
"Take the info provided by the groveler and modify system-release in place to
include it."
......@@ -345,11 +300,7 @@ include it."
(defmethod system-release-system-file ((system-release fs-system-release))
"Get the system object using the primary name and the source."
(let* ((source (system-release-source system-release))
(ht (fs-source-system-files-by-primary-name source))
(primary-name (asdf:primary-system-name
(system-name (system-release-system system-release)))))
(gethash primary-name ht)))
(fs-source-system-file (system-release-source system-release)))
(defmethod system-release-absolute-asd-pathname ((system-release fs-system-release))
"Get the absolute pathname using the system-file"
......
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