bzrmerge.el 15.7 KB
Newer Older
Glenn Morris's avatar
Glenn Morris committed
1
;;; bzrmerge.el --- help merge one Emacs bzr branch to another
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 2010-2015 Free Software Foundation, Inc.
4 5

;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
6
;; Keywords: maint
7

8
;; GNU Emacs is free software: you can redistribute it and/or modify
9 10 11 12
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

13
;; GNU Emacs is distributed in the hope that it will be useful,
14 15 16 17 18
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; 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/>.
20 21 22

;;; Commentary:

Glenn Morris's avatar
Glenn Morris committed
23
;; Some usage notes are in admin/notes/bzr.
24 25 26

;;; Code:

Stefan Monnier's avatar
Stefan Monnier committed
27
(eval-when-compile (require 'cl-lib))
28

29
(defvar bzrmerge-skip-regexp
30 31
  "back[- ]?port\\|merge\\|sync\\|re-?generate\\|bump version\\|from trunk\\|\
Auto-commit"
32 33 34
  "Regexp matching logs of revisions that might be skipped.
`bzrmerge-missing' will ask you if it should skip any matches.")

Glenn Morris's avatar
Glenn Morris committed
35 36 37
(defconst bzrmerge-buffer "*bzrmerge*"
  "Working buffer for bzrmerge.")

Glenn Morris's avatar
Glenn Morris committed
38 39 40
(defconst bzrmerge-warning-buffer "*bzrmerge warnings*"
  "Buffer where bzrmerge will display any warnings.")

41
(defun bzrmerge-merges ()
42
  "Return the list of already merged (not yet committed) revisions.
43
The list returned is sorted by oldest-first."
Glenn Morris's avatar
Glenn Morris committed
44
  (with-current-buffer (get-buffer-create bzrmerge-buffer)
45 46 47
    (erase-buffer)
    ;; We generally want to make sure we start with a clean tree, but we also
    ;; want to allow restarts (i.e. with some part of FROM already merged but
48 49
    ;; not yet committed).  Unversioned (unknown) files in the tree
    ;; are also ok.
50 51 52
    (call-process "bzr" nil t nil "status" "-v")
    (goto-char (point-min))
    (when (re-search-forward "^conflicts:\n" nil t)
Stefan Monnier's avatar
Stefan Monnier committed
53
      (user-error "You still have unresolved conflicts"))
54 55
    (let ((merges ())
          found)
56 57 58
      (if (not (re-search-forward "^pending merges:\n" nil t))
          (when (save-excursion
                  (goto-char (point-min))
59 60 61 62 63 64
                  (while (and
                          (re-search-forward "^\\([a-z ]*\\):\n" nil t)
                          (not
                           (setq found
                                 (not (equal "unknown" (match-string 1)))))))
                  found)
Stefan Monnier's avatar
Stefan Monnier committed
65
            (user-error "You still have uncommitted changes"))
66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111
        ;; This is really stupid, but it seems there's no easy way to figure
        ;; out which revisions have been merged already.  The only info I can
        ;; find is the "pending merges" from "bzr status -v", which is not
        ;; very machine-friendly.
        (while (not (eobp))
          (skip-chars-forward " ")
          (push (buffer-substring (point) (line-end-position)) merges)
          (forward-line 1)))
      merges)))

(defun bzrmerge-check-match (merge)
  ;; Make sure the MERGES match the revisions on the FROM branch.
  ;; Stupidly the best form of MERGES I can find is the one from
  ;; "bzr status -v" which is very machine non-friendly, so I have
  ;; to do some fuzzy matching.
  (let ((author
         (or
          (save-excursion
            (if (re-search-forward "^author: *\\([^<]*[^ ]\\) +<.*"
                                   nil t)
                (match-string 1)))
          (save-excursion
            (if (re-search-forward
                 "^committer: *\\([^<]*[^< ]\\) +<" nil t)
                (match-string 1)))))
        (timestamp
         (save-excursion
           (if (re-search-forward
                "^timestamp:[^0-9]*\\([-0-9]+\\)" nil t)
               (match-string 1))))
        (line1
         (save-excursion
           (if (re-search-forward "^message:[ \n]*" nil t)
               (buffer-substring (point) (line-end-position))))))
    ;; The `merge' may have a truncated line1 with "...", so get
    ;; rid of any "..." and then look for a prefix match.
    (when (string-match "\\.+\\'" merge)
      (setq merge (substring merge 0 (match-beginning 0))))
    (or (string-prefix-p
         merge (concat author " " timestamp " " line1))
        (string-prefix-p
         merge (concat author " " timestamp " [merge] " line1)))))

(defun bzrmerge-missing (from merges)
  "Return the list of revisions that need to be merged.
MERGES is the revisions already merged but not yet committed.
112
Asks about skipping revisions with logs matching `bzrmerge-skip-regexp'.
113 114
The result is of the form (TOMERGE . TOSKIP) where TOMERGE and TOSKIP
are both lists of revnos, in oldest-first order."
Glenn Morris's avatar
Glenn Morris committed
115
  (with-current-buffer (get-buffer-create bzrmerge-buffer)
116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135
    (erase-buffer)
    (call-process "bzr" nil t nil "missing" "--theirs-only"
                  (expand-file-name from))
    (let ((revnos ()) (skipped ()))
      (pop-to-buffer (current-buffer))
      (goto-char (point-max))
      (while (re-search-backward "^------------------------------------------------------------\nrevno: \\([0-9.]+\\).*" nil t)
        (save-excursion
          (if merges
              (while (not (bzrmerge-check-match (pop merges)))
                (unless merges
                  (error "Unmatched tip of merged revisions")))
            (let ((case-fold-search t)
                  (revno (match-string 1))
                  (skip nil))
              (if (string-match "\\." revno)
                  (error "Unexpected dotted revno!")
                (setq revno (string-to-number revno)))
              (re-search-forward "^message:\n")
              (while (and (not skip)
136
                          (re-search-forward bzrmerge-skip-regexp nil t))
137 138 139 140 141 142
                (let ((str (buffer-substring (line-beginning-position)
                                             (line-end-position))))
                  (when (string-match "\\` *" str)
                    (setq str (substring str (match-end 0))))
                  (when (string-match "[.!;, ]+\\'" str)
                    (setq str (substring str 0 (match-beginning 0))))
Glenn Morris's avatar
Glenn Morris committed
143 144 145 146 147
                  (let ((help-form "\
Type `y' to skip this revision,
`N' to include it and go on to the next revision,
`n' to not skip, but continue to search this log entry for skip regexps,
`q' to quit merging."))
Stefan Monnier's avatar
Stefan Monnier committed
148
                    (pcase (save-excursion
Glenn Morris's avatar
Glenn Morris committed
149 150 151 152
                            (read-char-choice
                             (format "%s: Skip (y/n/N/q/%s)? " str
                                     (key-description (vector help-char)))
                             '(?y ?n ?N ?q)))
Stefan Monnier's avatar
Stefan Monnier committed
153 154
                      (`?y (setq skip t))
                      (`?q (keyboard-quit))
Glenn Morris's avatar
Glenn Morris committed
155 156 157
                      ;; A single log entry can match skip-regexp multiple
                      ;; times.  If you are sure you don't want to skip it,
                      ;; you don't want to be asked multiple times.
Stefan Monnier's avatar
Stefan Monnier committed
158
                      (`?N (setq skip 'no))))))
Glenn Morris's avatar
Glenn Morris committed
159
              (if (eq skip t)
160 161 162
                  (push revno skipped)
                (push revno revnos)))))
        (delete-region (point) (point-max)))
Glenn Morris's avatar
Glenn Morris committed
163 164
      (and (or revnos skipped)
           (cons (nreverse revnos) (nreverse skipped))))))
