From mhenoch at common-lisp.net  Sat Jul  8 11:55:06 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Sat,  8 Jul 2006 07:55:06 -0400 (EDT)
Subject: [Cl-darcs-cvs] r16 - cl-darcs/trunk
Message-ID: <20060708115506.BD3981B000@common-lisp.net>

Author: mhenoch
Date: Sat Jul  8 07:55:06 2006
New Revision: 16

Modified:
   cl-darcs/trunk/touching.lisp
Log:
Declare filename argument as ignored.


Modified: cl-darcs/trunk/touching.lisp
==============================================================================
--- cl-darcs/trunk/touching.lisp	(original)
+++ cl-darcs/trunk/touching.lisp	Sat Jul  8 07:55:06 2006
@@ -25,6 +25,7 @@
 
 (defmethod find-touching ((patch patch) filename)
   "This least specific method returns NIL."
+  (declare (ignore filename))
   nil)
 
 (defmethod find-touching ((patch composite-patch) filename)


From mhenoch at common-lisp.net  Sat Jul  8 14:03:30 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Sat,  8 Jul 2006 10:03:30 -0400 (EDT)
Subject: [Cl-darcs-cvs] r17 - cl-darcs/trunk
Message-ID: <20060708140330.0C04F2F029@common-lisp.net>

Author: mhenoch
Date: Sat Jul  8 10:03:30 2006
New Revision: 17

Modified:
   cl-darcs/trunk/unwind.lisp
Log:
In put-before, handle case of empty patch list correctly.


Modified: cl-darcs/trunk/unwind.lisp
==============================================================================
--- cl-darcs/trunk/unwind.lisp	(original)
+++ cl-darcs/trunk/unwind.lisp	Sat Jul  8 10:03:30 2006
@@ -73,11 +73,12 @@
 and commuted through PATCHES, to finally give a list of patches
 whose context consists of P1.  If any commutation fails, this
 operation fails as well."
-  (destructuring-bind (&optional p2-c p1-c) (commute (invert-patch p1) (car patches))
-    (and p2-c p1-c
-	 (commute p1 p2-c)
-	 (let ((rest (put-before p1-c (cdr patches))))
-	   (and rest (cons p2-c rest))))))
+  (when patches
+    (destructuring-bind (&optional p2-c p1-c) (commute (invert-patch p1) (car patches))
+      (and p2-c p1-c
+	   (commute p1 p2-c)
+	   (let ((rest (put-before p1-c (cdr patches))))
+	     (and rest (cons p2-c rest)))))))
 
 (defun all-head-permutations (ps)
   "Return all possible permutations of PS.


From mhenoch at common-lisp.net  Sat Jul  8 15:05:25 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Sat,  8 Jul 2006 11:05:25 -0400 (EDT)
Subject: [Cl-darcs-cvs] r18 - cl-darcs/trunk
Message-ID: <20060708150525.E6C476D01E@common-lisp.net>

Author: mhenoch
Date: Sat Jul  8 11:05:25 2006
New Revision: 18

Modified:
   cl-darcs/trunk/equal.lisp
Log:
Use normal method combination for equal-patch.


Modified: cl-darcs/trunk/equal.lisp
==============================================================================
--- cl-darcs/trunk/equal.lisp	(original)
+++ cl-darcs/trunk/equal.lisp	Sat Jul  8 11:05:25 2006
@@ -15,25 +15,23 @@
 (defgeneric equal-patch (a b &optional really)
   (:documentation "Return true if patches A and B are equal.
 If REALLY is false, consider named patches with the same name
-to be equal, regardless of content.")
-  (:method-combination and :most-specific-last))
+to be equal, regardless of content."))
 
-(defmethod equal-patch :around ((a patch) (b patch) &optional really)
+(defmethod equal-patch ((a patch) (b patch) &optional really)
   "If there are no methods for comparing A and B, they are not equal."
   (declare (ignore really))
-  (if (next-method-p)
-      (call-next-method)
-      nil))
+  nil)
 
-(defmethod equal-patch and ((a file-patch) (b file-patch) &optional really)
+(defmethod equal-patch :around ((a file-patch) (b file-patch) &optional really)
   "Compare two file patches.
 Two file patches can be equal only if they are of the same type and
 patch the same file."
   (declare (ignore really))
-  (and (eq (class-of a) (class-of b))
-       (equal (patch-filename a) (patch-filename b))))
+  (when (and (eq (class-of a) (class-of b))
+	     (equal (patch-filename a) (patch-filename b)))
+    (call-next-method)))
 
-(defmethod equal-patch and ((a hunk-patch) (b hunk-patch) &optional really)
+(defmethod equal-patch ((a hunk-patch) (b hunk-patch) &optional really)
   "Compare two hunk patches."
   (declare (ignore really))
   (flet ((compare (accessor)
@@ -44,13 +42,7 @@
 	 (compare #'hunk-old-lines)
 	 (compare #'hunk-new-lines))))
 
-(defmethod equal-patch and ((a binary-patch) (b binary-patch) &optional really)
-  "Compare two binary patches."
-  (declare (ignore really))
-  (and (equalp (binary-oldhex a) (binary-oldhex b))
-       (equalp (binary-newhex a) (binary-newhex b))))
-
-(defmethod equal-patch and ((a token-replace-patch) (b token-replace-patch) &optional really)
+(defmethod equal-patch ((a token-replace-patch) (b token-replace-patch) &optional really)
   "Compare two token replacing patches."
   (declare (ignore really))
   (flet ((compare (accessor)
@@ -60,7 +52,13 @@
 	 (compare #'old-token)
 	 (compare #'new-token))))
 
-(defmethod equal-patch and ((a merger-patch) (b merger-patch) &optional really)
+(defmethod equal-patch ((a binary-patch) (b binary-patch) &optional really)
+  "Compare two binary patches."
+  (declare (ignore really))
+  (and (equalp (binary-oldhex a) (binary-oldhex b))
+       (equalp (binary-newhex a) (binary-newhex b))))
+
+(defmethod equal-patch ((a merger-patch) (b merger-patch) &optional really)
   "Compare two merger patches."
   (and (string= (merger-version a) (merger-version b))
        (eql (merger-inverted a) (merger-inverted b))


From mhenoch at common-lisp.net  Sat Jul  8 22:50:33 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Sat,  8 Jul 2006 18:50:33 -0400 (EDT)
Subject: [Cl-darcs-cvs] r19 - cl-darcs/trunk
Message-ID: <20060708225033.9780B1C00C@common-lisp.net>

Author: mhenoch
Date: Sat Jul  8 18:50:33 2006
New Revision: 19

Modified:
   cl-darcs/trunk/unreadable-stream.lisp
Log:
Clear EOF flag when something is unread


Modified: cl-darcs/trunk/unreadable-stream.lisp
==============================================================================
--- cl-darcs/trunk/unreadable-stream.lisp	(original)
+++ cl-darcs/trunk/unreadable-stream.lisp	Sat Jul  8 18:50:33 2006
@@ -167,11 +167,13 @@
 
 (defmethod unread-byte ((stream unreadable-stream) byte)
   "Store BYTE at the head of the unread buffer."
+  (setf (slot-value stream 'at-end-of-file) nil)
   (push byte (slot-value stream 'buffer)))
 
 (defmethod unread-sequence ((stream unreadable-stream) sequence)
   "Store SEQUENCE at the head of the unread buffer.
 It is assumed that SEQUENCE will not be modified."
+  (setf (slot-value stream 'at-end-of-file) nil)
   (with-slots (buffer) stream
     ;; Empty sequences must not be stored in the buffer.
     (unless (zerop (length sequence))
@@ -180,6 +182,7 @@
 (defmethod unread-line ((stream unreadable-stream) line)
   "Store LINE with an appended newline at the head of the unread buffer.
 It is assumed that SEQUENCE will not be modified."
+  (setf (slot-value stream 'at-end-of-file) nil)
   (with-slots (buffer) stream
     ;; If the line is empty, just store a newline.
     (if (zerop (length line))


From mhenoch at common-lisp.net  Sun Jul  9 16:52:18 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Sun,  9 Jul 2006 12:52:18 -0400 (EDT)
Subject: [Cl-darcs-cvs] r20 - cl-darcs/trunk
Message-ID: <20060709165218.CF9085E1A0@common-lisp.net>

Author: mhenoch
Date: Sun Jul  9 12:52:18 2006
New Revision: 20

Modified:
   cl-darcs/trunk/read-patch.lisp
Log:
Fix inverted confusion for read-merger


Modified: cl-darcs/trunk/read-patch.lisp
==============================================================================
--- cl-darcs/trunk/read-patch.lisp	(original)
+++ cl-darcs/trunk/read-patch.lisp	Sun Jul  9 12:52:18 2006
@@ -97,10 +97,10 @@
        (read-change-pref stream))
 
       ((string= token "merger")
-       (read-merger stream t))
+       (read-merger stream nil))
 
       ((string= token "regrem")
-       (read-merger stream nil))
+       (read-merger stream t))
 
       ((string= token "conflict")
        (read-conflict stream))


From mhenoch at common-lisp.net  Tue Jul 11 16:07:38 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Tue, 11 Jul 2006 12:07:38 -0400 (EDT)
Subject: [Cl-darcs-cvs] r21 - cl-darcs/trunk
Message-ID: <20060711160738.40DB436022@common-lisp.net>

Author: mhenoch
Date: Tue Jul 11 12:07:37 2006
New Revision: 21

Modified:
   cl-darcs/trunk/commute.lisp
Log:
Add default method for commute.


Modified: cl-darcs/trunk/commute.lisp
==============================================================================
--- cl-darcs/trunk/commute.lisp	(original)
+++ cl-darcs/trunk/commute.lisp	Tue Jul 11 12:07:37 2006
@@ -6,6 +6,11 @@
 P1-NEW has the same effect as applying P1 and then P2.
 If commutations fails, return nil."))
 
+(defmethod commute ((p2 patch) (p1 patch))
+  "Default method prints a warning and returns nil."
+  (warn "No method defined for commuting ~A and ~A." p2 p1)
+  nil)
+
 (defmethod commute :around ((p2 file-patch) (p1 file-patch))
   "If P1 and P2 change different files, commutation is trivial."
   (let ((p1-file (patch-filename p1))


From mhenoch at common-lisp.net  Tue Jul 11 16:08:36 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Tue, 11 Jul 2006 12:08:36 -0400 (EDT)
Subject: [Cl-darcs-cvs] r22 - cl-darcs/trunk
Message-ID: <20060711160836.D5CA137002@common-lisp.net>

Author: mhenoch
Date: Tue Jul 11 12:08:36 2006
New Revision: 22

Modified:
   cl-darcs/trunk/get.lisp
Log:
Read patchinfo structures per tag.  Write proper inventory files when getting a tree.


Modified: cl-darcs/trunk/get.lisp
==============================================================================
--- cl-darcs/trunk/get.lisp	(original)
+++ cl-darcs/trunk/get.lisp	Tue Jul 11 12:08:36 2006
@@ -22,12 +22,16 @@
   ;; other access methods later...
   ;; XXX: checkpoints?
   (let* ((repodir (make-upath inrepodir))
+	 ;; Here we get a list of lists.  Each list represents a tag;
+	 ;; the latest tag is at the head.  Each list contains patches
+	 ;; in the order they are to be applied.
 	 (patchinfo-list (read-repo-patch-list repodir))
 	 ;; We should probably download checkpoint patches, btw...
 	 (checkpoint (when partial
 		       (car (last (read-checkpoint-list repodir))))))
     ;; Create directories...
     (prepare-new-repo outname)
+    (set-default-repo outname inrepodir)
 
     (when checkpoint
       (format t "~&Copying checkpoint...")
@@ -37,11 +41,14 @@
 	(apply-patch checkpoint-patch outname))
       (format t "done"))
 
+    (write-inventory outname patchinfo-list)
+
     (let ((patches (if checkpoint
+		       ;; XXX: patchinfo-list is a list of lists now
 		       (find-remaining-patches patchinfo-list checkpoint)
-		       patchinfo-list)))
+		       (apply #'append (reverse patchinfo-list)))))
       (copy-repo-patches repodir outname patches)
-
+      
       (if (or (null query) (y-or-n-p "Apply patches?"))
 	  (progn
 	    (format t "~&Applying patches")
@@ -84,16 +91,21 @@
   (make-dir outname)
   (make-dir (merge-pathnames (make-pathname :directory (list :relative "_darcs"))
 			     outname))
-  (dolist (dir '("patches" "checkpoints" "prefs"))
+  (dolist (dir '("patches" "checkpoints" "prefs" "inventories"))
     (make-dir (merge-pathnames
 	       (make-pathname :directory (list :relative "_darcs" dir))
-	       outname))))
+	       outname)))
+  (write-default-prefs outname))
 
 ;; {lazily,}read_repo in DarcsRepo.lhs
 ;; read_repo_private in DarcsRepo.lhs
 (defun read-repo-patch-list (inrepodir &optional inventory-file)
   "Read patch info for INREPODIR from INVENTORY-FILE.
-Return a list of patchinfo structures."
+Return a list of lists of patchinfo structures.
+
+Note that this function returns patchinfo structures in the order
+they were applied, unlike the real darcs which often uses reverse
+order."
   (when (null inventory-file)
     (setf inventory-file (upath-subdir inrepodir '("_darcs") "inventory")))
   (let (tag-patches patches)
@@ -106,8 +118,9 @@
 		    ;; read the first patch...
 		    (read-patchinfo in))
 		   (new-filename (patchinfo-make-filename tag-patch)))
-	      ;; ...for the first patch is a tag.  Recursively read the
-	      ;; inventory of that file.
+	      ;; ...for the first patch is a tag.  Recursively read
+	      ;; the inventory of that file.  The tag patch then goes
+	      ;; at the head of the current list of patches.
 	      (setf tag-patches
 		    (read-repo-patch-list
 		     inrepodir (upath-subdir inrepodir '("_darcs" "inventories") new-filename)))
@@ -117,10 +130,11 @@
       ;; Then, just read all patches in the file.
       (format t "~&Reading patchinfo from ~A" inventory-file)
       (setf patches
-	    (loop for patch = (read-patchinfo in)
-	       while patch collect patch
-	       do (princ #\.))))
-    (nconc tag-patches patches)))
+	    (nconc patches
+		   (loop for patch = (read-patchinfo in)
+		      while patch collect patch
+		      do (princ #\.)))))
+    (cons patches tag-patches)))
 
 (defun read-patch-from-repo (repodir patchinfo)
   "Read patch named by PATCHINFO from REPODIR."
@@ -181,3 +195,48 @@
 			     (upath-subdir from '("_darcs" "checkpoints") filename)
 			     :binary t))
 	(fad:copy-stream in out)))))
+
+(defun write-inventory (out patchinfo-list &optional file)
+  "Write PATCHINFO-LIST as inventory in OUT.
+FILE is either nil, meaning the main \"inventory\" file, or a
+string naming a file in the \"inventories\" directory."
+  ;; XXX: slightly_optimize_patchset?
+  (let ((inventory-file (cond
+			  ((null file)
+			   (merge-pathnames
+			    (make-pathname :directory '(:relative "_darcs")
+					   :name "inventory")
+			    out))
+			  (t
+			   (merge-pathnames
+			    (make-pathname :directory '(:relative "_darcs" "inventories")
+					   :name file)
+			    out)))))
+    (with-open-file (f inventory-file :direction :output :if-exists :supersede
+		       :element-type '(unsigned-byte 8))
+      (flet ((print-patchinfos (patchinfos)
+	       ;; Convert output to binary, using the most direct possible
+	       ;; method...
+	       (dolist (patchinfo patchinfos)
+		 (map nil (lambda (char)
+			    (write-byte (char-code char) f))
+		      (with-output-to-string (strout)
+			(write-patchinfo patchinfo strout)))
+		 (write-byte 10 f))))
+	(cond
+	  ((null patchinfo-list)
+	   ;; No patches - empty inventory file.  Nothing to do.
+	   )
+	  ((null (cdr patchinfo-list))
+	   ;; One patch list - no remaining tags.
+
+	   (print-patchinfos (car patchinfo-list)))
+	  (t
+	   ;; Several patch lists, one for each tag
+	   (let* ((this-tag (car patchinfo-list))
+		  (other-tags (cdr patchinfo-list))
+		  (tag-name (patchinfo-make-filename (car this-tag))))
+	     (write-inventory out other-tags tag-name)
+	     (write-sequence (map 'vector #'char-code "Starting with tag:") f)
+	     (write-byte 10 f)
+	     (print-patchinfos (car patchinfo-list)))))))))


From mhenoch at common-lisp.net  Wed Jul 12 14:21:13 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Wed, 12 Jul 2006 10:21:13 -0400 (EDT)
Subject: [Cl-darcs-cvs] r23 - cl-darcs/trunk
Message-ID: <20060712142113.B7B1753010@common-lisp.net>

Author: mhenoch
Date: Wed Jul 12 10:21:13 2006
New Revision: 23

Added:
   cl-darcs/trunk/repo.lisp
Modified:
   cl-darcs/trunk/cl-darcs.asd
   cl-darcs/trunk/get.lisp
Log:
Split get.lisp, add repo.lisp


Modified: cl-darcs/trunk/cl-darcs.asd
==============================================================================
--- cl-darcs/trunk/cl-darcs.asd	(original)
+++ cl-darcs/trunk/cl-darcs.asd	Wed Jul 12 10:21:13 2006
@@ -31,6 +31,7 @@
    (:file "get" :depends-on ("util"))
    (:file "init" :depends-on ("util"))
    (:file "prefs" :depends-on ("util"))
+   (:file "repo" :depends-on ("util"))
 
    (:file "patch-core" :depends-on ("util"))
    (:file "read-patch" :depends-on ("patch-core"))

Modified: cl-darcs/trunk/get.lisp
==============================================================================
--- cl-darcs/trunk/get.lisp	(original)
+++ cl-darcs/trunk/get.lisp	Wed Jul 12 10:21:13 2006
@@ -86,77 +86,6 @@
 	  (format t "."))
 	(format t "~&Done")))))
 
-(defun prepare-new-repo (outname)
-  "Create directories for starting a repo at OUTNAME."
-  (make-dir outname)
-  (make-dir (merge-pathnames (make-pathname :directory (list :relative "_darcs"))
-			     outname))
-  (dolist (dir '("patches" "checkpoints" "prefs" "inventories"))
-    (make-dir (merge-pathnames
-	       (make-pathname :directory (list :relative "_darcs" dir))
-	       outname)))
-  (write-default-prefs outname))
-
-;; {lazily,}read_repo in DarcsRepo.lhs
-;; read_repo_private in DarcsRepo.lhs
-(defun read-repo-patch-list (inrepodir &optional inventory-file)
-  "Read patch info for INREPODIR from INVENTORY-FILE.
-Return a list of lists of patchinfo structures.
-
-Note that this function returns patchinfo structures in the order
-they were applied, unlike the real darcs which often uses reverse
-order."
-  (when (null inventory-file)
-    (setf inventory-file (upath-subdir inrepodir '("_darcs") "inventory")))
-  (let (tag-patches patches)
-    (with-open-stream (in (make-instance 'unreadable-stream
-					 :base-stream (open-upath inventory-file :binary t)))
-      ;; If first line is "Starting with tag:",
-      (let ((first-line (read-binary-line in)))
-	(if (string= (bytes-to-string first-line) "Starting with tag:")
-	    (let* ((tag-patch
-		    ;; read the first patch...
-		    (read-patchinfo in))
-		   (new-filename (patchinfo-make-filename tag-patch)))
-	      ;; ...for the first patch is a tag.  Recursively read
-	      ;; the inventory of that file.  The tag patch then goes
-	      ;; at the head of the current list of patches.
-	      (setf tag-patches
-		    (read-repo-patch-list
-		     inrepodir (upath-subdir inrepodir '("_darcs" "inventories") new-filename)))
-	      (setf patches (list tag-patch)))
-	    ;; If it's not, pretend we never read that line.
-	    (unread-line in first-line)))
-      ;; Then, just read all patches in the file.
-      (format t "~&Reading patchinfo from ~A" inventory-file)
-      (setf patches
-	    (nconc patches
-		   (loop for patch = (read-patchinfo in)
-		      while patch collect patch
-		      do (princ #\.)))))
-    (cons patches tag-patches)))
-
-(defun read-patch-from-repo (repodir patchinfo)
-  "Read patch named by PATCHINFO from REPODIR."
-  (read-patch-from-file
-   (upath-subdir repodir '("_darcs" "patches") (patchinfo-make-filename patchinfo))))
-
-(defun read-checkpoint-from-repo (repodir patchinfo)
-  "Read checkpoint named by PATCHINFO from REPODIR."
-  (read-patch-from-file
-   (upath-subdir repodir '("_darcs" "checkpoints") (patchinfo-make-filename patchinfo))))
-
-(defun read-checkpoint-list (repodir)
-  "Read a list of checkpoints from REPODIR.
-Return as a patchinfo list."
-  ;; If there are no checkpoints, it doesn't matter.
-  (ignore-errors
-    (with-open-stream (in (open-upath (upath-subdir repodir '("_darcs" "checkpoints") "inventory")))
-      (format t "~&Reading checkpoints")
-      (loop for patch = (read-patchinfo in)
-	 while patch collect patch
-	 do (princ #\.)))))
-
 (defun find-remaining-patches (patchinfo-list checkpoint)
   "Find the patches remaining after getting to CHECKPOINT."
   ;; XXX: this is incorrect; the checkpoint isn't among ordinary patches.
@@ -196,47 +125,3 @@
 			     :binary t))
 	(fad:copy-stream in out)))))
 
-(defun write-inventory (out patchinfo-list &optional file)
-  "Write PATCHINFO-LIST as inventory in OUT.
-FILE is either nil, meaning the main \"inventory\" file, or a
-string naming a file in the \"inventories\" directory."
-  ;; XXX: slightly_optimize_patchset?
-  (let ((inventory-file (cond
-			  ((null file)
-			   (merge-pathnames
-			    (make-pathname :directory '(:relative "_darcs")
-					   :name "inventory")
-			    out))
-			  (t
-			   (merge-pathnames
-			    (make-pathname :directory '(:relative "_darcs" "inventories")
-					   :name file)
-			    out)))))
-    (with-open-file (f inventory-file :direction :output :if-exists :supersede
-		       :element-type '(unsigned-byte 8))
-      (flet ((print-patchinfos (patchinfos)
-	       ;; Convert output to binary, using the most direct possible
-	       ;; method...
-	       (dolist (patchinfo patchinfos)
-		 (map nil (lambda (char)
-			    (write-byte (char-code char) f))
-		      (with-output-to-string (strout)
-			(write-patchinfo patchinfo strout)))
-		 (write-byte 10 f))))
-	(cond
-	  ((null patchinfo-list)
-	   ;; No patches - empty inventory file.  Nothing to do.
-	   )
-	  ((null (cdr patchinfo-list))
-	   ;; One patch list - no remaining tags.
-
-	   (print-patchinfos (car patchinfo-list)))
-	  (t
-	   ;; Several patch lists, one for each tag
-	   (let* ((this-tag (car patchinfo-list))
-		  (other-tags (cdr patchinfo-list))
-		  (tag-name (patchinfo-make-filename (car this-tag))))
-	     (write-inventory out other-tags tag-name)
-	     (write-sequence (map 'vector #'char-code "Starting with tag:") f)
-	     (write-byte 10 f)
-	     (print-patchinfos (car patchinfo-list)))))))))

Added: cl-darcs/trunk/repo.lisp
==============================================================================
--- (empty file)
+++ cl-darcs/trunk/repo.lisp	Wed Jul 12 10:21:13 2006
@@ -0,0 +1,134 @@
+;;; 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 prepare-new-repo (outname)
+  "Create directories for starting a repo at OUTNAME."
+  (make-dir outname)
+  (make-dir (merge-pathnames (make-pathname :directory (list :relative "_darcs"))
+			     outname))
+  (dolist (dir '("patches" "checkpoints" "prefs" "inventories"))
+    (make-dir (merge-pathnames
+	       (make-pathname :directory (list :relative "_darcs" dir))
+	       outname)))
+  (write-default-prefs outname))
+
+;; {lazily,}read_repo in DarcsRepo.lhs
+;; read_repo_private in DarcsRepo.lhs
+(defun read-repo-patch-list (inrepodir &optional inventory-file)
+  "Read patch info for INREPODIR from INVENTORY-FILE.
+Return a list of lists of patchinfo structures.
+
+Note that this function returns patchinfo structures in the order
+they were applied, unlike the real darcs which often uses reverse
+order."
+  (when (null inventory-file)
+    (setf inventory-file (upath-subdir inrepodir '("_darcs") "inventory")))
+  (let (tag-patches patches)
+    (with-open-stream (in (make-instance 'unreadable-stream
+					 :base-stream (open-upath inventory-file :binary t)))
+      ;; If first line is "Starting with tag:",
+      (let ((first-line (read-binary-line in)))
+	(if (string= (bytes-to-string first-line) "Starting with tag:")
+	    (let* ((tag-patch
+		    ;; read the first patch...
+		    (read-patchinfo in))
+		   (new-filename (patchinfo-make-filename tag-patch)))
+	      ;; ...for the first patch is a tag.  Recursively read
+	      ;; the inventory of that file.  The tag patch then goes
+	      ;; at the head of the current list of patches.
+	      (setf tag-patches
+		    (read-repo-patch-list
+		     inrepodir (upath-subdir inrepodir '("_darcs" "inventories") new-filename)))
+	      (setf patches (list tag-patch)))
+	    ;; If it's not, pretend we never read that line.
+	    (unread-line in first-line)))
+      ;; Then, just read all patches in the file.
+      (format t "~&Reading patchinfo from ~A" inventory-file)
+      (setf patches
+	    (nconc patches
+		   (loop for patch = (read-patchinfo in)
+		      while patch collect patch
+		      do (princ #\.)))))
+    (cons patches tag-patches)))
+
+(defun read-patch-from-repo (repodir patchinfo)
+  "Read patch named by PATCHINFO from REPODIR."
+  (read-patch-from-file
+   (upath-subdir repodir '("_darcs" "patches") (patchinfo-make-filename patchinfo))))
+
+(defun read-checkpoint-from-repo (repodir patchinfo)
+  "Read checkpoint named by PATCHINFO from REPODIR."
+  (read-patch-from-file
+   (upath-subdir repodir '("_darcs" "checkpoints") (patchinfo-make-filename patchinfo))))
+
+(defun read-checkpoint-list (repodir)
+  "Read a list of checkpoints from REPODIR.
+Return as a patchinfo list."
+  ;; If there are no checkpoints, it doesn't matter.
+  (ignore-errors
+    (with-open-stream (in (open-upath (upath-subdir repodir '("_darcs" "checkpoints") "inventory")))
+      (format t "~&Reading checkpoints")
+      (loop for patch = (read-patchinfo in)
+	 while patch collect patch
+	 do (princ #\.)))))
+
+(defun write-inventory (out patchinfo-list &optional file)
+  "Write PATCHINFO-LIST as inventory in OUT.
+FILE is either nil, meaning the main \"inventory\" file, or a
+string naming a file in the \"inventories\" directory."
+  ;; XXX: slightly_optimize_patchset?
+  (let ((inventory-file (cond
+			  ((null file)
+			   (merge-pathnames
+			    (make-pathname :directory '(:relative "_darcs")
+					   :name "inventory")
+			    out))
+			  (t
+			   (merge-pathnames
+			    (make-pathname :directory '(:relative "_darcs" "inventories")
+					   :name file)
+			    out)))))
+    (with-open-file (f inventory-file :direction :output :if-exists :supersede
+		       :element-type '(unsigned-byte 8))
+      (flet ((print-patchinfos (patchinfos)
+	       ;; Convert output to binary, using the most direct possible
+	       ;; method...
+	       (dolist (patchinfo patchinfos)
+		 (map nil (lambda (char)
+			    (write-byte (char-code char) f))
+		      (with-output-to-string (strout)
+			(write-patchinfo patchinfo strout)))
+		 (write-byte 10 f))))
+	(cond
+	  ((null patchinfo-list)
+	   ;; No patches - empty inventory file.  Nothing to do.
+	   )
+	  ((null (cdr patchinfo-list))
+	   ;; One patch list - no remaining tags.
+
+	   (print-patchinfos (car patchinfo-list)))
+	  (t
+	   ;; Several patch lists, one for each tag
+	   (let* ((this-tag (car patchinfo-list))
+		  (other-tags (cdr patchinfo-list))
+		  (tag-name (patchinfo-make-filename (car this-tag))))
+	     (write-inventory out other-tags tag-name)
+	     (write-sequence (map 'vector #'char-code "Starting with tag:") f)
+	     (write-byte 10 f)
+	     (print-patchinfos (car patchinfo-list)))))))))
+


From mhenoch at common-lisp.net  Wed Jul 12 14:42:38 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Wed, 12 Jul 2006 10:42:38 -0400 (EDT)
Subject: [Cl-darcs-cvs] r24 - cl-darcs/trunk
Message-ID: <20060712144238.DF6531400C@common-lisp.net>

Author: mhenoch
Date: Wed Jul 12 10:42:38 2006
New Revision: 24

Modified:
   cl-darcs/trunk/repo.lisp
Log:
Add get-common-and-uncommon


Modified: cl-darcs/trunk/repo.lisp
==============================================================================
--- cl-darcs/trunk/repo.lisp	(original)
+++ cl-darcs/trunk/repo.lisp	Wed Jul 12 10:42:38 2006
@@ -132,3 +132,17 @@
 	     (write-byte 10 f)
 	     (print-patchinfos (car patchinfo-list)))))))))
 
+(defun get-common-and-uncommon (ours theirs)
+  "Given patchsets OURS and THEIRS, find common and uncommon patches.
+OURS and THEIRS are lists of lists of patchinfos, as returned by
+`read-repo-patch-list'.  Three values are returned: a list of
+patchinfos that appear in both sets, a list of patchinfos that
+appear only in OURS, and a list of patchinfos that appear only in
+THEIRS."
+  ;; Of course, there are possible optimizations here, in particular
+  ;; regarding tags, but this will do for now.
+  (let ((ours-list (apply #'append (reverse ours)))
+	(theirs-list (apply #'append (reverse theirs))))
+    (values (union ours-list theirs-list :test #'equalp)
+	    (set-difference ours-list theirs-list :test #'equalp)
+	    (set-difference theirs-list ours-list :test #'equalp))))


From mhenoch at common-lisp.net  Wed Jul 12 14:59:30 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Wed, 12 Jul 2006 10:59:30 -0400 (EDT)
Subject: [Cl-darcs-cvs] r25 - cl-darcs/trunk
Message-ID: <20060712145930.9AB8C1A005@common-lisp.net>

Author: mhenoch
Date: Wed Jul 12 10:59:30 2006
New Revision: 25

Modified:
   cl-darcs/trunk/commute.lisp
   cl-darcs/trunk/equal.lisp
   cl-darcs/trunk/unwind.lisp
Log:
Add license notices


Modified: cl-darcs/trunk/commute.lisp
==============================================================================
--- cl-darcs/trunk/commute.lisp	(original)
+++ cl-darcs/trunk/commute.lisp	Wed Jul 12 10:59:30 2006
@@ -1,3 +1,19 @@
+;;; 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)
 
 (defgeneric commute (p2 p1)

Modified: cl-darcs/trunk/equal.lisp
==============================================================================
--- cl-darcs/trunk/equal.lisp	(original)
+++ cl-darcs/trunk/equal.lisp	Wed Jul 12 10:59:30 2006
@@ -1,3 +1,19 @@
+;;; 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 equal-list (predicate a b)

Modified: cl-darcs/trunk/unwind.lisp
==============================================================================
--- cl-darcs/trunk/unwind.lisp	(original)
+++ cl-darcs/trunk/unwind.lisp	Wed Jul 12 10:59:30 2006
@@ -1,3 +1,19 @@
+;;; 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)
 
 ;; From PatchCommute.lhs


From mhenoch at common-lisp.net  Wed Jul 12 15:30:02 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Wed, 12 Jul 2006 11:30:02 -0400 (EDT)
Subject: [Cl-darcs-cvs] r26 - cl-darcs/trunk
Message-ID: <20060712153002.9E2CE2E1AB@common-lisp.net>

Author: mhenoch
Date: Wed Jul 12 11:30:01 2006
New Revision: 26

Added:
   cl-darcs/trunk/merge.lisp
Modified:
   cl-darcs/trunk/cl-darcs.asd
Log:
Add merge.lisp


Modified: cl-darcs/trunk/cl-darcs.asd
==============================================================================
--- cl-darcs/trunk/cl-darcs.asd	(original)
+++ cl-darcs/trunk/cl-darcs.asd	Wed Jul 12 11:30:01 2006
@@ -39,6 +39,7 @@
    (:file "invert-patch" :depends-on ("patch-core"))
    (:file "touching" :depends-on ("patch-core"))
    (:file "commute" :depends-on ("patch-core"))
+   (:file "merge" :depends-on ("patch-core"))
    (:file "unwind" :depends-on ("patch-core"))
    (:file "equal" :depends-on ("patch-core"))
 

Added: cl-darcs/trunk/merge.lisp
==============================================================================
--- (empty file)
+++ cl-darcs/trunk/merge.lisp	Wed Jul 12 11:30:01 2006
@@ -0,0 +1,38 @@
+;;; 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 merge-patches (p1 p2)
+  "Create variant of P1 that can be applied after P2.
+P1 and P2 are parallel patches, i.e. they apply to the same tree.
+We now want to apply P2 and then P1 to that tree.  This function
+returns a version of P1 that satisfies that constraint."
+  (or (elegant-merge p1 p2)
+      (error "Couldn't merge ~A and ~A." p1 p2)))
+
+(defun elegant-merge (p1 p2)
+  ;; A piece of patch algebra.  See PatchCommute.lhs for the
+  ;; explanation.
+  (destructuring-bind (&optional p2-new p1-new)
+      (commute p1 (invert-patch p2))
+    (declare (ignore p2-new))
+    (when p1-new
+      (destructuring-bind (&optional p2-old p1-old)
+	  (commute p1-new p2)
+	(declare (ignore p2-old))
+	(when (equal-patch p1 p1-old t)
+	  p1-new)))))


From mhenoch at common-lisp.net  Wed Jul 12 18:17:38 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Wed, 12 Jul 2006 14:17:38 -0400 (EDT)
Subject: [Cl-darcs-cvs] r27 - cl-darcs/trunk
Message-ID: <20060712181738.94AE01600A@common-lisp.net>

Author: mhenoch
Date: Wed Jul 12 14:17:37 2006
New Revision: 27

Modified:
   cl-darcs/trunk/merge.lisp
Log:
Further hack merge.lisp


Modified: cl-darcs/trunk/merge.lisp
==============================================================================
--- cl-darcs/trunk/merge.lisp	(original)
+++ cl-darcs/trunk/merge.lisp	Wed Jul 12 14:17:37 2006
@@ -16,11 +16,44 @@
 
 (in-package :darcs)
 
-(defun merge-patches (p1 p2)
-  "Create variant of P1 that can be applied after P2.
+(defgeneric merge-patches (p1 p2)
+  (:documentation "Create variant of P1 that can be applied after P2.
 P1 and P2 are parallel patches, i.e. they apply to the same tree.
 We now want to apply P2 and then P1 to that tree.  This function
-returns a version of P1 that satisfies that constraint."
+returns a version of P1 that satisfies that constraint."))
+
+;; named patches
+(defmethod merge-patches ((p1 named-patch) (p2 patch))
+  (make-instance 'named-patch
+		 :patchinfo (named-patch-patchinfo p1)
+		 :dependencies (named-patch-dependencies p1)
+		 :patch
+		 (merge-patches (named-patch-patch p1) p2)))
+(defmethod merge-patches ((p1 patch) (p2 named-patch))
+  (merge-patches p1 (named-patch-patch p2)))
+
+;; composite patches
+(defmethod merge-patches ((p1 composite-patch) (p2 composite-patch))
+  (make-instance 
+   'composite-patch
+   :patches
+   (let ((patches1 (patches p1))
+	 (patches2 (patches p2)))
+     (cond
+       ((null patches1)
+	nil)
+       (t
+	(labels ((mc (p1s p2s)
+		   (if (null p2s)
+		       p1s
+		       (mc (merge-patches-after-patch p1s (car p2s)) (cdr p2s)))))
+	  (mc patches1 patches2)))))))
+(defmethod merge-patches ((p1 composite-patch) (p2 patch))
+  (make-instance 'composite-patch :patches (merge-patches-after-patch (patches p1) p2)))
+(defmethod merge-patches ((p1 patch) (p2 composite-patch))
+  (merge-patch-after-patches p1 (patches p2)))
+
+(defmethod merge-patches ((p1 patch) (p2 patch))
   (or (elegant-merge p1 p2)
       (error "Couldn't merge ~A and ~A." p1 p2)))
 
@@ -36,3 +69,15 @@
 	(declare (ignore p2-old))
 	(when (equal-patch p1 p1-old t)
 	  p1-new)))))
+
+(defun merge-patch-after-patches (p1 p2s)
+  "Create a variant of P1 that can be applied after all of P2S.
+P1 is a patch; P2S is a list of patches."
+  (loop for p2s-left on p2s
+     do (setf p1 (merge-patches p1 (car p2s-left))))
+  p1)
+
+(defun merge-patches-after-patch (p1s p2)
+  "Create a variant of P1S that can be applied after P2.
+P1S is a list of patches; P2 is a patch."
+  (error "merge-patches-after-patch not yet implemented."))


From mhenoch at common-lisp.net  Wed Jul 12 19:06:02 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Wed, 12 Jul 2006 15:06:02 -0400 (EDT)
Subject: [Cl-darcs-cvs] r28 - cl-darcs/trunk
Message-ID: <20060712190602.D3FE74610C@common-lisp.net>

Author: mhenoch
Date: Wed Jul 12 15:06:02 2006
New Revision: 28

Modified:
   cl-darcs/trunk/commute.lisp
Log:
Add commute methods for composite patches


Modified: cl-darcs/trunk/commute.lisp
==============================================================================
--- cl-darcs/trunk/commute.lisp	(original)
+++ cl-darcs/trunk/commute.lisp	Wed Jul 12 15:06:02 2006
@@ -77,3 +77,44 @@
 	 ;; In other cases, there is no failsafe way to commute the
 	 ;; patches, so we give up.
 	 nil)))))
+
+(defmethod commute ((p2 composite-patch) (p1 patch))
+  (cond
+    ;; Simple case first...
+    ((null (patches p2))
+     (list p1 p2))
+    (t
+     ;; Now, p1 was committed before all the patches in p2, and we
+     ;; want it to come after.
+     (let ((p2s (patches p2))
+	   p2s-new)
+       (loop for p in p2s
+	  do (destructuring-bind (&optional p1-new p-new)
+		 (commute p p1)
+	       (cond
+		 ((null p1-new)
+		  (return-from commute (call-next-method)))
+		 (t
+		  (setf p1 p1-new)
+		  (push p-new p2s-new)))))
+       (list p1 (make-instance 'composite-patch :patches (nreverse p2s-new)))))))
+(defmethod commute ((p2 patch) (p1 composite-patch))
+  (cond
+    ((null (patches p1))
+     (list p1 p2))
+    (t
+     ;; p2 was committed after all the patches in p1.  Thus we start
+     ;; backwards in p1, commuting p2 with each of the patches.
+     (let ((p1s (reverse (patches p1)))
+	   p1s-new)
+       (loop for p in p1s
+	  do (destructuring-bind (&optional p-new p2-new)
+		 (commute p2 p)
+	       (cond
+		 ((null p-new)
+		  (return-from commute (call-next-method)))
+		 (t
+		  (setf p2 p2-new)
+		  (push p-new p1s-new)))))
+       (list (make-instance 'composite-patch :patches p1s-new)
+	     p2)))))


From mhenoch at common-lisp.net  Wed Jul 12 19:09:17 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Wed, 12 Jul 2006 15:09:17 -0400 (EDT)
Subject: [Cl-darcs-cvs] r29 - cl-darcs/trunk
Message-ID: <20060712190917.3C3F74E003@common-lisp.net>

Author: mhenoch
Date: Wed Jul 12 15:09:17 2006
New Revision: 29

Modified:
   cl-darcs/trunk/merge.lisp
Log:
Implement merge-patches-after-patch


Modified: cl-darcs/trunk/merge.lisp
==============================================================================
--- cl-darcs/trunk/merge.lisp	(original)
+++ cl-darcs/trunk/merge.lisp	Wed Jul 12 15:09:17 2006
@@ -80,4 +80,9 @@
 (defun merge-patches-after-patch (p1s p2)
   "Create a variant of P1S that can be applied after P2.
 P1S is a list of patches; P2 is a patch."
-  (error "merge-patches-after-patch not yet implemented."))
+  (destructuring-bind (p1-new p2-new)
+      (commute (merge-patch-after-patches p2 p1s) 
+	       (make-instance 'composite-patch :patches p1s))
+    (declare (ignore p2-new))
+    (patches p1-new)))
+


From mhenoch at common-lisp.net  Fri Jul 14 23:46:56 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Fri, 14 Jul 2006 19:46:56 -0400 (EDT)
Subject: [Cl-darcs-cvs] r30 - cl-darcs/trunk
Message-ID: <20060714234656.B166F2B02A@common-lisp.net>

Author: mhenoch
Date: Fri Jul 14 19:46:56 2006
New Revision: 30

Modified:
   cl-darcs/trunk/patchinfo.lisp
Log:
Add print-object method for patchinfo structures


Modified: cl-darcs/trunk/patchinfo.lisp
==============================================================================
--- cl-darcs/trunk/patchinfo.lisp	(original)
+++ cl-darcs/trunk/patchinfo.lisp	Fri Jul 14 19:46:56 2006
@@ -116,3 +116,10 @@
     (setf (patchinfo-inverted copy)
 	  (not (patchinfo-inverted copy)))
     copy))
+
+(defmethod print-object ((patchinfo patchinfo) stream)
+  (if *print-readably*
+      (call-next-method)
+      (format stream "~A ~A (~A)" (patchinfo-date patchinfo)
+	      (patchinfo-name patchinfo)
+	      (patchinfo-author patchinfo))))


From mhenoch at common-lisp.net  Fri Jul 14 23:47:12 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Fri, 14 Jul 2006 19:47:12 -0400 (EDT)
Subject: [Cl-darcs-cvs] r31 - cl-darcs/trunk
Message-ID: <20060714234712.89C492D01D@common-lisp.net>

Author: mhenoch
Date: Fri Jul 14 19:47:12 2006
New Revision: 31

Modified:
   cl-darcs/trunk/repo.lisp
Log:
Add append-inventory function


Modified: cl-darcs/trunk/repo.lisp
==============================================================================
--- cl-darcs/trunk/repo.lisp	(original)
+++ cl-darcs/trunk/repo.lisp	Fri Jul 14 19:47:12 2006
@@ -132,6 +132,20 @@
 	     (write-byte 10 f)
 	     (print-patchinfos (car patchinfo-list)))))))))
 
+(defun append-inventory (outrepo patchinfo)
+  "Append PATCHINFO to inventory in OUTREPO."
+  (with-open-file (f (merge-pathnames 
+		      (make-pathname :directory '(:relative "_darcs")
+				     :name "inventory")
+		      outrepo)
+		     :direction :output :if-exists :append
+		     :element-type '(unsigned-byte 8))
+    (map nil (lambda (char)
+	       (write-byte (char-code char) f))
+	 (with-output-to-string (strout)
+	   (write-patchinfo patchinfo strout)))
+    (write-byte 10 f)))
+
 (defun get-common-and-uncommon (ours theirs)
   "Given patchsets OURS and THEIRS, find common and uncommon patches.
 OURS and THEIRS are lists of lists of patchinfos, as returned by


From mhenoch at common-lisp.net  Fri Jul 14 23:47:25 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Fri, 14 Jul 2006 19:47:25 -0400 (EDT)
Subject: [Cl-darcs-cvs] r32 - cl-darcs/trunk
Message-ID: <20060714234725.DEEFB2E182@common-lisp.net>

Author: mhenoch
Date: Fri Jul 14 19:47:25 2006
New Revision: 32

Added:
   cl-darcs/trunk/pull.lisp
Log:
Add pull.lisp


Added: cl-darcs/trunk/pull.lisp
==============================================================================
--- (empty file)
+++ cl-darcs/trunk/pull.lisp	Fri Jul 14 19:47:25 2006
@@ -0,0 +1,52 @@
+;;; 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 pull (ourrepo theirrepo)
+  "Pull new patches from THEIRREPO into OURREPO."
+  (setf ourrepo (fad:pathname-as-directory ourrepo))
+  (let ((our-patchinfo (read-repo-patch-list ourrepo))
+	(their-patchinfo (read-repo-patch-list theirrepo)))
+    (multiple-value-bind (common only-ours only-theirs)
+	(get-common-and-uncommon our-patchinfo their-patchinfo)
+      (declare (ignore common))
+      (format t "~&Found these new patches:")
+      (dolist (p only-theirs)
+	(format t "~& - ~A" p))
+      ;; XXX: This is where we pick which of their patches we want to
+      ;; pull.
+      (let* ((their-patches
+	      (mapcar (lambda (pi)
+			(read-patch-from-repo theirrepo pi))
+		      only-theirs))
+	     (our-patches
+	      (mapcar (lambda (pi)
+			(read-patch-from-repo ourrepo pi))
+		      only-ours))
+	     (merged-patches (patches
+			      (merge-patches (make-instance 'composite-patch
+							    :patches their-patches)
+					     (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))
+	  (format t ".")))))
+  (format t "~&All done"))


From mhenoch at common-lisp.net  Sat Jul 15 11:33:01 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Sat, 15 Jul 2006 07:33:01 -0400 (EDT)
Subject: [Cl-darcs-cvs] r33 - cl-darcs/trunk
Message-ID: <20060715113301.474A9402F@common-lisp.net>

Author: mhenoch
Date: Sat Jul 15 07:33:00 2006
New Revision: 33

Modified:
   cl-darcs/trunk/cl-darcs.asd
Log:
Add pull.lisp to ASDF file


Modified: cl-darcs/trunk/cl-darcs.asd
==============================================================================
--- cl-darcs/trunk/cl-darcs.asd	(original)
+++ cl-darcs/trunk/cl-darcs.asd	Sat Jul 15 07:33:00 2006
@@ -29,6 +29,7 @@
 
    (:file "patchinfo" :depends-on ("util"))
    (:file "get" :depends-on ("util"))
+   (:file "pull" :depends-on ("util"))
    (:file "init" :depends-on ("util"))
    (:file "prefs" :depends-on ("util"))
    (:file "repo" :depends-on ("util"))


From mhenoch at common-lisp.net  Sat Jul 15 11:40:13 2006
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Sat, 15 Jul 2006 07:40:13 -0400 (EDT)
Subject: [Cl-darcs-cvs] r34 - cl-darcs/trunk
Message-ID: <20060715114013.0A1D8402F@common-lisp.net>

Author: mhenoch
Date: Sat Jul 15 07:40:12 2006
New Revision: 34

Modified:
   cl-darcs/trunk/pull.lisp
Log:
Use "defaultrepo" preference if no repo specified to pull from


Modified: cl-darcs/trunk/pull.lisp
==============================================================================
--- cl-darcs/trunk/pull.lisp	(original)
+++ cl-darcs/trunk/pull.lisp	Sat Jul 15 07:40:12 2006
@@ -16,9 +16,15 @@
 
 (in-package :darcs)
 
-(defun pull (ourrepo theirrepo)
-  "Pull new patches from THEIRREPO into OURREPO."
+(defun pull (ourrepo &optional theirrepo)
+  "Pull new patches from THEIRREPO into OURREPO.
+If THEIRREPO is not specified, use default repositiory specified
+in preferences."
   (setf ourrepo (fad:pathname-as-directory ourrepo))
+  (unless theirrepo
+    (setf theirrepo (car (get-preflist ourrepo "defaultrepo")))
+    (unless theirrepo
+      (error "No remote repositiory specified, and no default available.")))
   (let ((our-patchinfo (read-repo-patch-list ourrepo))
 	(their-patchinfo (read-repo-patch-list theirrepo)))
     (multiple-value-bind (common only-ours only-theirs)