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

Fix bug saving projects

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