165 166 167 168 169

(defun bzrmerge-resolve (file)
  (unless (file-exists-p file) (error "Bzrmerge-resolve: Can't find %s" file))
  (with-demoted-errors
    (let ((exists (find-buffer-visiting file)))
170 171
      (with-current-buffer (let ((enable-local-variables :safe)
                                 (enable-local-eval nil))
172
                             (find-file-noselect file))
173
        (if (buffer-modified-p)
Stefan Monnier's avatar
Stefan Monnier committed
174
            (user-error "Unsaved changes in %s" (current-buffer)))
175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210
        (save-excursion
          (cond
           ((derived-mode-p 'change-log-mode)
            ;; Fix up dates before resolving the conflicts.
            (goto-char (point-min))
            (let ((diff-auto-refine-mode nil))
              (while (re-search-forward smerge-begin-re nil t)
                (smerge-match-conflict)
                (smerge-ensure-match 3)
                (let ((start1 (match-beginning 1))
                      (end1 (match-end 1))
                      (start3 (match-beginning 3))
                      (end3 (copy-marker (match-end 3) t)))
                  (goto-char start3)
                  (while (re-search-forward change-log-start-entry-re end3 t)
                    (let* ((str (match-string 0))
                           (newstr (save-match-data
                                     (concat (add-log-iso8601-time-string)
                                             (when (string-match " *\\'" str)
                                               (match-string 0 str))))))
                      (replace-match newstr t t)))
                  ;; change-log-resolve-conflict prefers to put match-1's
                  ;; elements first (for equal dates), whereas we want to put
                  ;; match-3's first.
                  (let ((match3 (buffer-substring start3 end3))
                        (match1 (buffer-substring start1 end1)))
                    (delete-region start3 end3)
                    (goto-char start3)
                    (insert match1)
                    (delete-region start1 end1)
                    (goto-char start1)
                    (insert match3)))))
            ;; (pop-to-buffer (current-buffer)) (debug 'before-resolve)
            ))
          ;; Try to resolve the conflicts.
          (cond
Glenn Morris's avatar
Glenn Morris committed
211 212
           ((member file '("configure" "lisp/ldefs-boot.el"
                           "lisp/emacs-lisp/cl-loaddefs.el"))
213 214 215
            ;; We are in the file's buffer, so names are relative.
            (call-process "bzr" nil t nil "revert"
                          (file-name-nondirectory file))
216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245
            (revert-buffer nil 'noconfirm))
           (t
            (goto-char (point-max))
            (while (re-search-backward smerge-begin-re nil t)
              (save-excursion
                (ignore-errors
                  (smerge-match-conflict)
                  (smerge-resolve))))
            ;; (when (derived-mode-p 'change-log-mode)
            ;;   (pop-to-buffer (current-buffer)) (debug 'after-resolve))
            (save-buffer)))
          (goto-char (point-min))
          (prog1 (re-search-forward smerge-begin-re nil t)
            (unless exists (kill-buffer))))))))

(defun bzrmerge-add-metadata (from endrevno)
  "Add the metadata for a merge of FROM upto ENDREVNO.
Does not make other difference."
  (if (with-temp-buffer
        (call-process "bzr" nil t nil "status")
        (goto-char (point-min))
        (re-search-forward "^conflicts:\n" nil t))
      (error "Don't know how to add metadata in the presence of conflicts")
    (call-process "bzr" nil t nil "shelve" "--all"
                  "-m" "Bzrmerge shelved merge during skipping")
    (call-process "bzr" nil t nil "revert")
    (call-process "bzr" nil t nil
                  "merge" "-r" (format "%s" endrevno) from)
    (call-process "bzr" nil t nil "revert" ".")
    (call-process "bzr" nil t nil "unshelve")))
246

247 248 249 250
(defvar bzrmerge-already-done nil)

(defun bzrmerge-apply (missing from)
  (setq from (expand-file-name from))
Glenn Morris's avatar
Glenn Morris committed
251
  (with-current-buffer (get-buffer-create bzrmerge-buffer)
252 253 254 255 256 257
    (erase-buffer)
    (when (equal (cdr bzrmerge-already-done) (list from missing))
      (setq missing (car bzrmerge-already-done)))
    (setq bzrmerge-already-done nil)
    (let ((merge (car missing))
          (skip (cdr missing))
258
          (unsafe nil)
259 260 261 262 263 264 265
          beg end)
      (when (or merge skip)
        (cond
         ((and skip (or (null merge) (< (car skip) (car merge))))
          ;; Do a "skip" (i.e. merge the meta-data only).
          (setq beg (1- (car skip)))
          (while (and skip (or (null merge) (< (car skip) (car merge))))
Stefan Monnier's avatar
Stefan Monnier committed
266
            (cl-assert (> (car skip) (or end beg)))
267 268 269 270 271 272
            (setq end (pop skip)))
          (message "Skipping %s..%s" beg end)
          (bzrmerge-add-metadata from end))

         (t
          ;; Do a "normal" merge.
Stefan Monnier's avatar
Stefan Monnier committed
273
          (cl-assert (or (null skip) (< (car merge) (car skip))))
274 275
          (setq beg (1- (car merge)))
          (while (and merge (or (null skip) (< (car merge) (car skip))))
Stefan Monnier's avatar
Stefan Monnier committed
276
            (cl-assert (> (car merge) (or end beg)))
277 278 279 280 281 282 283 284 285 286 287 288 289
            (setq end (pop merge)))
          (message "Merging %s..%s" beg end)
          (if (with-temp-buffer
                (call-process "bzr" nil t nil "status")
                (zerop (buffer-size)))
              (call-process "bzr" nil t nil
                            "merge" "-r" (format "%s" end) from)
            ;; Stupidly, "bzr merge --force -r A..B" dos not maintain the
            ;; metadata properly except when the checkout is clean.
            (call-process "bzr" nil t nil "merge"
                          "--force" "-r" (format "%s..%s" beg end) from)
            ;; The merge did not update the metadata, so force the next time
            ;; around to update it (as a "skip").
290
            (setq unsafe t)
291 292 293 294 295
            (push end skip))
          (pop-to-buffer (current-buffer))
          (sit-for 1)
          ;; (debug 'after-merge)
          ;; Check the conflicts.
296 297 298
          ;; FIXME if using the helpful bzr changelog_merge plugin,
          ;; there are normally no conflicts in ChangeLogs.
          ;; But we still want the dates fixing, like bzrmerge-resolve does.
299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315
          (let ((conflicted nil)
                (files ()))
            (goto-char (point-min))
            (when (re-search-forward "bzr: ERROR:" nil t)
              (error "Internal Bazaar error!!"))
            (while (re-search-forward "^Text conflict in " nil t)
              (push (buffer-substring (point) (line-end-position)) files))
            (if (re-search-forward "^\\([0-9]+\\) conflicts encountered" nil t)
                (if (/= (length files) (string-to-number (match-string 1)))
                    (setq conflicted t))
              (if files (setq conflicted t)))
            (dolist (file files)
              (if (bzrmerge-resolve file)
                  (setq conflicted t)))
            (when conflicted
              (setq bzrmerge-already-done
                    (list (cons merge skip) from missing))
316 317 318 319 320 321 322
              (if unsafe
                  ;; FIXME: Obviously, we'd rather make it right rather
                  ;; than output such a warning.  But I don't know how to add
                  ;; the metadata to bzr's since the technique used in
                  ;; bzrmerge-add-metadata does not work when there
                  ;; are conflicts.
                  (display-warning 'bzrmerge "Resolve conflicts manually.
323
BEWARE!  Important metadata is kept in this Emacs session!
Glenn Morris's avatar
Glenn Morris committed
324 325
Do not commit without re-running `M-x bzrmerge' first!"
                                   :warning bzrmerge-warning-buffer))
Stefan Monnier's avatar
Stefan Monnier committed
326
              (user-error "Resolve conflicts manually")))))
327 328 329 330 331 332 333 334 335 336 337 338 339
        (cons merge skip)))))

(defun bzrmerge (from)
  "Merge from branch FROM into `default-directory'."
  (interactive
   (list
    (let ((def
           (with-temp-buffer
             (call-process "bzr" nil t nil "info")
             (goto-char (point-min))
             (when (re-search-forward "submit branch: *" nil t)
               (buffer-substring (point) (line-end-position))))))
      (read-file-name "From branch: " nil nil nil def))))
Glenn Morris's avatar
Glenn Morris committed
340 341 342 343
  ;; Eg we ran bzrmerge once, it stopped with conflicts, we fixed them
  ;; and are running it again.
  (if (get-buffer bzrmerge-warning-buffer)
      (kill-buffer bzrmerge-warning-buffer))
344 345 346 347 348 349 350 351
  (message "Merging from %s..." from)
  (require 'vc-bzr)
  (let ((default-directory (or (vc-bzr-root default-directory)
                               (error "Not in a Bzr tree"))))
    ;; First, check the status.
    (let* ((merges (bzrmerge-merges))
           ;; OK, we have the status, now check the missing data.
           (missing (bzrmerge-missing from merges)))
Glenn Morris's avatar
Glenn Morris committed
352 353 354 355 356
      (if (not missing)
          (message "Merging from %s...nothing to merge" from)
        (while missing
          (setq missing (bzrmerge-apply missing from)))
        (message "Merging from %s...done" from)))))
357 358 359

(provide 'bzrmerge)
;;; bzrmerge.el ends here