Commit 22879d0f authored by Eric Timmons's avatar Eric Timmons
Browse files

Fix bug saving projects

parent e695fdd1
...@@ -39,9 +39,12 @@ ...@@ -39,9 +39,12 @@
(release-data-read-p (release-data-read-p
:initform nil :initform nil
:accessor project-release-data-read-p) :accessor project-release-data-read-p)
(deltas (release-deltas
:initform nil :initform nil
:accessor project-deltas)) :accessor project-release-deltas)
(slots-changed
:initform nil
:accessor project-slots-changed))
(:documentation (:documentation
"The base implementation of projects. Contains a mapping from version string "The base implementation of projects. Contains a mapping from version string
to release objects. When this mapping is accessed for the first time, all to release objects. When this mapping is accessed for the first time, all
...@@ -56,6 +59,15 @@ instantiated.")) ...@@ -56,6 +59,15 @@ instantiated."))
(setf (gethash r release-ht) nil)) (setf (gethash r release-ht) nil))
(setf (project-release-ht project) release-ht))) (setf (project-release-ht project) release-ht)))
(defmethod (setf project-repo) :after (new-value (project project))
(pushnew 'repo (project-slots-changed project)))
(defmethod (setf project-version-scheme) :after (new-value (project project))
(pushnew 'version-scheme (project-slots-changed project)))
(defmethod (setf project-releases-object-version) :after (new-value (project project))
(pushnew 'releases-object-version (project-slots-changed project)))
(defmethod index-project-class (index) (defmethod index-project-class (index)
"Register this as the default project class." "Register this as the default project class."
'project) 'project)
...@@ -70,16 +82,18 @@ instantiated.")) ...@@ -70,16 +82,18 @@ instantiated."))
(unless (eql (project new-release) project) (unless (eql (project new-release) project)
(error "This release does not belong to this project!")) (error "This release does not belong to this project!"))
(setf (gethash (release-version new-release) (project-release-ht project)) new-release) (setf (gethash (release-version new-release) (project-release-ht project)) new-release)
(push (cons :add-release new-release) (project-deltas project)) (push (cons :add-release new-release) (project-release-deltas project))
project) project)
(defmethod project-changes-appendable-p ((project project)) (defmethod project-changes-appendable-p ((project project))
(every (lambda (x) (every (lambda (x)
(eql (car x) :add-release)) (eql (car x) :add-release))
(project-deltas project))) (project-release-deltas project)))
(defmethod project-dirty-p ((project project)) (defmethod project-dirty-p ((project project))
(project-deltas project)) (or
(project-release-deltas project)
(project-slots-changed project)))
(defmethod slot-unbound (class (project project) (slot-name (eql 'releases-object-version))) (defmethod slot-unbound (class (project project) (slot-name (eql 'releases-object-version)))
(with-open-object-stream (s (index-object-store (index project)) (with-open-object-stream (s (index-object-store (index project))
...@@ -152,39 +166,41 @@ instantiated.")) ...@@ -152,39 +166,41 @@ instantiated."))
:if-exists (if appendable-p :append :supersede)) :if-exists (if appendable-p :append :supersede))
(if appendable-p (if appendable-p
(project-write-changes-to-stream project s) (project-write-changes-to-stream project s)
(project-write-to-stream project s))) (project-write-to-stream project s))))
(awhen (project-releases-object-version project) (awhen (and (member 'releases-object-version (project-slots-changed project))
(with-open-object-stream (s (index-object-store (index project)) (project-releases-object-version project))
(project-object-path project "releases-object-version") (with-open-object-stream (s (index-object-store (index project))
:direction :output (project-object-path project "releases-object-version")
:if-exists :supersede) :direction :output
(with-clpi-io-syntax () :if-exists :supersede)
(write it :stream s) (with-clpi-io-syntax ()
(terpri s)))) (write it :stream s)
(when (slot-boundp project 'repo) (terpri s))))
(with-open-object-stream (s (index-object-store (index project)) (project-object-path project "repo") (when (member 'repo (project-slots-changed project))
:direction :output (with-open-object-stream (s (index-object-store (index project)) (project-object-path project "repo")
:if-exists :supersede) :direction :output
(with-clpi-io-syntax () :if-exists :supersede)
(write (repo-to-description (project-repo project)) :stream s) (with-clpi-io-syntax ()
(terpri s)))) (write (repo-to-description (project-repo project)) :stream s)
(when (slot-boundp project 'version-scheme) (terpri s))))
(with-open-object-stream (s (index-object-store (index project)) (when (member 'version-scheme (project-slots-changed project))
(project-object-path project "version-scheme") (with-open-object-stream (s (index-object-store (index project))
:direction :output (project-object-path project "version-scheme")
:if-exists :supersede) :direction :output
(with-clpi-io-syntax () :if-exists :supersede)
(write (project-version-scheme project) :stream s) (with-clpi-io-syntax ()
(terpri s))))))) (write (project-version-scheme project) :stream s)
(terpri s))))
(setf (project-slots-changed project) nil)))
(defmethod project-versions ((project project)) (defmethod project-versions ((project project))
(hash-table-keys (project-release-ht project))) (hash-table-keys (project-release-ht project)))
(defmethod project-write-changes-to-stream ((project project) s) (defmethod project-write-changes-to-stream ((project project) s)
(assert (every (lambda (x) (eql (car x) :add-release)) (project-deltas project))) (assert (every (lambda (x) (eql (car x) :add-release)) (project-release-deltas project)))
(let ((release-descs (mapcar (lambda (release) (let ((release-descs (mapcar (lambda (release)
(list* (release-version release) (release-plist release))) (list* (release-version release) (release-plist release)))
(mapcar #'cdr (project-deltas project)))) (mapcar #'cdr (project-release-deltas project))))
(version-scheme (project-version-scheme project))) (version-scheme (project-version-scheme project)))
(when version-scheme (when version-scheme
(setf release-descs (sort release-descs (ecase version-scheme (setf release-descs (sort release-descs (ecase version-scheme
...@@ -201,7 +217,7 @@ instantiated.")) ...@@ -201,7 +217,7 @@ instantiated."))
(write release-desc (write release-desc
:stream s) :stream s)
(terpri s)))) (terpri s))))
(setf (project-deltas project) nil)) (setf (project-release-deltas project) nil))
(defmethod project-write-to-stream ((project project) s) (defmethod project-write-to-stream ((project project) s)
(let ((release-descs (mapcar (lambda (release) (let ((release-descs (mapcar (lambda (release)
...@@ -223,7 +239,7 @@ instantiated.")) ...@@ -223,7 +239,7 @@ instantiated."))
(write release-desc (write release-desc
:stream s) :stream s)
(terpri s)))) (terpri s))))
(setf (project-deltas project) nil)) (setf (project-release-deltas project) nil))
(defmethod slot-unbound (class (project project) (slot-name (eql 'repo))) (defmethod slot-unbound (class (project project) (slot-name (eql 'repo)))
"Create the repository object on demand." "Create the repository object on demand."
......
Supports Markdown
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