source: cl-darcs/trunk/send.lisp

Last change on this file was 121, checked in by Magnus Henoch, 17 years ago

Ironclad's SHA1 works with CLISP now

File size: 3.9 KB
Line 
1;;; Copyright (C) 2007 Magnus Henoch
2;;;
3;;; This program is free software; you can redistribute it and/or
4;;; modify it under the terms of the GNU General Public License as
5;;; published by the Free Software Foundation; either version 2 of the
6;;; License, or (at your option) any later version.
7;;;
8;;; This program is distributed in the hope that it will be useful,
9;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11;;; General Public License for more details.
12;;;
13;;; You should have received a copy of the GNU General Public License
14;;; along with this program; if not, write to the Free Software
15;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
16
17(in-package :darcs)
18
19(defun send-to-file (our-repo file &key their-repo (select-patches :ask))
20  "Write new patches in OUR-REPO to FILE, suitable for sending by e-mail.
21\"New\" patches are those present in OUR-REPO but not in
22THEIR-REPO.  If THEIR-REPO is NIL, use default repository
23specified in preferences.
24SELECT-PATCHES specifies how to select which patches to include.
25It can be one of:
26:ALL - include all patches
27:ASK - ask for each patch through Y-OR-N-P
28a function - call this function with a NAMED-PATCH object, and
29             include if it returns true"
30  (setf our-repo (fad:pathname-as-directory our-repo))
31  (unless their-repo
32    (unless (setf their-repo (car (get-preflist our-repo "defaultrepo")))
33      (error "No remote repositiory specified, and no default available.")))
34
35  (with-open-file (f file
36                     :direction :output
37                     :element-type '(unsigned-byte 8))
38   
39    (let ((our-patchinfo (read-repo-patch-list our-repo))
40          (their-patchinfo (read-repo-patch-list their-repo)))
41      (multiple-value-bind (common only-ours only-theirs)
42          (get-common-and-uncommon our-patchinfo their-patchinfo)
43        (declare (ignore only-theirs))
44        (format t "~&Found these new patches:")
45        (dolist (p only-ours)
46          (format t "~& - ~A" p))
47
48        (let* ((all-our-patches
49                (mapcar (lambda (patchinfo)
50                          (read-patch-from-repo our-repo patchinfo))
51                        only-ours))
52               (patches-to-send
53                (if (or (eq select-patches :all)
54                        (and (eq select-patches :ask)
55                             (y-or-n-p "Send all patches?")))
56                    all-our-patches
57                    (select-patches all-our-patches 
58                                    (if (functionp select-patches)
59                                        select-patches
60                                        (lambda (patch) 
61                                          (display-patch patch *query-io*)
62                                          (y-or-n-p "Include patch ~A? " patch)))))))
63
64          (write-byte 10 f)
65          (write-sequence (string-to-bytes "New patches:") f)
66          (write-byte 10 f)
67          (write-byte 10 f)
68          (dolist (patch patches-to-send)
69            (write-patch patch f))
70          (write-byte 10 f)
71
72          (write-sequence (string-to-bytes "Context:") f)
73          (write-byte 10 f)
74          (write-byte 10 f)
75          ;; Context is in reverse order: latest applied first.
76          (setf common (nreverse common))
77
78          ;; XXX: handle tags properly.
79          (let ((latest-tag (member-if
80                             (lambda (patchinfo)
81                               (string= (patchinfo-name patchinfo) "TAG "
82                                        :end1 4))
83                             common)))
84            (when latest-tag
85              ;; Here we just cut history after the latest tag.  This
86              ;; should work in most cases.
87              (setf (cdr latest-tag) nil)))
88
89          (dolist (patchinfo common)
90            (write-sequence (string-to-bytes
91                             (with-output-to-string (strout)
92                               (write-patchinfo patchinfo strout)))
93                            f)
94            (write-byte 10 f))
95          (write-sequence (string-to-bytes "Patch bundle hash:") f)
96          (write-byte 10 f)
97          (write-sequence (string-to-bytes (hash-bundle patches-to-send)) f)
98          (write-byte 10 f))))))
99
100(defun hash-bundle (patches)
101  (let ((patches-as-vector
102         (flexi-streams:with-output-to-sequence (out)
103           (dolist (patch patches)
104             (write-patch patch out)))))
105    (setf patches-as-vector
106          (make-array (length patches-as-vector)
107                      :element-type '(unsigned-byte 8)
108                      :initial-contents patches-as-vector))
109    (ironclad:byte-array-to-hex-string
110     (ironclad:digest-sequence :sha1 patches-as-vector))))
Note: See TracBrowser for help on using the repository browser.