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 |
---|
22 | THEIR-REPO. If THEIR-REPO is NIL, use default repository |
---|
23 | specified in preferences. |
---|
24 | SELECT-PATCHES specifies how to select which patches to include. |
---|
25 | It can be one of: |
---|
26 | :ALL - include all patches |
---|
27 | :ASK - ask for each patch through Y-OR-N-P |
---|
28 | a 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)))) |
---|