[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