Commit | Line | Data |
---|---|---|
9ebea0e7 SM |
1 | ;;; bzrmerge.el --- |
2 | ||
529ee9ed | 3 | ;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. |
9ebea0e7 SM |
4 | |
5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> | |
6 | ;; Keywords: | |
7 | ||
529ee9ed | 8 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
9ebea0e7 SM |
9 | ;; it under the terms of the GNU General Public License as published by |
10 | ;; the Free Software Foundation, either version 3 of the License, or | |
11 | ;; (at your option) any later version. | |
12 | ||
529ee9ed | 13 | ;; GNU Emacs is distributed in the hope that it will be useful, |
9ebea0e7 SM |
14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;; GNU General Public License for more details. | |
17 | ||
18 | ;; You should have received a copy of the GNU General Public License | |
529ee9ed | 19 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
9ebea0e7 SM |
20 | |
21 | ;;; Commentary: | |
22 | ||
23 | ;; | |
24 | ||
25 | ;;; Code: | |
26 | ||
27 | (defun bzrmerge-merges () | |
28 | "Return the list of already merged (not not committed) revisions. | |
29 | The list returned is sorted by oldest-first." | |
30 | (with-current-buffer (get-buffer-create "*bzrmerge*") | |
31 | (erase-buffer) | |
32 | ;; We generally want to make sure we start with a clean tree, but we also | |
33 | ;; want to allow restarts (i.e. with some part of FROM already merged but | |
34 | ;; not yet committed). | |
35 | (call-process "bzr" nil t nil "status" "-v") | |
36 | (goto-char (point-min)) | |
37 | (when (re-search-forward "^conflicts:\n" nil t) | |
38 | (error "You still have unresolved conflicts")) | |
39 | (let ((merges ())) | |
40 | (if (not (re-search-forward "^pending merges:\n" nil t)) | |
41 | (when (save-excursion | |
42 | (goto-char (point-min)) | |
43 | (re-search-forward "^[a-z ]*:\n" nil t)) | |
44 | (error "You still have uncommitted changes")) | |
45 | ;; This is really stupid, but it seems there's no easy way to figure | |
46 | ;; out which revisions have been merged already. The only info I can | |
47 | ;; find is the "pending merges" from "bzr status -v", which is not | |
48 | ;; very machine-friendly. | |
49 | (while (not (eobp)) | |
50 | (skip-chars-forward " ") | |
51 | (push (buffer-substring (point) (line-end-position)) merges) | |
52 | (forward-line 1))) | |
53 | merges))) | |
54 | ||
55 | (defun bzrmerge-check-match (merge) | |
56 | ;; Make sure the MERGES match the revisions on the FROM branch. | |
57 | ;; Stupidly the best form of MERGES I can find is the one from | |
58 | ;; "bzr status -v" which is very machine non-friendly, so I have | |
59 | ;; to do some fuzzy matching. | |
60 | (let ((author | |
61 | (or | |
62 | (save-excursion | |
63 | (if (re-search-forward "^author: *\\([^<]*[^ ]\\) +<.*" | |
64 | nil t) | |
65 | (match-string 1))) | |
66 | (save-excursion | |
67 | (if (re-search-forward | |
68 | "^committer: *\\([^<]*[^< ]\\) +<" nil t) | |
69 | (match-string 1))))) | |
70 | (timestamp | |
71 | (save-excursion | |
72 | (if (re-search-forward | |
73 | "^timestamp:[^0-9]*\\([-0-9]+\\)" nil t) | |
74 | (match-string 1)))) | |
75 | (line1 | |
76 | (save-excursion | |
77 | (if (re-search-forward "^message:[ \n]*" nil t) | |
78 | (buffer-substring (point) (line-end-position)))))) | |
79 | ;; The `merge' may have a truncated line1 with "...", so get | |
80 | ;; rid of any "..." and then look for a prefix match. | |
81 | (when (string-match "\\.+\\'" merge) | |
82 | (setq merge (substring merge 0 (match-beginning 0)))) | |
83 | (or (string-prefix-p | |
84 | merge (concat author " " timestamp " " line1)) | |
85 | (string-prefix-p | |
86 | merge (concat author " " timestamp " [merge] " line1))))) | |
87 | ||
88 | (defun bzrmerge-missing (from merges) | |
89 | "Return the list of revisions that need to be merged. | |
90 | MERGES is the revisions already merged but not yet committed. | |
91 | The result is of the form (TOMERGE . TOSKIP) where TOMERGE and TOSKIP | |
92 | are both lists of revnos, in oldest-first order." | |
93 | (with-current-buffer (get-buffer-create "*bzrmerge*") | |
94 | (erase-buffer) | |
95 | (call-process "bzr" nil t nil "missing" "--theirs-only" | |
96 | (expand-file-name from)) | |
97 | (let ((revnos ()) (skipped ())) | |
98 | (pop-to-buffer (current-buffer)) | |
99 | (goto-char (point-max)) | |
100 | (while (re-search-backward "^------------------------------------------------------------\nrevno: \\([0-9.]+\\).*" nil t) | |
101 | (save-excursion | |
102 | (if merges | |
103 | (while (not (bzrmerge-check-match (pop merges))) | |
104 | (unless merges | |
105 | (error "Unmatched tip of merged revisions"))) | |
106 | (let ((case-fold-search t) | |
107 | (revno (match-string 1)) | |
108 | (skip nil)) | |
109 | (if (string-match "\\." revno) | |
110 | (error "Unexpected dotted revno!") | |
111 | (setq revno (string-to-number revno))) | |
112 | (re-search-forward "^message:\n") | |
113 | (while (and (not skip) | |
114 | (re-search-forward | |
115 | "back[- ]?port\\|merge\\|re-?generate\\|bump version" nil t)) | |
116 | (let ((str (buffer-substring (line-beginning-position) | |
117 | (line-end-position)))) | |
118 | (when (string-match "\\` *" str) | |
119 | (setq str (substring str (match-end 0)))) | |
120 | (when (string-match "[.!;, ]+\\'" str) | |
121 | (setq str (substring str 0 (match-beginning 0)))) | |
122 | (if (save-excursion (y-or-n-p (concat str ": Skip? "))) | |
123 | (setq skip t)))) | |
124 | (if skip | |
125 | (push revno skipped) | |
126 | (push revno revnos))))) | |
127 | (delete-region (point) (point-max))) | |
128 | (cons (nreverse revnos) (nreverse skipped))))) | |
129 | ||
130 | (defun bzrmerge-resolve (file) | |
131 | (unless (file-exists-p file) (error "Bzrmerge-resolve: Can't find %s" file)) | |
132 | (with-demoted-errors | |
133 | (let ((exists (find-buffer-visiting file))) | |
134 | (with-current-buffer (find-file-noselect file) | |
135 | (if (buffer-modified-p) | |
136 | (error "Unsaved changes in %s" (current-buffer))) | |
137 | (save-excursion | |
138 | (cond | |
139 | ((derived-mode-p 'change-log-mode) | |
140 | ;; Fix up dates before resolving the conflicts. | |
141 | (goto-char (point-min)) | |
142 | (let ((diff-auto-refine-mode nil)) | |
143 | (while (re-search-forward smerge-begin-re nil t) | |
144 | (smerge-match-conflict) | |
145 | (smerge-ensure-match 3) | |
146 | (let ((start1 (match-beginning 1)) | |
147 | (end1 (match-end 1)) | |
148 | (start3 (match-beginning 3)) | |
149 | (end3 (copy-marker (match-end 3) t))) | |
150 | (goto-char start3) | |
151 | (while (re-search-forward change-log-start-entry-re end3 t) | |
152 | (let* ((str (match-string 0)) | |
153 | (newstr (save-match-data | |
154 | (concat (add-log-iso8601-time-string) | |
155 | (when (string-match " *\\'" str) | |
156 | (match-string 0 str)))))) | |
157 | (replace-match newstr t t))) | |
158 | ;; change-log-resolve-conflict prefers to put match-1's | |
159 | ;; elements first (for equal dates), whereas we want to put | |
160 | ;; match-3's first. | |
161 | (let ((match3 (buffer-substring start3 end3)) | |
162 | (match1 (buffer-substring start1 end1))) | |
163 | (delete-region start3 end3) | |
164 | (goto-char start3) | |
165 | (insert match1) | |
166 | (delete-region start1 end1) | |
167 | (goto-char start1) | |
168 | (insert match3))))) | |
169 | ;; (pop-to-buffer (current-buffer)) (debug 'before-resolve) | |
170 | )) | |
171 | ;; Try to resolve the conflicts. | |
172 | (cond | |
173 | ((member file '("configure" "lisp/ldefs-boot.el")) | |
174 | (call-process "bzr" nil t nil "revert" file) | |
175 | (revert-buffer nil 'noconfirm)) | |
176 | (t | |
177 | (goto-char (point-max)) | |
178 | (while (re-search-backward smerge-begin-re nil t) | |
179 | (save-excursion | |
180 | (ignore-errors | |
181 | (smerge-match-conflict) | |
182 | (smerge-resolve)))) | |
183 | ;; (when (derived-mode-p 'change-log-mode) | |
184 | ;; (pop-to-buffer (current-buffer)) (debug 'after-resolve)) | |
185 | (save-buffer))) | |
186 | (goto-char (point-min)) | |
187 | (prog1 (re-search-forward smerge-begin-re nil t) | |
188 | (unless exists (kill-buffer)))))))) | |
189 | ||
190 | (defun bzrmerge-add-metadata (from endrevno) | |
191 | "Add the metadata for a merge of FROM upto ENDREVNO. | |
192 | Does not make other difference." | |
193 | (if (with-temp-buffer | |
194 | (call-process "bzr" nil t nil "status") | |
195 | (goto-char (point-min)) | |
196 | (re-search-forward "^conflicts:\n" nil t)) | |
197 | (error "Don't know how to add metadata in the presence of conflicts") | |
198 | (call-process "bzr" nil t nil "shelve" "--all" | |
199 | "-m" "Bzrmerge shelved merge during skipping") | |
200 | (call-process "bzr" nil t nil "revert") | |
201 | (call-process "bzr" nil t nil | |
202 | "merge" "-r" (format "%s" endrevno) from) | |
203 | (call-process "bzr" nil t nil "revert" ".") | |
204 | (call-process "bzr" nil t nil "unshelve"))) | |
529ee9ed | 205 | |
9ebea0e7 SM |
206 | (defvar bzrmerge-already-done nil) |
207 | ||
208 | (defun bzrmerge-apply (missing from) | |
209 | (setq from (expand-file-name from)) | |
210 | (with-current-buffer (get-buffer-create "*bzrmerge*") | |
211 | (erase-buffer) | |
212 | (when (equal (cdr bzrmerge-already-done) (list from missing)) | |
213 | (setq missing (car bzrmerge-already-done))) | |
214 | (setq bzrmerge-already-done nil) | |
215 | (let ((merge (car missing)) | |
216 | (skip (cdr missing)) | |
217 | beg end) | |
218 | (when (or merge skip) | |
219 | (cond | |
220 | ((and skip (or (null merge) (< (car skip) (car merge)))) | |
221 | ;; Do a "skip" (i.e. merge the meta-data only). | |
222 | (setq beg (1- (car skip))) | |
223 | (while (and skip (or (null merge) (< (car skip) (car merge)))) | |
224 | (assert (> (car skip) (or end beg))) | |
225 | (setq end (pop skip))) | |
226 | (message "Skipping %s..%s" beg end) | |
227 | (bzrmerge-add-metadata from end)) | |
228 | ||
229 | (t | |
230 | ;; Do a "normal" merge. | |
231 | (assert (or (null skip) (< (car merge) (car skip)))) | |
232 | (setq beg (1- (car merge))) | |
233 | (while (and merge (or (null skip) (< (car merge) (car skip)))) | |
234 | (assert (> (car merge) (or end beg))) | |
235 | (setq end (pop merge))) | |
236 | (message "Merging %s..%s" beg end) | |
237 | (if (with-temp-buffer | |
238 | (call-process "bzr" nil t nil "status") | |
239 | (zerop (buffer-size))) | |
240 | (call-process "bzr" nil t nil | |
241 | "merge" "-r" (format "%s" end) from) | |
242 | ;; Stupidly, "bzr merge --force -r A..B" dos not maintain the | |
243 | ;; metadata properly except when the checkout is clean. | |
244 | (call-process "bzr" nil t nil "merge" | |
245 | "--force" "-r" (format "%s..%s" beg end) from) | |
246 | ;; The merge did not update the metadata, so force the next time | |
247 | ;; around to update it (as a "skip"). | |
248 | (push end skip)) | |
249 | (pop-to-buffer (current-buffer)) | |
250 | (sit-for 1) | |
251 | ;; (debug 'after-merge) | |
252 | ;; Check the conflicts. | |
253 | (let ((conflicted nil) | |
254 | (files ())) | |
255 | (goto-char (point-min)) | |
256 | (when (re-search-forward "bzr: ERROR:" nil t) | |
257 | (error "Internal Bazaar error!!")) | |
258 | (while (re-search-forward "^Text conflict in " nil t) | |
259 | (push (buffer-substring (point) (line-end-position)) files)) | |
260 | (if (re-search-forward "^\\([0-9]+\\) conflicts encountered" nil t) | |
261 | (if (/= (length files) (string-to-number (match-string 1))) | |
262 | (setq conflicted t)) | |
263 | (if files (setq conflicted t))) | |
264 | (dolist (file files) | |
265 | (if (bzrmerge-resolve file) | |
266 | (setq conflicted t))) | |
267 | (when conflicted | |
268 | (setq bzrmerge-already-done | |
269 | (list (cons merge skip) from missing)) | |
270 | (error "Resolve conflicts manually"))))) | |
271 | (cons merge skip))))) | |
272 | ||
273 | (defun bzrmerge (from) | |
274 | "Merge from branch FROM into `default-directory'." | |
275 | (interactive | |
276 | (list | |
277 | (let ((def | |
278 | (with-temp-buffer | |
279 | (call-process "bzr" nil t nil "info") | |
280 | (goto-char (point-min)) | |
281 | (when (re-search-forward "submit branch: *" nil t) | |
282 | (buffer-substring (point) (line-end-position)))))) | |
283 | (read-file-name "From branch: " nil nil nil def)))) | |
284 | (message "Merging from %s..." from) | |
285 | (require 'vc-bzr) | |
286 | (let ((default-directory (or (vc-bzr-root default-directory) | |
287 | (error "Not in a Bzr tree")))) | |
288 | ;; First, check the status. | |
289 | (let* ((merges (bzrmerge-merges)) | |
290 | ;; OK, we have the status, now check the missing data. | |
291 | (missing (bzrmerge-missing from merges))) | |
292 | (while missing | |
293 | (setq missing (bzrmerge-apply missing from)))))) | |
294 | ||
295 | (provide 'bzrmerge) | |
296 | ;;; bzrmerge.el ends here |