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))))