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

Fix bug saving projects

parent e695fdd1
Loading
Loading
Loading
Loading
+49 −33
Original line number Diff line number Diff line
@@ -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,8 +166,9 @@ 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)
            (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
@@ -161,30 +176,31 @@ instantiated."))
        (with-clpi-io-syntax ()
          (write it :stream s)
          (terpri s))))
      (when (slot-boundp project 'repo)
    (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 (slot-boundp project 'version-scheme)
    (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)))))))
          (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."