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

[mhenoch at common-lisp.net]

Author: mhenoch
Date: Fri Oct  6 15:55:15 2006
New Revision: 51

Added:
   cl-darcs/trunk/pristine.lisp
Modified:
   cl-darcs/trunk/get.lisp
   cl-darcs/trunk/pull.lisp
Log:
Add functions for keeping a pristine.  Use it when getting and pulling.


Modified: cl-darcs/trunk/get.lisp
==============================================================================
--- cl-darcs/trunk/get.lisp	(original)
+++ cl-darcs/trunk/get.lisp	Fri Oct  6 15:55:15 2006
@@ -64,6 +64,8 @@
 	  ;; What happens when adding patches one by one?
 	  (append-inventory outname patchinfo)
 	  (format t ".")))
+      (format t "~&Creating pristine")
+      (create-pristine-from-tree outname)
       (format t "~&All done"))))
 
 (defun select-some-patches (patchinfo-list)

Added: cl-darcs/trunk/pristine.lisp
==============================================================================
--- (empty file)
+++ cl-darcs/trunk/pristine.lisp	Fri Oct  6 15:55:15 2006
@@ -0,0 +1,28 @@
+;;; Copyright (C) 2006 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)
+
+(defun create-pristine-from-tree (repodir)
+  "Copy the checked-out tree at REPODIR to get a pristine tree."
+  (let* ((darcs-dir (upath-subdir repodir '("_darcs")))
+	 (pristine-dir (upath-subdir darcs-dir '("pristine"))))
+    (make-dir pristine-dir)
+    (copy-directory repodir pristine-dir :excluding (list darcs-dir))))
+
+(defun apply-patch-to-pristine (patch repodir)
+  "Apply PATCH to the pristine tree in REPODIR."
+  (apply-patch patch (upath-subdir repodir '("_darcs" "pristine"))))

Modified: cl-darcs/trunk/pull.lisp
==============================================================================
--- cl-darcs/trunk/pull.lisp	(original)
+++ cl-darcs/trunk/pull.lisp	Fri Oct  6 15:55:15 2006
@@ -49,11 +49,32 @@
 					     (make-instance 'composite-patch
 							    :patches our-patches)))))
 	(format t "~&Applying patches")
-	(dolist (p merged-patches)
-	  (apply-patch p ourrepo)
-	  ;; If this is not a named patch, our assumptions are
-	  ;; challenged.
-	  (append-inventory ourrepo (named-patch-patchinfo p))
-	  (write-patch-to-repo p ourrepo)
-	  (format t ".")))))
-  (format t "~&All done"))
+	(let ((applying-to-source t)
+	      (source-and-pristine-differ nil))
+	  (dolist (p merged-patches)
+	    ;; First, copy the modified patch to the repository.
+	    (write-patch-to-repo p ourrepo)
+	    ;; Then, apply it to the pristine copy.  This couldn't
+	    ;; possibly fail.
+	    (apply-patch-to-pristine p ourrepo)
+	    ;; Note the patch in the inventory.
+	    (append-inventory ourrepo (named-patch-patchinfo p))
+	    ;; And finally apply the patch to the real source.  This
+	    ;; could fail if the source has been modified.  Deal with
+	    ;; that in a crude way.  XXX: it is wasteful to apply
+	    ;; patches twice.
+	    (when applying-to-source
+	      (restart-case
+		  (apply-patch p ourrepo)
+		(skip-this ()
+		    :report "Don't apply this patch to the source tree (it was applied to the pristine tree)"
+		    (setf source-and-pristine-differ t))
+		(skip-all ()
+		    :report "Stop trying to apply patches to the source tree (they will be applied to the pristine tree)"
+		    (setf source-and-pristine-differ t)
+		    (setf applying-to-source nil))))
+	    (format t "."))
+	  (when source-and-pristine-differ
+	    (format t "~&~<Some patches could not be applied to the source tree.~
+You should manually merge changes from the pristine tree in _darcs/pristine/.~:@>")))))
+    (format t "~&All done")))