1 ;;; bzrmerge.el --- help merge one Emacs bzr branch to another
3 ;; Copyright (C) 2010-2011 Free Software Foundation, Inc.
5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
8 ;; GNU Emacs is free software: you can redistribute it and/or modify
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.
13 ;; GNU Emacs is distributed in the hope that it will be useful,
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.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 ;; Some usage notes are in admin/notes/bzr.
28 (require 'cl
)) ; assert
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.")
35 (defconst bzrmerge-buffer
"*bzrmerge*"
36 "Working buffer for bzrmerge.")
38 (defun bzrmerge-merges ()
39 "Return the list of already merged (not yet committed) revisions.
40 The list returned is sorted by oldest-first."
41 (with-current-buffer (get-buffer-create bzrmerge-buffer
)
43 ;; We generally want to make sure we start with a clean tree, but we also
44 ;; want to allow restarts (i.e. with some part of FROM already merged but
45 ;; not yet committed).
46 (call-process "bzr" nil t nil
"status" "-v")
47 (goto-char (point-min))
48 (when (re-search-forward "^conflicts:\n" nil t
)
49 (error "You still have unresolved conflicts"))
51 (if (not (re-search-forward "^pending merges:\n" nil t
))
53 (goto-char (point-min))
54 (re-search-forward "^[a-z ]*:\n" nil t
))
55 (error "You still have uncommitted changes"))
56 ;; This is really stupid, but it seems there's no easy way to figure
57 ;; out which revisions have been merged already. The only info I can
58 ;; find is the "pending merges" from "bzr status -v", which is not
59 ;; very machine-friendly.
61 (skip-chars-forward " ")
62 (push (buffer-substring (point) (line-end-position)) merges
)
66 (defun bzrmerge-check-match (merge)
67 ;; Make sure the MERGES match the revisions on the FROM branch.
68 ;; Stupidly the best form of MERGES I can find is the one from
69 ;; "bzr status -v" which is very machine non-friendly, so I have
70 ;; to do some fuzzy matching.
74 (if (re-search-forward "^author: *\\([^<]*[^ ]\\) +<.*"
78 (if (re-search-forward
79 "^committer: *\\([^<]*[^< ]\\) +<" nil t
)
83 (if (re-search-forward
84 "^timestamp:[^0-9]*\\([-0-9]+\\)" nil t
)
88 (if (re-search-forward "^message:[ \n]*" nil t
)
89 (buffer-substring (point) (line-end-position))))))
90 ;; The `merge' may have a truncated line1 with "...", so get
91 ;; rid of any "..." and then look for a prefix match.
92 (when (string-match "\\.+\\'" merge
)
93 (setq merge
(substring merge
0 (match-beginning 0))))
95 merge
(concat author
" " timestamp
" " line1
))
97 merge
(concat author
" " timestamp
" [merge] " line1
)))))
99 (defun bzrmerge-missing (from merges
)
100 "Return the list of revisions that need to be merged.
101 MERGES is the revisions already merged but not yet committed.
102 Asks about skipping revisions with logs matching `bzrmerge-skip-regexp'.
103 The result is of the form (TOMERGE . TOSKIP) where TOMERGE and TOSKIP
104 are both lists of revnos, in oldest-first order."
105 (with-current-buffer (get-buffer-create bzrmerge-buffer
)
107 (call-process "bzr" nil t nil
"missing" "--theirs-only"
108 (expand-file-name from
))
109 (let ((revnos ()) (skipped ()))
110 (pop-to-buffer (current-buffer))
111 (goto-char (point-max))
112 (while (re-search-backward "^------------------------------------------------------------\nrevno: \\([0-9.]+\\).*" nil t
)
115 (while (not (bzrmerge-check-match (pop merges
)))
117 (error "Unmatched tip of merged revisions")))
118 (let ((case-fold-search t
)
119 (revno (match-string 1))
121 (if (string-match "\\." revno
)
122 (error "Unexpected dotted revno!")
123 (setq revno
(string-to-number revno
)))
124 (re-search-forward "^message:\n")
125 (while (and (not skip
)
126 (re-search-forward bzrmerge-skip-regexp nil t
))
127 (let ((str (buffer-substring (line-beginning-position)
128 (line-end-position))))
129 (when (string-match "\\` *" str
)
130 (setq str
(substring str
(match-end 0))))
131 (when (string-match "[.!;, ]+\\'" str
)
132 (setq str
(substring str
0 (match-beginning 0))))
133 (if (save-excursion (y-or-n-p (concat str
": Skip? ")))
137 (push revno revnos
)))))
138 (delete-region (point) (point-max)))
139 (and (or revnos skipped
)
140 (cons (nreverse revnos
) (nreverse skipped
))))))
142 (defun bzrmerge-resolve (file)
143 (unless (file-exists-p file
) (error "Bzrmerge-resolve: Can't find %s" file
))
145 (let ((exists (find-buffer-visiting file
)))
146 (with-current-buffer (find-file-noselect file
)
147 (if (buffer-modified-p)
148 (error "Unsaved changes in %s" (current-buffer)))
151 ((derived-mode-p 'change-log-mode
)
152 ;; Fix up dates before resolving the conflicts.
153 (goto-char (point-min))
154 (let ((diff-auto-refine-mode nil
))
155 (while (re-search-forward smerge-begin-re nil t
)
156 (smerge-match-conflict)
157 (smerge-ensure-match 3)
158 (let ((start1 (match-beginning 1))
160 (start3 (match-beginning 3))
161 (end3 (copy-marker (match-end 3) t
)))
163 (while (re-search-forward change-log-start-entry-re end3 t
)
164 (let* ((str (match-string 0))
165 (newstr (save-match-data
166 (concat (add-log-iso8601-time-string)
167 (when (string-match " *\\'" str
)
168 (match-string 0 str
))))))
169 (replace-match newstr t t
)))
170 ;; change-log-resolve-conflict prefers to put match-1's
171 ;; elements first (for equal dates), whereas we want to put
173 (let ((match3 (buffer-substring start3 end3
))
174 (match1 (buffer-substring start1 end1
)))
175 (delete-region start3 end3
)
178 (delete-region start1 end1
)
181 ;; (pop-to-buffer (current-buffer)) (debug 'before-resolve)
183 ;; Try to resolve the conflicts.
185 ((member file
'("configure" "lisp/ldefs-boot.el"
186 "lisp/emacs-lisp/cl-loaddefs.el"))
187 (call-process "bzr" nil t nil
"revert" file
)
188 (revert-buffer nil
'noconfirm
))
190 (goto-char (point-max))
191 (while (re-search-backward smerge-begin-re nil t
)
194 (smerge-match-conflict)
196 ;; (when (derived-mode-p 'change-log-mode)
197 ;; (pop-to-buffer (current-buffer)) (debug 'after-resolve))
199 (goto-char (point-min))
200 (prog1 (re-search-forward smerge-begin-re nil t
)
201 (unless exists
(kill-buffer))))))))
203 (defun bzrmerge-add-metadata (from endrevno
)
204 "Add the metadata for a merge of FROM upto ENDREVNO.
205 Does not make other difference."
206 (if (with-temp-buffer
207 (call-process "bzr" nil t nil
"status")
208 (goto-char (point-min))
209 (re-search-forward "^conflicts:\n" nil t
))
210 (error "Don't know how to add metadata in the presence of conflicts")
211 (call-process "bzr" nil t nil
"shelve" "--all"
212 "-m" "Bzrmerge shelved merge during skipping")
213 (call-process "bzr" nil t nil
"revert")
214 (call-process "bzr" nil t nil
215 "merge" "-r" (format "%s" endrevno
) from
)
216 (call-process "bzr" nil t nil
"revert" ".")
217 (call-process "bzr" nil t nil
"unshelve")))
219 (defvar bzrmerge-already-done nil
)
221 (defun bzrmerge-apply (missing from
)
222 (setq from
(expand-file-name from
))
223 (with-current-buffer (get-buffer-create bzrmerge-buffer
)
225 (when (equal (cdr bzrmerge-already-done
) (list from missing
))
226 (setq missing
(car bzrmerge-already-done
)))
227 (setq bzrmerge-already-done nil
)
228 (let ((merge (car missing
))
232 (when (or merge skip
)
234 ((and skip
(or (null merge
) (< (car skip
) (car merge
))))
235 ;; Do a "skip" (i.e. merge the meta-data only).
236 (setq beg
(1- (car skip
)))
237 (while (and skip
(or (null merge
) (< (car skip
) (car merge
))))
238 (assert (> (car skip
) (or end beg
)))
239 (setq end
(pop skip
)))
240 (message "Skipping %s..%s" beg end
)
241 (bzrmerge-add-metadata from end
))
244 ;; Do a "normal" merge.
245 (assert (or (null skip
) (< (car merge
) (car skip
))))
246 (setq beg
(1- (car merge
)))
247 (while (and merge
(or (null skip
) (< (car merge
) (car skip
))))
248 (assert (> (car merge
) (or end beg
)))
249 (setq end
(pop merge
)))
250 (message "Merging %s..%s" beg end
)
251 (if (with-temp-buffer
252 (call-process "bzr" nil t nil
"status")
253 (zerop (buffer-size)))
254 (call-process "bzr" nil t nil
255 "merge" "-r" (format "%s" end
) from
)
256 ;; Stupidly, "bzr merge --force -r A..B" dos not maintain the
257 ;; metadata properly except when the checkout is clean.
258 (call-process "bzr" nil t nil
"merge"
259 "--force" "-r" (format "%s..%s" beg end
) from
)
260 ;; The merge did not update the metadata, so force the next time
261 ;; around to update it (as a "skip").
264 (pop-to-buffer (current-buffer))
266 ;; (debug 'after-merge)
267 ;; Check the conflicts.
268 (let ((conflicted nil
)
270 (goto-char (point-min))
271 (when (re-search-forward "bzr: ERROR:" nil t
)
272 (error "Internal Bazaar error!!"))
273 (while (re-search-forward "^Text conflict in " nil t
)
274 (push (buffer-substring (point) (line-end-position)) files
))
275 (if (re-search-forward "^\\([0-9]+\\) conflicts encountered" nil t
)
276 (if (/= (length files
) (string-to-number (match-string 1)))
278 (if files
(setq conflicted t
)))
280 (if (bzrmerge-resolve file
)
281 (setq conflicted t
)))
283 (setq bzrmerge-already-done
284 (list (cons merge skip
) from missing
))
286 ;; FIXME: Obviously, we'd rather make it right rather
287 ;; than output such a warning. But I don't know how to add
288 ;; the metadata to bzr's since the technique used in
289 ;; bzrmerge-add-metadata does not work when there
291 (display-warning 'bzrmerge
"Resolve conflicts manually.
292 ¡BEWARE! Important metadata is kept in this Emacs session!
293 Do not commit without re-running `M-x bzrmerge' first!"))
294 (error "Resolve conflicts manually")))))
295 (cons merge skip
)))))
297 (defun bzrmerge (from)
298 "Merge from branch FROM into `default-directory'."
303 (call-process "bzr" nil t nil
"info")
304 (goto-char (point-min))
305 (when (re-search-forward "submit branch: *" nil t
)
306 (buffer-substring (point) (line-end-position))))))
307 (read-file-name "From branch: " nil nil nil def
))))
308 (message "Merging from %s..." from
)
310 (let ((default-directory (or (vc-bzr-root default-directory
)
311 (error "Not in a Bzr tree"))))
312 ;; First, check the status.
313 (let* ((merges (bzrmerge-merges))
314 ;; OK, we have the status, now check the missing data.
315 (missing (bzrmerge-missing from merges
)))
317 (message "Merging from %s...nothing to merge" from
)
319 (setq missing
(bzrmerge-apply missing from
)))
320 (message "Merging from %s...done" from
)))))
323 ;;; bzrmerge.el ends here