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

[mhenoch at 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"))