Commit | Line | Data |
---|---|---|
f6041baa | 1 | ;;; bzrmerge.el --- help merge one Emacs bzr branch to another |
9ebea0e7 | 2 | |
ab422c4d | 3 | ;; Copyright (C) 2010-2013 Free Software Foundation, Inc. |
9ebea0e7 SM |
4 | |
5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> | |
c9279dad | 6 | ;; Keywords: maint |
9ebea0e7 | 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 | ||
f58e0fd5 | 27 | (eval-when-compile (require 'cl-lib)) |
1851cac3 | 28 | |
d0cb8662 | 29 | (defvar bzrmerge-skip-regexp |
6116bd7e GM |
30 | "back[- ]?port\\|merge\\|sync\\|re-?generate\\|bump version\\|from trunk\\|\ |
31 | Auto-commit" | |
d0cb8662 GM |
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 | |
a3f90bea GM |
48 | ;; not yet committed). Unversioned (unknown) files in the tree |
49 | ;; are also ok. | |
9ebea0e7 SM |
50 | (call-process "bzr" nil t nil "status" "-v") |
51 | (goto-char (point-min)) | |
52 | (when (re-search-forward "^conflicts:\n" nil t) | |
78be8b64 | 53 | (user-error "You still have unresolved conflicts")) |
a3f90bea GM |
54 | (let ((merges ()) |
55 | found) | |
9ebea0e7 SM |
56 | (if (not (re-search-forward "^pending merges:\n" nil t)) |
57 | (when (save-excursion | |
58 | (goto-char (point-min)) | |
a3f90bea GM |
59 | (while (and |
60 | (re-search-forward "^\\([a-z ]*\\):\n" nil t) | |
61 | (not | |
62 | (setq found | |
63 | (not (equal "unknown" (match-string 1))))))) | |
64 | found) | |
78be8b64 | 65 | (user-error "You still have uncommitted changes")) |
9ebea0e7 SM |
66 | ;; This is really stupid, but it seems there's no easy way to figure |
67 | ;; out which revisions have been merged already. The only info I can | |
68 | ;; find is the "pending merges" from "bzr status -v", which is not | |
69 | ;; very machine-friendly. | |
70 | (while (not (eobp)) | |
71 | (skip-chars-forward " ") | |
72 | (push (buffer-substring (point) (line-end-position)) merges) | |
73 | (forward-line 1))) | |
74 | merges))) | |
75 | ||
76 | (defun bzrmerge-check-match (merge) | |
77 | ;; Make sure the MERGES match the revisions on the FROM branch. | |
78 | ;; Stupidly the best form of MERGES I can find is the one from | |
79 | ;; "bzr status -v" which is very machine non-friendly, so I have | |
80 | ;; to do some fuzzy matching. | |
81 | (let ((author | |
82 | (or | |
83 | (save-excursion | |
84 | (if (re-search-forward "^author: *\\([^<]*[^ ]\\) +<.*" | |
85 | nil t) | |
86 | (match-string 1))) | |
87 | (save-excursion | |
88 | (if (re-search-forward | |
89 | "^committer: *\\([^<]*[^< ]\\) +<" nil t) | |
90 | (match-string 1))))) | |
91 | (timestamp | |
92 | (save-excursion | |
93 | (if (re-search-forward | |
94 | "^timestamp:[^0-9]*\\([-0-9]+\\)" nil t) | |
95 | (match-string 1)))) | |
96 | (line1 | |
97 | (save-excursion | |
98 | (if (re-search-forward "^message:[ \n]*" nil t) | |
99 | (buffer-substring (point) (line-end-position)))))) | |
100 | ;; The `merge' may have a truncated line1 with "...", so get | |
101 | ;; rid of any "..." and then look for a prefix match. | |
102 | (when (string-match "\\.+\\'" merge) | |
103 | (setq merge (substring merge 0 (match-beginning 0)))) | |
104 | (or (string-prefix-p | |
105 | merge (concat author " " timestamp " " line1)) | |
106 | (string-prefix-p | |
107 | merge (concat author " " timestamp " [merge] " line1))))) | |
108 | ||
109 | (defun bzrmerge-missing (from merges) | |
110 | "Return the list of revisions that need to be merged. | |
111 | MERGES is the revisions already merged but not yet committed. | |
d0cb8662 | 112 | Asks about skipping revisions with logs matching `bzrmerge-skip-regexp'. |
9ebea0e7 SM |
113 | The result is of the form (TOMERGE . TOSKIP) where TOMERGE and TOSKIP |
114 | are both lists of revnos, in oldest-first order." | |
f6041baa | 115 | (with-current-buffer (get-buffer-create bzrmerge-buffer) |
9ebea0e7 SM |
116 | (erase-buffer) |
117 | (call-process "bzr" nil t nil "missing" "--theirs-only" | |
118 | (expand-file-name from)) | |
119 | (let ((revnos ()) (skipped ())) | |
120 | (pop-to-buffer (current-buffer)) | |
121 | (goto-char (point-max)) | |
122 | (while (re-search-backward "^------------------------------------------------------------\nrevno: \\([0-9.]+\\).*" nil t) | |
123 | (save-excursion | |
124 | (if merges | |
125 | (while (not (bzrmerge-check-match (pop merges))) | |
126 | (unless merges | |
127 | (error "Unmatched tip of merged revisions"))) | |
128 | (let ((case-fold-search t) | |
129 | (revno (match-string 1)) | |
130 | (skip nil)) | |
131 | (if (string-match "\\." revno) | |
132 | (error "Unexpected dotted revno!") | |
133 | (setq revno (string-to-number revno))) | |
134 | (re-search-forward "^message:\n") | |
135 | (while (and (not skip) | |
d0cb8662 | 136 | (re-search-forward bzrmerge-skip-regexp nil t)) |
9ebea0e7 SM |
137 | (let ((str (buffer-substring (line-beginning-position) |
138 | (line-end-position)))) | |
139 | (when (string-match "\\` *" str) | |
140 | (setq str (substring str (match-end 0)))) | |
141 | (when (string-match "[.!;, ]+\\'" str) | |
142 | (setq str (substring str 0 (match-beginning 0)))) | |
54de86ac GM |
143 | (let ((help-form "\ |
144 | Type `y' to skip this revision, | |
145 | `N' to include it and go on to the next revision, | |
146 | `n' to not skip, but continue to search this log entry for skip regexps, | |
147 | `q' to quit merging.")) | |
4dc7c8d5 | 148 | (pcase (save-excursion |
54de86ac GM |
149 | (read-char-choice |
150 | (format "%s: Skip (y/n/N/q/%s)? " str | |
151 | (key-description (vector help-char))) | |
152 | '(?y ?n ?N ?q))) | |
4dc7c8d5 SM |
153 | (`?y (setq skip t)) |
154 | (`?q (keyboard-quit)) | |
54de86ac GM |
155 | ;; A single log entry can match skip-regexp multiple |
156 | ;; times. If you are sure you don't want to skip it, | |
157 | ;; you don't want to be asked multiple times. | |
4dc7c8d5 | 158 | (`?N (setq skip 'no)))))) |
54de86ac | 159 | (if (eq skip t) |
9ebea0e7 SM |
160 | (push revno skipped) |
161 | (push revno revnos))))) | |
162 | (delete-region (point) (point-max))) | |
f6041baa GM |
163 | (and (or revnos skipped) |
164 | (cons (nreverse revnos) (nreverse skipped)))))) | |
9ebea0e7 SM |
165 | |
166 | (defun bzrmerge-resolve (file) | |
167 | (unless (file-exists-p file) (error "Bzrmerge-resolve: Can't find %s" file)) | |
168 | (with-demoted-errors | |
169 | (let ((exists (find-buffer-visiting file))) | |
23c726f6 GM |
170 | (with-current-buffer (let ((enable-local-variables :safe) |
171 | (enable-local-eval nil)) | |
2a35386d | 172 | (find-file-noselect file)) |
9ebea0e7 | 173 | (if (buffer-modified-p) |
78be8b64 | 174 | (user-error "Unsaved changes in %s" (current-buffer))) |
9ebea0e7 SM |
175 | (save-excursion |
176 | (cond | |
177 | ((derived-mode-p 'change-log-mode) | |
178 | ;; Fix up dates before resolving the conflicts. | |
179 | (goto-char (point-min)) | |
180 | (let ((diff-auto-refine-mode nil)) | |
181 | (while (re-search-forward smerge-begin-re nil t) | |
182 | (smerge-match-conflict) | |
183 | (smerge-ensure-match 3) | |
184 | (let ((start1 (match-beginning 1)) | |
185 | (end1 (match-end 1)) | |
186 | (start3 (match-beginning 3)) | |
187 | (end3 (copy-marker (match-end 3) t))) | |
188 | (goto-char start3) | |
189 | (while (re-search-forward change-log-start-entry-re end3 t) | |
190 | (let* ((str (match-string 0)) | |
191 | (newstr (save-match-data | |
192 | (concat (add-log-iso8601-time-string) | |
193 | (when (string-match " *\\'" str) | |
194 | (match-string 0 str)))))) | |
195 | (replace-match newstr t t))) | |
196 | ;; change-log-resolve-conflict prefers to put match-1's | |
197 | ;; elements first (for equal dates), whereas we want to put | |
198 | ;; match-3's first. | |
199 | (let ((match3 (buffer-substring start3 end3)) | |
200 | (match1 (buffer-substring start1 end1))) | |
201 | (delete-region start3 end3) | |
202 | (goto-char start3) | |
203 | (insert match1) | |
204 | (delete-region start1 end1) | |
205 | (goto-char start1) | |
206 | (insert match3))))) | |
207 | ;; (pop-to-buffer (current-buffer)) (debug 'before-resolve) | |
208 | )) | |
209 | ;; Try to resolve the conflicts. | |
210 | (cond | |
6fffc900 GM |
211 | ((member file '("configure" "lisp/ldefs-boot.el" |
212 | "lisp/emacs-lisp/cl-loaddefs.el")) | |
7b24e97a GM |
213 | ;; We are in the file's buffer, so names are relative. |
214 | (call-process "bzr" nil t nil "revert" | |
215 | (file-name-nondirectory file)) | |
9ebea0e7 SM |
216 | (revert-buffer nil 'noconfirm)) |
217 | (t | |
218 | (goto-char (point-max)) | |
219 | (while (re-search-backward smerge-begin-re nil t) | |
220 | (save-excursion | |
221 | (ignore-errors | |
222 | (smerge-match-conflict) | |
223 | (smerge-resolve)))) | |
224 | ;; (when (derived-mode-p 'change-log-mode) | |
225 | ;; (pop-to-buffer (current-buffer)) (debug 'after-resolve)) | |
226 | (save-buffer))) | |
227 | (goto-char (point-min)) | |
228 | (prog1 (re-search-forward smerge-begin-re nil t) | |
229 | (unless exists (kill-buffer)))))))) | |
230 | ||
231 | (defun bzrmerge-add-metadata (from endrevno) | |
232 | "Add the metadata for a merge of FROM upto ENDREVNO. | |
233 | Does not make other difference." | |
234 | (if (with-temp-buffer | |
235 | (call-process "bzr" nil t nil "status") | |
236 | (goto-char (point-min)) | |
237 | (re-search-forward "^conflicts:\n" nil t)) | |
238 | (error "Don't know how to add metadata in the presence of conflicts") | |
239 | (call-process "bzr" nil t nil "shelve" "--all" | |
240 | "-m" "Bzrmerge shelved merge during skipping") | |
241 | (call-process "bzr" nil t nil "revert") | |
242 | (call-process "bzr" nil t nil | |
243 | "merge" "-r" (format "%s" endrevno) from) | |
244 | (call-process "bzr" nil t nil "revert" ".") | |
245 | (call-process "bzr" nil t nil "unshelve"))) | |
529ee9ed | 246 | |
9ebea0e7 SM |
247 | (defvar bzrmerge-already-done nil) |
248 | ||
249 | (defun bzrmerge-apply (missing from) | |
250 | (setq from (expand-file-name from)) | |
f6041baa | 251 | (with-current-buffer (get-buffer-create bzrmerge-buffer) |
9ebea0e7 SM |
252 | (erase-buffer) |
253 | (when (equal (cdr bzrmerge-already-done) (list from missing)) | |
254 | (setq missing (car bzrmerge-already-done))) | |
255 | (setq bzrmerge-already-done nil) | |
256 | (let ((merge (car missing)) | |
257 | (skip (cdr missing)) | |
41f44310 | 258 | (unsafe nil) |
9ebea0e7 SM |
259 | beg end) |
260 | (when (or merge skip) | |
261 | (cond | |
262 | ((and skip (or (null merge) (< (car skip) (car merge)))) | |
263 | ;; Do a "skip" (i.e. merge the meta-data only). | |
264 | (setq beg (1- (car skip))) | |
265 | (while (and skip (or (null merge) (< (car skip) (car merge)))) | |
f58e0fd5 | 266 | (cl-assert (> (car skip) (or end beg))) |
9ebea0e7 SM |
267 | (setq end (pop skip))) |
268 | (message "Skipping %s..%s" beg end) | |
269 | (bzrmerge-add-metadata from end)) | |
270 | ||
271 | (t | |
272 | ;; Do a "normal" merge. | |
f58e0fd5 | 273 | (cl-assert (or (null skip) (< (car merge) (car skip)))) |
9ebea0e7 SM |
274 | (setq beg (1- (car merge))) |
275 | (while (and merge (or (null skip) (< (car merge) (car skip)))) | |
f58e0fd5 | 276 | (cl-assert (> (car merge) (or end beg))) |
9ebea0e7 SM |
277 | (setq end (pop merge))) |
278 | (message "Merging %s..%s" beg end) | |
279 | (if (with-temp-buffer | |
280 | (call-process "bzr" nil t nil "status") | |
281 | (zerop (buffer-size))) | |
282 | (call-process "bzr" nil t nil | |
283 | "merge" "-r" (format "%s" end) from) | |
284 | ;; Stupidly, "bzr merge --force -r A..B" dos not maintain the | |
285 | ;; metadata properly except when the checkout is clean. | |
286 | (call-process "bzr" nil t nil "merge" | |
287 | "--force" "-r" (format "%s..%s" beg end) from) | |
288 | ;; The merge did not update the metadata, so force the next time | |
289 | ;; around to update it (as a "skip"). | |
41f44310 | 290 | (setq unsafe t) |
9ebea0e7 SM |
291 | (push end skip)) |
292 | (pop-to-buffer (current-buffer)) | |
293 | (sit-for 1) | |
294 | ;; (debug 'after-merge) | |
295 | ;; Check the conflicts. | |
59af988b GM |
296 | ;; FIXME if using the helpful bzr changelog_merge plugin, |
297 | ;; there are normally no conflicts in ChangeLogs. | |
298 | ;; But we still want the dates fixing, like bzrmerge-resolve does. | |
9ebea0e7 SM |
299 | (let ((conflicted nil) |
300 | (files ())) | |
301 | (goto-char (point-min)) | |
302 | (when (re-search-forward "bzr: ERROR:" nil t) | |
303 | (error "Internal Bazaar error!!")) | |
304 | (while (re-search-forward "^Text conflict in " nil t) | |
305 | (push (buffer-substring (point) (line-end-position)) files)) | |
306 | (if (re-search-forward "^\\([0-9]+\\) conflicts encountered" nil t) | |
307 | (if (/= (length files) (string-to-number (match-string 1))) | |
308 | (setq conflicted t)) | |
309 | (if files (setq conflicted t))) | |
310 | (dolist (file files) | |
311 | (if (bzrmerge-resolve file) | |
312 | (setq conflicted t))) | |
313 | (when conflicted | |
314 | (setq bzrmerge-already-done | |
315 | (list (cons merge skip) from missing)) | |
41f44310 SM |
316 | (if unsafe |
317 | ;; FIXME: Obviously, we'd rather make it right rather | |
318 | ;; than output such a warning. But I don't know how to add | |
319 | ;; the metadata to bzr's since the technique used in | |
320 | ;; bzrmerge-add-metadata does not work when there | |
321 | ;; are conflicts. | |
322 | (display-warning 'bzrmerge "Resolve conflicts manually. | |
50d8b29d | 323 | BEWARE! Important metadata is kept in this Emacs session! |
4d881c83 GM |
324 | Do not commit without re-running `M-x bzrmerge' first!" |
325 | :warning bzrmerge-warning-buffer)) | |
78be8b64 | 326 | (user-error "Resolve conflicts manually"))))) |
9ebea0e7 SM |
327 | (cons merge skip))))) |
328 | ||
329 | (defun bzrmerge (from) | |
330 | "Merge from branch FROM into `default-directory'." | |
331 | (interactive | |
332 | (list | |
333 | (let ((def | |
334 | (with-temp-buffer | |
335 | (call-process "bzr" nil t nil "info") | |
336 | (goto-char (point-min)) | |
337 | (when (re-search-forward "submit branch: *" nil t) | |
338 | (buffer-substring (point) (line-end-position)))))) | |
339 | (read-file-name "From branch: " nil nil nil def)))) | |
4d881c83 GM |
340 | ;; Eg we ran bzrmerge once, it stopped with conflicts, we fixed them |
341 | ;; and are running it again. | |
342 | (if (get-buffer bzrmerge-warning-buffer) | |
343 | (kill-buffer bzrmerge-warning-buffer)) | |
9ebea0e7 SM |
344 | (message "Merging from %s..." from) |
345 | (require 'vc-bzr) | |
346 | (let ((default-directory (or (vc-bzr-root default-directory) | |
347 | (error "Not in a Bzr tree")))) | |
348 | ;; First, check the status. | |
349 | (let* ((merges (bzrmerge-merges)) | |
350 | ;; OK, we have the status, now check the missing data. | |
351 | (missing (bzrmerge-missing from merges))) | |
f6041baa GM |
352 | (if (not missing) |
353 | (message "Merging from %s...nothing to merge" from) | |
354 | (while missing | |
355 | (setq missing (bzrmerge-apply missing from))) | |
356 | (message "Merging from %s...done" from))))) | |
9ebea0e7 SM |
357 | |
358 | (provide 'bzrmerge) | |
359 | ;;; bzrmerge.el ends here |