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

Do not call MAKE-INSTANCE directly on sources

parent a8d2f57f
......@@ -84,13 +84,12 @@
"Set the ~clpmfile~'s filesystem source based on the directory where the
clpmfile is located."
(setf (clpmfile-fs-source clpmfile)
(make-instance 'fs-source
:root-pathname (uiop:pathname-directory-pathname
(uiop:make-pathname* :directory '(:relative)))
:name :clpmfile-fs))
(make-source 'fs-source
:root-pathname (uiop:pathname-directory-pathname
(uiop:make-pathname* :directory '(:relative)))
:name :clpmfile-fs))
(setf (clpmfile-vcs-source clpmfile)
(make-instance 'vcs-source
:name :clpmfile-vcs)))
(make-source 'vcs-source :name :clpmfile-vcs)))
(defun clpmfile-asd-file-requirements (clpmfile)
"Return a list of requirements gathered from the ~:asd~ statements in
......
......@@ -36,6 +36,13 @@
:initarg :url
:accessor source-url)))
(defmethod make-source ((type (eql 'clpi-source)) &rest initargs &key url name)
(let ((url-string (if (stringp url) url (uri-to-string url))))
(ensure-gethash (list type name url-string) *source-cache*
(apply #'make-instance
type
initargs))))
(defmethod initialize-instance :after ((source clpi-source)
&rest initargs
&key url)
......
......@@ -39,7 +39,7 @@
(eql type :vcs)
(stringp name)))
(assert (keywordp type))
(apply #'make-instance
(apply #'make-source
(resolve-type type)
:name name
(remove-from-plist args :type))))
......
......@@ -11,12 +11,14 @@
#:clpm/data
#:puri
#:split-sequence)
(:export #:clpm-project
(:export #:*source-cache*
#:clpm-project
#:clpm-release
#:clpm-source
#:clpm-system
#:clpm-system-file
#:clpm-system-release
#:make-source
#:project
#:project-missing-version
#:project-name
......@@ -116,6 +118,21 @@
(:documentation "Base class for any CLPM source. A source contains projects
and systems."))
(defvar *source-cache*)
(defun init-source-cache ()
(unless (boundp '*source-cache*)
(setf *source-cache* (make-hash-table :test 'equal))))
(uiop:register-image-restore-hook 'init-source-cache)
(defun clear-source-cache ()
(makunbound '*source-cache*))
(uiop:register-clear-configuration-hook 'clear-source-cache)
(defgeneric make-source (type &key &allow-other-keys)
(:documentation "Get a source of TYPE. This may return a new instance or an
existing instance that was made with similar arguments."))
(defgeneric source-cache-directory (source)
(:documentation "The source's cache directory."))
......
......@@ -61,6 +61,15 @@ project (:ALL) and one release (:NEWEST). Does not do any autodiscovery of
system files, system files must be registered with the source using
FS-SOURCE-REGISTER-ASD."))
(defmethod make-source ((type (eql 'fs-source)) &rest initargs
&key system-files name root-pathname)
(aprog1 (ensure-gethash (list type name root-pathname) *source-cache*
(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
......@@ -125,13 +134,14 @@ can be relative (to the source's root dir) or absolute."
(setf asd-pathname (enough-namestring asd-pathname (merge-pathnames (fs-source-root-pathname fs-source)))))
(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))
(system-file (make-instance 'fs-system-file
:source fs-source
:release (fs-project-release (fs-source-project fs-source))
:enough-namestring namestring)))
(setf (gethash (pathname-name namestring) primary-name-ht) system-file
(gethash namestring namestring-ht) system-file)))
(namestring (namestring asd-pathname)))
(aprog1 (ensure-gethash (pathname-name namestring) primary-name-ht
(make-instance 'fs-system-file
:source fs-source
:release (fs-project-release (fs-source-project fs-source))
:enough-namestring namestring))
(setf (gethash namestring namestring-ht) it))))
(defmethod source-to-form ((source fs-source))
(let* ((project (source-project source :all))
......
......@@ -36,6 +36,13 @@
:initarg :url
:accessor ql-flat-source-url)))
(defmethod make-source ((type (eql 'ql-flat-source)) &rest initargs &key url name)
(let ((url-string (if (stringp url) url (uri-to-string url))))
(ensure-gethash (list type name url-string) *source-cache*
(apply #'make-instance
type
initargs))))
(defmethod initialize-instance :after ((source ql-flat-source)
&rest initargs
&key url)
......
......@@ -48,6 +48,15 @@
"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)
(aprog1 (ensure-gethash (list type name) *source-cache*
(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)
......
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