From mhenoch at common-lisp.net  Sat Mar 10 20:39:19 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Sat, 10 Mar 2007 15:39:19 -0500 (EST)
Subject: [Cl-darcs-cvs] r102 - cl-darcs/trunk
Message-ID: <20070310203919.A1C8B6A032@common-lisp.net>

Author: mhenoch
Date: Sat Mar 10 15:39:19 2007
New Revision: 102

Modified:
   cl-darcs/trunk/util.lisp
Log:
Fix off-by-ten error in HEX-TO-NUMBER


Modified: cl-darcs/trunk/util.lisp
==============================================================================
--- cl-darcs/trunk/util.lisp	(original)
+++ cl-darcs/trunk/util.lisp	Sat Mar 10 15:39:19 2007
@@ -47,9 +47,9 @@
     ((<= (char-code #\0) c (char-code #\9))
      (- c (char-code #\0)))
     ((<= (char-code #\A) c (char-code #\F))
-     (- c (char-code #\A)))
+     (+ 10 (- c (char-code #\A))))
     ((<= (char-code #\a) c (char-code #\f))
-     (- c (char-code #\a)))
+     (+ 10 (- c (char-code #\a))))
     (t
      (error "Invalid hex digit ~A." c))))
 


From mhenoch at common-lisp.net  Sat Mar 10 21:13:10 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Sat, 10 Mar 2007 16:13:10 -0500 (EST)
Subject: [Cl-darcs-cvs] r103 - cl-darcs/trunk
Message-ID: <20070310211310.422FC74181@common-lisp.net>

Author: mhenoch
Date: Sat Mar 10 16:13:10 2007
New Revision: 103

Modified:
   cl-darcs/trunk/cl-darcs.asd
   cl-darcs/trunk/upath.lisp
Log:
Use Drakma instead of Aserve


Modified: cl-darcs/trunk/cl-darcs.asd
==============================================================================
--- cl-darcs/trunk/cl-darcs.asd	(original)
+++ cl-darcs/trunk/cl-darcs.asd	Sat Mar 10 16:13:10 2007
@@ -12,7 +12,7 @@
   :author "Magnus Henoch <henoch at dtek.chalmers.se>"
   :depends-on (:split-sequence
 	       ;; HTTP client
-	       :aserve
+	       :drakma :puri
 	       :trivial-gray-streams
 	       ;; SHA1, hex etc
 	       :ironclad

Modified: cl-darcs/trunk/upath.lisp
==============================================================================
--- cl-darcs/trunk/upath.lisp	(original)
+++ cl-darcs/trunk/upath.lisp	Sat Mar 10 16:13:10 2007
@@ -72,77 +72,9 @@
   (ctypecase upath
     (net.uri:uri 
      (dformat "~&Opening ~A..." upath)
-     (let ((client-request (net.aserve.client:make-http-client-request upath :proxy *http-proxy*)))
-       (net.aserve.client:read-client-response-headers client-request)
-       (let ((code (net.aserve.client:client-request-response-code client-request)))
-	 (cond
-	   ((= code 200)
-	    (make-instance (if binary 'http-byte-input-stream 'http-char-input-stream)
-			   :client-request client-request))
-	   ((and (> redirect-max-depth 0) (member code '(301 302 303 307)))
-	    (let ((new-location (cdr (assoc :location (net.aserve.client:client-request-headers client-request)))))
-	      (dformat "~&Redirected to ~A." new-location)
-	      (net.aserve.client:client-request-close client-request)
-	      (open-upath
-	       (net.uri:uri new-location)
-	       :redirect-max-depth (1- redirect-max-depth) :binary binary)))
-	   (t
-	    (error "Couldn't read ~A: ~A ~A."
-		   upath
-		   (net.aserve.client:client-request-response-code client-request)
-		   (net.aserve.client:client-request-response-comment client-request)))))))
+     (apply #'drakma:http-request upath :redirect redirect-max-depth
+	    :want-stream t (when *http-proxy* `(:proxy ,*http-proxy*))))
 
     (pathname
      (open upath :direction :input :if-does-not-exist :error
 	   :element-type (if binary '(unsigned-byte 8) 'character)))))
-
-
-(defclass http-input-stream (trivial-gray-streams:trivial-gray-stream-mixin
-			     trivial-gray-streams:fundamental-input-stream)
-  ((client-request :initarg :client-request)
-   (binary)
-   (unread :initform nil))
-  (:documentation "A Gray stream wrapping an Allegroserve HTTP request."))
-
-(defclass http-char-input-stream (http-input-stream
-				  trivial-gray-streams:fundamental-character-input-stream)
-  ((binary :initform nil))
-  (:documentation "An HTTP input stream for characters."))
-
-(defclass http-byte-input-stream (http-input-stream
-				  trivial-gray-streams:fundamental-binary-input-stream)
-  ((binary :initform t))
-  (:documentation "An HTTP input stream for bytes."))
-
-(defmethod trivial-gray-streams:stream-read-sequence 
-    ((stream http-input-stream) sequence start end &key &allow-other-keys)
-  (if (slot-value stream 'binary)
-      (net.aserve.client:client-request-read-sequence 
-       sequence (slot-value stream 'client-request))
-      (let* ((buffer (make-array (- end start) :element-type '(unsigned-byte 8)))
-	     (len (net.aserve.client:client-request-read-sequence 
-		   buffer (slot-value stream 'client-request))))
-	(loop for i from 0 below len
-	   do (setf (elt sequence (+ i start)) (aref buffer i)))
-	len)))
-
-(defmethod trivial-gray-streams:stream-read-byte ((stream http-input-stream))
-  (let ((buffer (make-array 1 :element-type '(unsigned-byte 8))))
-    (if (= 1 (trivial-gray-streams:stream-read-sequence stream buffer 0 1))
-	(aref buffer 0)
-	:eof)))
-
-(defmethod trivial-gray-streams:stream-read-char ((stream http-input-stream))
-  (or (pop (slot-value stream 'unread))
-      (let ((byte (trivial-gray-streams:stream-read-byte stream)))
-	(if (eql byte :eof) byte (code-char byte)))))
-
-(defmethod trivial-gray-streams:stream-unread-char ((stream http-input-stream) char)
-  (push char (slot-value stream 'unread)))
-
-(defmethod stream-element-type ((stream http-input-stream))
-  (if (slot-value stream 'binary) '(unsigned-byte 8) 'character))
-
-(defmethod close ((stream http-input-stream) &key &allow-other-keys)
-  (net.aserve.client:client-request-close (slot-value stream 'client-request))
-  (call-next-method))


From mhenoch at common-lisp.net  Sat Mar 10 21:18:07 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Sat, 10 Mar 2007 16:18:07 -0500 (EST)
Subject: [Cl-darcs-cvs] r104 - cl-darcs/trunk
Message-ID: <20070310211807.B366974181@common-lisp.net>

Author: mhenoch
Date: Sat Mar 10 16:18:07 2007
New Revision: 104

Modified:
   cl-darcs/trunk/util.lisp
Log:
Use ENSURE-DIRECTORIES-EXIST in MAKE-DIR


Modified: cl-darcs/trunk/util.lisp
==============================================================================
--- cl-darcs/trunk/util.lisp	(original)
+++ cl-darcs/trunk/util.lisp	Sat Mar 10 16:18:07 2007
@@ -238,10 +238,10 @@
 (defun make-dir (pathname)
   "Create directory PATHNAME."
   (with-simple-restart (ignore-error "Ignore ~A directory creation error." pathname)
-    #+clisp (ext:make-dir pathname)
-    #+sbcl  (sb-posix:mkdir pathname #o777)
-    #-(or clisp sbcl)
-    (error "MAKE-DIR not implemented for ~A." (lisp-implementation-type))))
+    (multiple-value-bind (path created) (ensure-directories-exist pathname)
+      (declare (ignore path))
+      (unless created
+	(error "Directory ~A already exists." pathname)))))
 
 (defun delete-dir (pathname)
   "Delete directory PATHNAME."


From mhenoch at common-lisp.net  Sat Mar 10 21:18:44 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Sat, 10 Mar 2007 16:18:44 -0500 (EST)
Subject: [Cl-darcs-cvs] r105 - cl-darcs/trunk
Message-ID: <20070310211844.D9B4D74181@common-lisp.net>

Author: mhenoch
Date: Sat Mar 10 16:18:44 2007
New Revision: 105

Modified:
   cl-darcs/trunk/util.lisp
Log:
Implement DELETE-DIR for Lispworks


Modified: cl-darcs/trunk/util.lisp
==============================================================================
--- cl-darcs/trunk/util.lisp	(original)
+++ cl-darcs/trunk/util.lisp	Sat Mar 10 16:18:44 2007
@@ -247,7 +247,8 @@
   "Delete directory PATHNAME."
   #+clisp (ext:delete-dir pathname)
   #+sbcl  (sb-posix:rmdir pathname)
-  #-(or clisp sbcl)
+  #+lispworks (lw:delete-directory pathname)
+  #-(or clisp sbcl lispworks)
   (error "DELETE-DIR not implemented for ~A." (lisp-implementation-type)))
 
 (defun copy-directory (source target &key excluding)


From mhenoch at common-lisp.net  Sat Mar 10 23:04:14 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Sat, 10 Mar 2007 18:04:14 -0500 (EST)
Subject: [Cl-darcs-cvs] r106 - cl-darcs/trunk
Message-ID: <20070310230414.1E05A1010@common-lisp.net>

Author: mhenoch
Date: Sat Mar 10 18:04:14 2007
New Revision: 106

Modified:
   cl-darcs/trunk/pull.lisp
   cl-darcs/trunk/record.lisp
Log:
Make PULL conditionally interactive.
SELECT-PATCHES now takes a predicate as second argument.


Modified: cl-darcs/trunk/pull.lisp
==============================================================================
--- cl-darcs/trunk/pull.lisp	(original)
+++ cl-darcs/trunk/pull.lisp	Sat Mar 10 18:04:14 2007
@@ -16,10 +16,16 @@
 
 (in-package :darcs)
 
-(defun pull (ourrepo &optional theirrepo)
+(defun pull (ourrepo &optional theirrepo &key (select-patches :ask))
   "Pull new patches from THEIRREPO into OURREPO.
 If THEIRREPO is not specified, use default repositiory specified
-in preferences."
+in preferences.
+SELECT-PATCHES specifies how to select which remote patches to pull.
+It can be one of:
+:ALL - pull all patches
+:ASK - ask for each patch through Y-OR-N-P
+a function - call this function with a NAMED-PATCH object, and
+             pull if it returns true"
   (setf ourrepo (fad:pathname-as-directory ourrepo))
   (unless theirrepo
     (setf theirrepo (car (get-preflist ourrepo "defaultrepo")))
@@ -42,9 +48,16 @@
 			(read-patch-from-repo theirrepo patchinfo))
 		      only-theirs))
 	     (their-patches
-	      (if (y-or-n-p "Pull all patches?")
+	      (if (or (eq select-patches :all)
+		      (and (eq select-patches :ask)
+			   (y-or-n-p "Pull all patches?")))
 		  all-their-patches
-		  (select-patches all-their-patches)))
+		  (select-patches all-their-patches 
+				  (if (functionp select-patches)
+				      select-patches
+				      (lambda (patch) 
+					(display-patch patch *query-io*)
+					(y-or-n-p "Pull patch ~A? " patch))))))
 	     (our-patches
 	      (mapcar (lambda (patchinfo)
 			(read-patch-from-repo ourrepo patchinfo))

Modified: cl-darcs/trunk/record.lisp
==============================================================================
--- cl-darcs/trunk/record.lisp	(original)
+++ cl-darcs/trunk/record.lisp	Sat Mar 10 18:04:14 2007
@@ -49,20 +49,22 @@
   "Record changes in REPO.
 Arguments as to `record-patches'."
   (let ((patches (diff-repo repo)))
-    (unless patches
-      (error "Nothing to record."))
+    (flet ((ask (patch)
+	     (display-patch patch *query-io*)
+	     (y-or-n-p "Record patch ~A? " patch)))
+      (unless patches
+	(error "Nothing to record."))
 
-    (record-patches repo name author date log (select-patches patches))))
+      (record-patches repo name author date log (select-patches patches #'ask)))))
 
-(defun select-patches (patches)
-  "Ask the user to select some of PATCHES.
+(defun select-patches (patches predicate)
+  "Select some of PATCHES using PREDICATE.
 Do the necessary commutation and dependency elimination."
   (let (patches-to-record)
     (loop while (setf patches (remove nil patches))
        do
        ;; Should we include this patch? 
-       (display-patch (car patches) *query-io*)
-       (if (y-or-n-p "Record patch ~A?" (car patches))
+       (if (funcall predicate (car patches))
 	   (progn
 	     ;; Yes, just add it to the list and go on.
 	     (push (car patches) patches-to-record)


From mhenoch at common-lisp.net  Sun Mar 11 03:10:57 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Sat, 10 Mar 2007 22:10:57 -0500 (EST)
Subject: [Cl-darcs-cvs] r107 - cl-darcs/trunk
Message-ID: <20070311031057.494171010@common-lisp.net>

Author: mhenoch
Date: Sat Mar 10 22:10:57 2007
New Revision: 107

Modified:
   cl-darcs/trunk/util.lisp
Log:
Fix EOF handling of READ-BINARY-LINE


Modified: cl-darcs/trunk/util.lisp
==============================================================================
--- cl-darcs/trunk/util.lisp	(original)
+++ cl-darcs/trunk/util.lisp	Sat Mar 10 22:10:57 2007
@@ -96,10 +96,15 @@
 Return a vector of binary values.  Return EOF-VALUE if EOF-ERROR-P
 is nil and end-of-file occurs before any data is read."
   (multiple-value-bind (line delim)
-      (read-until 10 stream eof-error-p eof-value)
-    (if (or (not (zerop (length line))) (eql delim 10))
-	line
-	delim)))
+      (read-until 10 stream nil :eof)
+    (cond
+      ;; nothing read, and we've reached the end
+      ((and (zerop (length line)) (eq delim :eof))
+       (if eof-error-p
+	   (error 'end-of-file :stream stream)
+	   eof-value))
+      (t
+       line))))
 
 (defun read-token (stream)
   "Read and return a whitespace-separated token from STREAM.


From mhenoch at common-lisp.net  Sun Mar 11 03:14:51 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Sat, 10 Mar 2007 22:14:51 -0500 (EST)
Subject: [Cl-darcs-cvs] r108 - cl-darcs/trunk
Message-ID: <20070311031451.BD1431010@common-lisp.net>

Author: mhenoch
Date: Sat Mar 10 22:14:51 2007
New Revision: 108

Modified:
   cl-darcs/trunk/get.lisp
   cl-darcs/trunk/pull.lisp
Log:
Flush *STANDARD-OUTPUT* when writing progress dots


Modified: cl-darcs/trunk/get.lisp
==============================================================================
--- cl-darcs/trunk/get.lisp	(original)
+++ cl-darcs/trunk/get.lisp	Sat Mar 10 22:14:51 2007
@@ -73,7 +73,8 @@
 	  ;; Check how darcs handles tags - rotate inventory files?
 	  ;; What happens when adding patches one by one?
 	  (append-inventory outname patchinfo)
-	  (format t ".")))
+	  (princ #\.)
+	  (force-output)))
       (format t "~&Creating pristine")
       (create-pristine-from-tree outname)
       (format t "~&All done"))))
@@ -115,7 +116,8 @@
 			       (upath-subdir from '("_darcs" "patches") filename)
 			       :binary t))
 	  (fad:copy-stream in out))))
-    (princ #\.)))
+    (princ #\.)
+    (force-output)))
 
 (defun copy-checkpoint (from to checkpoint)
   "Copy CHECKPOINT from repository FROM to repository TO.

Modified: cl-darcs/trunk/pull.lisp
==============================================================================
--- cl-darcs/trunk/pull.lisp	(original)
+++ cl-darcs/trunk/pull.lisp	Sat Mar 10 22:14:51 2007
@@ -92,7 +92,8 @@
 		    :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 "."))
+	    (princ #\.)
+	    (force-output))
 	  (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/.~>" nil)))))


From mhenoch at common-lisp.net  Tue Mar 13 04:14:01 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Mon, 12 Mar 2007 23:14:01 -0500 (EST)
Subject: [Cl-darcs-cvs] r109 - cl-darcs/trunk
Message-ID: <20070313041401.5A4657D195@common-lisp.net>

Author: mhenoch
Date: Mon Mar 12 23:14:00 2007
New Revision: 109

Modified:
   cl-darcs/trunk/cl-darcs.asd
Log:
Fix dependency problem for record.lisp


Modified: cl-darcs/trunk/cl-darcs.asd
==============================================================================
--- cl-darcs/trunk/cl-darcs.asd	(original)
+++ cl-darcs/trunk/cl-darcs.asd	Mon Mar 12 23:14:00 2007
@@ -38,9 +38,9 @@
    (:file "prefs" :depends-on ("util"))
    (:file "repo" :depends-on ("util"))
    (:file "diff" :depends-on ("util"))
-   (:file "record" :depends-on ("util"))
 
    (:file "patch-core" :depends-on ("util"))
+   (:file "record" :depends-on ("patch-core"))
    (:file "read-patch" :depends-on ("patch-core"))
    (:file "write-patch" :depends-on ("patch-core"))
    (:file "apply-patch" :depends-on ("patch-core"))


From mhenoch at common-lisp.net  Thu Mar 15 21:41:55 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Thu, 15 Mar 2007 16:41:55 -0500 (EST)
Subject: [Cl-darcs-cvs] r110 - cl-darcs/trunk
Message-ID: <20070315214155.7B85945000@common-lisp.net>

Author: mhenoch
Date: Thu Mar 15 16:41:55 2007
New Revision: 110

Modified:
   cl-darcs/trunk/repo.lisp
Log:
Fix thinko in get-common-and-uncommon


Modified: cl-darcs/trunk/repo.lisp
==============================================================================
--- cl-darcs/trunk/repo.lisp	(original)
+++ cl-darcs/trunk/repo.lisp	Thu Mar 15 16:41:55 2007
@@ -159,6 +159,6 @@
   ;; 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)
+    (values (intersection 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  Thu Mar 15 22:27:17 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Thu, 15 Mar 2007 17:27:17 -0500 (EST)
Subject: [Cl-darcs-cvs] r111 - cl-darcs/trunk
Message-ID: <20070315222717.651997D19D@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))))


From mhenoch at common-lisp.net  Fri Mar 16 02:47:47 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Thu, 15 Mar 2007 21:47:47 -0500 (EST)
Subject: [Cl-darcs-cvs] r112 - cl-darcs/trunk
Message-ID: <20070316024747.ECD573C053@common-lisp.net>

Author: mhenoch
Date: Thu Mar 15 21:47:47 2007
New Revision: 112

Added:
   cl-darcs/trunk/revert.lisp
Modified:
   cl-darcs/trunk/cl-darcs.asd
Log:
Add revert.lisp and REVERT-CHANGES


Modified: cl-darcs/trunk/cl-darcs.asd
==============================================================================
--- cl-darcs/trunk/cl-darcs.asd	(original)
+++ cl-darcs/trunk/cl-darcs.asd	Thu Mar 15 21:47:47 2007
@@ -54,6 +54,7 @@
    (:file "unwind" :depends-on ("patch-core"))
    (:file "equal" :depends-on ("patch-core"))
    (:file "send" :depends-on ("patch-core"))
+   (:file "revert" :depends-on ("patch-core"))
 
    ;; Franz' inflate implementation
    #-allegro (:file "ifstar")

Added: cl-darcs/trunk/revert.lisp
==============================================================================
--- (empty file)
+++ cl-darcs/trunk/revert.lisp	Thu Mar 15 21:47:47 2007
@@ -0,0 +1,54 @@
+;;; 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 revert-changes (repo &key (select-patches :ask))
+  "Revert unrecorded changes in REPO.
+SELECT-PATCHES specifies how to select which patches to revert.
+It can be one of:
+:ALL - revert all patches
+:ASK - ask for each patch through Y-OR-N-P
+a function - call this function with a PATCH object, and
+             revert if it returns true"
+  (setf repo (fad:pathname-as-directory repo))
+  
+  (let* ((patches (diff-repo repo))
+	 (patches-to-keep
+	  (if (eql select-patches :all)
+	      nil
+	      (select-patches (copy-seq patches)
+			      ;; here the sense of the predicate is
+			      ;; inverted.
+			      (case select-patches
+				(:ask (lambda (p)
+					(display-patch p *query-io*)
+					(not (y-or-n-p "Revert this patch?"))))
+				(t (complement select-patches)))))))
+    ;; First revert all patches
+    (format t "~&Reverting")
+    (dolist (patch (reverse (mapcar #'invert-patch patches)))
+      (apply-patch patch repo)
+      (princ #\.)
+      (force-output))
+
+    ;; Then reapply all patches we want to keep
+    (format t "~&Reapplying")
+    (dolist (patch patches-to-keep)
+      (apply-patch patch repo)
+      (princ #\.)
+      (force-output))))
+


From mhenoch at common-lisp.net  Fri Mar 16 02:48:22 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Thu, 15 Mar 2007 21:48:22 -0500 (EST)
Subject: [Cl-darcs-cvs] r113 - cl-darcs/trunk
Message-ID: <20070316024822.A77343C053@common-lisp.net>

Author: mhenoch
Date: Thu Mar 15 21:48:22 2007
New Revision: 113

Modified:
   cl-darcs/trunk/packages.lisp
Log:
Export REVERT-CHANGES and SEND-TO-FILE


Modified: cl-darcs/trunk/packages.lisp
==============================================================================
--- cl-darcs/trunk/packages.lisp	(original)
+++ cl-darcs/trunk/packages.lisp	Thu Mar 15 21:48:22 2007
@@ -6,4 +6,5 @@
   (:export
    #:*http-proxy*
    #:get-repo #:pull #:diff-repo #:diff-repo-display 
-   #:record-changes #:create-repo))
+   #:record-changes #:create-repo
+   #:revert-changes #:send-to-file))


From mhenoch at common-lisp.net  Fri Mar 16 03:19:21 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Thu, 15 Mar 2007 22:19:21 -0500 (EST)
Subject: [Cl-darcs-cvs] r114 - cl-darcs/trunk
Message-ID: <20070316031921.C469C1B@common-lisp.net>

Author: mhenoch
Date: Thu Mar 15 22:19:21 2007
New Revision: 114

Modified:
   cl-darcs/trunk/commute.lisp
Log:
Add COMMUTE methods for trivial commutations of FILE-PATCH and MERGER-PATCH.


Modified: cl-darcs/trunk/commute.lisp
==============================================================================
--- cl-darcs/trunk/commute.lisp	(original)
+++ cl-darcs/trunk/commute.lisp	Thu Mar 15 22:19:21 2007
@@ -97,6 +97,30 @@
 	(list p1 p2)
 	(call-next-method))))
 
+(defmethod commute :around ((p2 file-patch) (p1 merger-patch))
+  "If P1 touches only one file, and P2 touches another, commutation is trivial."
+  (let ((p1-first (merger-first p1))
+	(p1-second (merger-second p1))
+	(p2-file (patch-filename p2)))
+    (if (and (typep p1-first 'file-patch)
+	     (typep p1-second 'file-patch)
+	     (equal (patch-filename p1-first) (patch-filename p1-second))
+	     (not (equal (patch-filename p1-first) p2-file)))
+	(list p1 p2)
+	(call-next-method))))
+
+(defmethod commute :around ((p2 merger-patch) (p1 file-patch))
+  "If P2 touches only one file, and P1 touches another, commutation is trivial."
+  (let ((p1-file (patch-filename p1))
+	(p2-first (merger-first p2))
+	(p2-second (merger-second p2)))
+    (if (and (typep p2-first 'file-patch)
+	     (typep p2-second 'file-patch)
+	     (equal (patch-filename p2-first) (patch-filename p2-second))
+	     (not (equal (patch-filename p2-first) p1-file)))
+	(list p1 p2)
+	(call-next-method))))
+
 (defmethod commute ((p2 hunk-patch) (p1 hunk-patch))
   "Attempt to commute the two hunk patches P1 and P2."
   (assert (equal (patch-filename p1) (patch-filename p2)))


From mhenoch at common-lisp.net  Fri Mar 16 03:22:39 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Thu, 15 Mar 2007 22:22:39 -0500 (EST)
Subject: [Cl-darcs-cvs] r115 - cl-darcs/trunk
Message-ID: <20070316032239.75BD63201F@common-lisp.net>

Author: mhenoch
Date: Thu Mar 15 22:22:39 2007
New Revision: 115

Modified:
   cl-darcs/trunk/revert.lisp
Log:
Only print "Reapplying" when actually reapplying something


Modified: cl-darcs/trunk/revert.lisp
==============================================================================
--- cl-darcs/trunk/revert.lisp	(original)
+++ cl-darcs/trunk/revert.lisp	Thu Mar 15 22:22:39 2007
@@ -45,10 +45,11 @@
       (princ #\.)
       (force-output))
 
-    ;; Then reapply all patches we want to keep
-    (format t "~&Reapplying")
-    (dolist (patch patches-to-keep)
-      (apply-patch patch repo)
-      (princ #\.)
-      (force-output))))
+    (when patches-to-keep
+      ;; Then reapply all patches we want to keep
+      (format t "~&Reapplying")
+      (dolist (patch patches-to-keep)
+	(apply-patch patch repo)
+	(princ #\.)
+	(force-output)))))
 


From mhenoch at common-lisp.net  Fri Mar 30 13:14:34 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Fri, 30 Mar 2007 08:14:34 -0500 (EST)
Subject: [Cl-darcs-cvs] r116 - cl-darcs/trunk
Message-ID: <20070330131434.20CC03A01F@common-lisp.net>

Author: mhenoch
Date: Fri Mar 30 08:14:33 2007
New Revision: 116

Modified:
   cl-darcs/trunk/send.lisp
Log:
Don't use PI as variable in lambda function


Modified: cl-darcs/trunk/send.lisp
==============================================================================
--- cl-darcs/trunk/send.lisp	(original)
+++ cl-darcs/trunk/send.lisp	Fri Mar 30 08:14:33 2007
@@ -77,8 +77,8 @@
 
 	  ;; XXX: handle tags properly.
 	  (let ((latest-tag (member-if
-			     (lambda (pi)
-			       (string= (patchinfo-name pi) "TAG "
+			     (lambda (patchinfo)
+			       (string= (patchinfo-name patchinfo) "TAG "
 					:end1 4))
 			     common)))
 	    ;; Here we just cut history after the latest tag.  This


From mhenoch at common-lisp.net  Fri Mar 30 13:15:59 2007
From: mhenoch at common-lisp.net (mhenoch at common-lisp.net)
Date: Fri, 30 Mar 2007 08:15:59 -0500 (EST)
Subject: [Cl-darcs-cvs] r117 - cl-darcs/trunk
Message-ID: <20070330131559.F16B63A03E@common-lisp.net>

Author: mhenoch
Date: Fri Mar 30 08:15:59 2007
New Revision: 117

Modified:
   cl-darcs/trunk/send.lisp
Log:
Don't cut history after latest tag if there is no tag


Modified: cl-darcs/trunk/send.lisp
==============================================================================
--- cl-darcs/trunk/send.lisp	(original)
+++ cl-darcs/trunk/send.lisp	Fri Mar 30 08:15:59 2007
@@ -81,9 +81,10 @@
 			       (string= (patchinfo-name patchinfo) "TAG "
 					:end1 4))
 			     common)))
-	    ;; Here we just cut history after the latest tag.  This
-	    ;; should work in most cases.
-	    (setf (cdr latest-tag) nil))
+	    (when latest-tag
+	      ;; 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