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

[mhenoch at common-lisp.net]

Author: mhenoch
Date: Thu Mar 15 17:27:17 2007
New Revision: 111

Added:
   cl-darcs/trunk/send.lisp
Modified:
   cl-darcs/trunk/cl-darcs.asd
Log:
Add send-to-file


Modified: cl-darcs/trunk/cl-darcs.asd
==============================================================================
--- cl-darcs/trunk/cl-darcs.asd	(original)
+++ cl-darcs/trunk/cl-darcs.asd	Thu Mar 15 17:27:17 2007
@@ -16,6 +16,7 @@
 	       :trivial-gray-streams
 	       ;; SHA1, hex etc
 	       :ironclad
+	       :flexi-streams
 	       ;; Ironclad's SHA1 doesn't work with CLISP yet
 	       #+clisp :sb-sha1
 	       ;; Files and directories
@@ -52,6 +53,7 @@
    (:file "merge" :depends-on ("patch-core"))
    (:file "unwind" :depends-on ("patch-core"))
    (:file "equal" :depends-on ("patch-core"))
+   (:file "send" :depends-on ("patch-core"))
 
    ;; Franz' inflate implementation
    #-allegro (:file "ifstar")

Added: cl-darcs/trunk/send.lisp
==============================================================================
--- (empty file)
+++ cl-darcs/trunk/send.lisp	Thu Mar 15 17:27:17 2007
@@ -0,0 +1,108 @@
+;;; Copyright (C) 2007 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 send-to-file (our-repo file &key their-repo (select-patches :ask))
+  "Write new patches in OUR-REPO to FILE, suitable for sending by e-mail.
+\"New\" patches are those present in OUR-REPO but not in
+THEIR-REPO.  If THEIR-REPO is NIL, use default repository
+specified in preferences.
+SELECT-PATCHES specifies how to select which patches to include.
+It can be one of:
+:ALL - include all patches
+:ASK - ask for each patch through Y-OR-N-P
+a function - call this function with a NAMED-PATCH object, and
+             include if it returns true"
+  (setf our-repo (fad:pathname-as-directory our-repo))
+  (unless their-repo
+    (unless (setf their-repo (car (get-preflist our-repo "defaultrepo")))
+      (error "No remote repositiory specified, and no default available.")))
+
+  (with-open-file (f file
+		     :direction :output
+		     :element-type '(unsigned-byte 8))
+    
+    (let ((our-patchinfo (read-repo-patch-list our-repo))
+	  (their-patchinfo (read-repo-patch-list their-repo)))
+      (multiple-value-bind (common only-ours only-theirs)
+	  (get-common-and-uncommon our-patchinfo their-patchinfo)
+	(declare (ignore only-theirs))
+	(format t "~&Found these new patches:")
+	(dolist (p only-ours)
+	  (format t "~& - ~A" p))
+
+	(let* ((all-our-patches
+		(mapcar (lambda (patchinfo)
+			  (read-patch-from-repo our-repo patchinfo))
+			only-ours))
+	       (patches-to-send
+		(if (or (eq select-patches :all)
+			(and (eq select-patches :ask)
+			     (y-or-n-p "Send all patches?")))
+		    all-our-patches
+		    (select-patches all-our-patches 
+				    (if (functionp select-patches)
+					select-patches
+					(lambda (patch) 
+					  (display-patch patch *query-io*)
+					  (y-or-n-p "Include patch ~A? " patch)))))))
+
+	  (write-byte 10 f)
+	  (write-sequence (string-to-bytes "New patches:") f)
+	  (write-byte 10 f)
+	  (write-byte 10 f)
+	  (dolist (patch patches-to-send)
+	    (write-patch patch f))
+	  (write-byte 10 f)
+
+	  (write-sequence (string-to-bytes "Context:") f)
+	  (write-byte 10 f)
+	  (write-byte 10 f)
+	  ;; Context is in reverse order: latest applied first.
+	  (setf common (nreverse common))
+
+	  ;; XXX: handle tags properly.
+	  (let ((latest-tag (member-if
+			     (lambda (pi)
+			       (string= (patchinfo-name pi) "TAG "
+					:end1 4))
+			     common)))
+	    ;; Here we just cut history after the latest tag.  This
+	    ;; should work in most cases.
+	    (setf (cdr latest-tag) nil))
+
+	  (dolist (patchinfo common)
+	    (write-sequence (string-to-bytes
+			     (with-output-to-string (strout)
+			       (write-patchinfo patchinfo strout)))
+			    f)
+	    (write-byte 10 f))
+	  (write-sequence (string-to-bytes "Patch bundle hash:") f)
+	  (write-byte 10 f)
+	  (write-sequence (string-to-bytes (hash-bundle patches-to-send)) f)
+	  (write-byte 10 f))))))
+
+(defun hash-bundle (patches)
+  (let ((patches-as-vector
+	 (flexi-streams:with-output-to-sequence (out)
+	   (dolist (patch patches)
+	     (write-patch patch out)))))
+    (setf patches-as-vector
+	  (coerce patches-as-vector '(simple-array (unsigned-byte 8))))
+    (ironclad:byte-array-to-hex-string
+     #+clisp (sb-sha1:sha1sum-sequence patches-as-vector)
+     #-clisp (ironclad:digest-sequence :sha1 patches-as-vector))))