[Cl-darcs-cvs] r155 - cl-darcs/trunk

mhenoch at common-lisp.net mhenoch at common-lisp.net
Tue Jan 8 18:08:02 UTC 2008


Author: mhenoch
Date: Tue Jan  8 13:08:01 2008
New Revision: 155

Added:
   cl-darcs/trunk/condition.lisp
Modified:
   cl-darcs/trunk/cl-darcs.asd
   cl-darcs/trunk/pending.lisp
   cl-darcs/trunk/record.lisp
Log:
Remove pending patches after they are committed


Modified: cl-darcs/trunk/cl-darcs.asd
==============================================================================
--- cl-darcs/trunk/cl-darcs.asd	(original)
+++ cl-darcs/trunk/cl-darcs.asd	Tue Jan  8 13:08:01 2008
@@ -27,7 +27,8 @@
 
   :components
   ((:file "packages")
-   (:file "util" :depends-on ("packages" #-allegro "inflate"))
+   (:file "condition" :depends-on ("packages"))
+   (:file "util" :depends-on ("packages" "condition" #-allegro "inflate"))
    (:file "unreadable-stream" :depends-on ("packages"))
    (:file "upath" :depends-on ("util" #|"binary-text"|#))
 

Added: cl-darcs/trunk/condition.lisp
==============================================================================
--- (empty file)
+++ cl-darcs/trunk/condition.lisp	Tue Jan  8 13:08:01 2008
@@ -0,0 +1,27 @@
+;;; Copyright (C) 2008 Magnus Henoch
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
+
+(in-package :darcs)
+
+(define-condition repository-condition ()
+  ((repository :initarg :repository :type pathname
+	       :documentation "The absolute path of the concerned repository."))
+  (:documentation "Base class for conditions concerning a repository."))
+
+(define-condition repository-file-condition (repository-condition)
+  ((file :initarg :file :type pathname
+	 :documentation "The relative path of the concerned file or directory."))
+  (:documentation "Base class for conditions concerning a file in a repository."))

Modified: cl-darcs/trunk/pending.lisp
==============================================================================
--- cl-darcs/trunk/pending.lisp	(original)
+++ cl-darcs/trunk/pending.lisp	Tue Jan  8 13:08:01 2008
@@ -1,4 +1,4 @@
-;;; Copyright (C) 2007 Magnus Henoch
+;;; Copyright (C) 2007, 2008 Magnus Henoch
 ;;;
 ;;; This program is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU General Public License as
@@ -26,16 +26,34 @@
     (when (probe-file pending-file)
       (read-patch-from-file pending-file :compressed nil))))
 
+(defun write-pending (repodir patch)
+  "Write PATCH to the \"pending\" file in REPODIR.
+The previous file is overwritten."
+  (declare (type (or null composite-patch) patch))
+  (if (and patch (patches patch))
+      (with-open-file (out (pending-filename repodir)
+			   :direction :output :element-type '(unsigned-byte 8)
+			   :if-exists :supersede)
+	(write-patch patch out))
+      (delete-file (pending-filename repodir))))
+
 (defun add-to-pending (repodir patch)
   "Add PATCH to the list of \"pending\" patches in REPODIR."
   (let ((pending (read-pending repodir)))
     (when (null pending)
       (setf pending (make-instance 'composite-patch)))
     (setf (patches pending) (append (patches pending) (list patch)))
-    (with-open-file (out (pending-filename repodir)
-			 :direction :output :element-type '(unsigned-byte 8)
-			 :if-exists :supersede)
-      (write-patch pending out))))
+    (write-pending repodir pending)))
+
+(defun remove-matching-from-pending (repodir patches)
+  "Remove PATCHES from the list of \"pending\" patches in REPODIR."
+  ;; Currently we only have ADD-FILE-PATCH and ADD-DIR-PATCH in
+  ;; pending, which can be compared by EQUAL-PATCH.
+  (let ((pending (read-pending repodir)))
+    (when pending
+      (setf (patches pending)
+	    (nset-difference (patches pending) patches :test #'equal-patch))
+      (write-pending repodir pending))))
 
 (defun add-file (repo file)
   "Schedule FILE for recording to REPO.
@@ -52,10 +70,23 @@
 
     (let ((pristine-file (merge-pathnames file (upath-subdir repo '("_darcs" "pristine"))))
 	  (working-file (merge-pathnames file repo)))
-      (when (if (eql type :file)
-		(fad:file-exists-p pristine-file)
-		(fad:directory-exists-p pristine-file))
-	(error "~A already exists in the repository." (pathname-to-string file)))
+      ;; XXX: does this work properly for directories?
+      (when (or
+	     ;; Is file/directory already committed?
+	     (if (eql type :file)
+		 (fad:file-exists-p pristine-file)
+		 (fad:directory-exists-p pristine-file))
+	     ;; Or is it already added to pending?
+	     (let* ((pending (read-pending repo))
+		    (patches (when pending (patches pending))))
+	       (or
+		(find file patches 
+		      :key (lambda (p) (when (typep p 'add-file-patch) (patch-filename p)))
+		      :test #'equal)
+		(find file patches
+		      :key (lambda (p) (when (typep p 'add-dir-patch) (patch-directory p)))
+		      :test #'equal))))
+	(error 'already-in-repository :repository repo :file file))
       (when (not (if (eql type :file)
 		     (fad:file-exists-p working-file)
 		     (fad:directory-exists-p working-file)))
@@ -66,4 +97,13 @@
      repo 
      (if (eql type :file)
 	 (make-instance 'add-file-patch :filename file)
-	 (make-instance 'add-dir-patch :directory file)))))
\ No newline at end of file
+	 (make-instance 'add-dir-patch :directory file)))))
+
+(define-condition already-in-repository (repository-file-condition error)
+  ()
+  (:documentation "The file to be added already exists in the repository.")
+  (:report (lambda (condition stream)
+	     (format stream
+		     "~A already exists in the repository in ~A."
+		     (slot-value condition 'file)
+		     (slot-value condition 'repository)))))

Modified: cl-darcs/trunk/record.lisp
==============================================================================
--- cl-darcs/trunk/record.lisp	(original)
+++ cl-darcs/trunk/record.lisp	Tue Jan  8 13:08:01 2008
@@ -1,4 +1,4 @@
-;;; Copyright (C) 2006 Magnus Henoch
+;;; Copyright (C) 2006, 2008 Magnus Henoch
 ;;;
 ;;; This program is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU General Public License as
@@ -43,6 +43,7 @@
 					      :patches patches))))
     (write-patch-to-repo patch repo)
     (apply-patch-to-pristine patch repo)
+    (remove-matching-from-pending repo patches)
     (append-inventory repo patchinfo)))
 
 (defun record-changes (repo name author date log)



More information about the Cl-darcs-cvs mailing list