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