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/>.
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*")
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"))
40 (if (not (re-search-forward "^pending merges:\n" nil t
))
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.
50 (skip-chars-forward " ")
51 (push (buffer-substring (point) (line-end-position)) merges
)
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.
63 (if (re-search-forward "^author: *\\([^<]*[^ ]\\) +<.*"
67 (if (re-search-forward
68 "^committer: *\\([^<]*[^< ]\\) +<" nil t
)
72 (if (re-search-forward
73 "^timestamp:[^0-9]*\\([-0-9]+\\)" nil t
)
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))))
84 merge
(concat author
" " timestamp
" " line1
))
86 merge
(concat author
" " timestamp
" [merge] " line1
)))))
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*")
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
)
103 (while (not (bzrmerge-check-match (pop merges
)))
105 (error "Unmatched tip of merged revisions")))
106 (let ((case-fold-search t
)
107 (revno (match-string 1))
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
)
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? ")))
126 (push revno revnos
)))))
127 (delete-region (point) (point-max)))
128 (cons (nreverse revnos
) (nreverse skipped
)))))
130 (defun bzrmerge-resolve (file)
131 (unless (file-exists-p file
) (error "Bzrmerge-resolve: Can't find %s" file
))
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)))
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))
148 (start3 (match-beginning 3))
149 (end3 (copy-marker (match-end 3) t
)))
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
161 (let ((match3 (buffer-substring start3 end3
))
162 (match1 (buffer-substring start1 end1
)))
163 (delete-region start3 end3
)
166 (delete-region start1 end1
)
169 ;; (pop-to-buffer (current-buffer)) (debug 'before-resolve)
171 ;; Try to resolve the conflicts.
173 ((member file
'("configure" "lisp/ldefs-boot.el"))
174 (call-process "bzr" nil t nil
"revert" file
)
175 (revert-buffer nil
'noconfirm
))
177 (goto-char (point-max))
178 (while (re-search-backward smerge-begin-re nil t
)
181 (smerge-match-conflict)
183 ;; (when (derived-mode-p 'change-log-mode)
184 ;; (pop-to-buffer (current-buffer)) (debug 'after-resolve))
186 (goto-char (point-min))
187 (prog1 (re-search-forward smerge-begin-re nil t
)
188 (unless exists
(kill-buffer))))))))
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")))
206 (defvar bzrmerge-already-done nil
)
208 (defun bzrmerge-apply (missing from
)
209 (setq from
(expand-file-name from
))
210 (with-current-buffer (get-buffer-create "*bzrmerge*")
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
))
218 (when (or merge skip
)
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
))
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").
249 (pop-to-buffer (current-buffer))
251 ;; (debug 'after-merge)
252 ;; Check the conflicts.
253 (let ((conflicted nil
)
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)))
263 (if files
(setq conflicted t
)))
265 (if (bzrmerge-resolve file
)
266 (setq conflicted t
)))
268 (setq bzrmerge-already-done
269 (list (cons merge skip
) from missing
))
270 (error "Resolve conflicts manually")))))
271 (cons merge skip
)))))
273 (defun bzrmerge (from)
274 "Merge from branch FROM into `default-directory'."
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
)
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
)))
293 (setq missing
(bzrmerge-apply missing from
))))))
296 ;;; bzrmerge.el ends here