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)