admin/bzrmerge.el

   1 ;;; bzrmerge.el --- help merge one Emacs bzr branch to another
   2
   3 ;; Copyright (C) 2010-2011  Free Software Foundation, Inc.
   4
   5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
   6 ;; Keywords:
   7
   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.
  12
  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.
  17
  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/>.
  20
  21 ;;; Commentary:
  22
  23 ;; Some usage notes are in admin/notes/bzr.
  24
  25 ;;; Code:
  26
  27 (eval-when-compile
  28   (require 'cl))                        ; assert
  29
  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
  35 (defconst bzrmerge-buffer "*bzrmerge*"
  36   "Working buffer for bzrmerge.")
  37
  38 (defconst bzrmerge-warning-buffer "*bzrmerge warnings*"
  39   "Buffer where bzrmerge will display any warnings.")
  40
  41 (defun bzrmerge-merges ()
  42   "Return the list of already merged (not yet committed) revisions.
  43 The list returned is sorted by oldest-first."
  44   (with-current-buffer (get-buffer-create bzrmerge-buffer)
  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.
 105 Asks about skipping revisions with logs matching `bzrmerge-skip-regexp'.
 106 The result is of the form (TOMERGE . TOSKIP) where TOMERGE and TOSKIP
 107 are both lists of revnos, in oldest-first order."
 108   (with-current-buffer (get-buffer-create bzrmerge-buffer)
 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)
 129                           (re-search-forward bzrmerge-skip-regexp nil t))
 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)))
 142       (and (or revnos skipped)
 143            (cons (nreverse revnos) (nreverse skipped))))))
 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 (let ((enable-local-variables :safe))
 150                              (find-file-noselect file))
 151         (if (buffer-modified-p)
 152             (error "Unsaved changes in %s" (current-buffer)))
 153         (save-excursion
 154           (cond
 155            ((derived-mode-p 'change-log-mode)
 156             ;; Fix up dates before resolving the conflicts.
 157             (goto-char (point-min))
 158             (let ((diff-auto-refine-mode nil))
 159               (while (re-search-forward smerge-begin-re nil t)
 160                 (smerge-match-conflict)
 161                 (smerge-ensure-match 3)
 162                 (let ((start1 (match-beginning 1))
 163                       (end1 (match-end 1))
 164                       (start3 (match-beginning 3))
 165                       (end3 (copy-marker (match-end 3) t)))
 166                   (goto-char start3)
 167                   (while (re-search-forward change-log-start-entry-re end3 t)
 168                     (let* ((str (match-string 0))
 169                            (newstr (save-match-data
 170                                      (concat (add-log-iso8601-time-string)
 171                                              (when (string-match " *\\'" str)
 172                                                (match-string 0 str))))))
 173                       (replace-match newstr t t)))
 174                   ;; change-log-resolve-conflict prefers to put match-1's
 175                   ;; elements first (for equal dates), whereas we want to put
 176                   ;; match-3's first.
 177                   (let ((match3 (buffer-substring start3 end3))
 178                         (match1 (buffer-substring start1 end1)))
 179                     (delete-region start3 end3)
 180                     (goto-char start3)
 181                     (insert match1)
 182                     (delete-region start1 end1)
 183                     (goto-char start1)
 184                     (insert match3)))))
 185             ;; (pop-to-buffer (current-buffer)) (debug 'before-resolve)
 186             ))
 187           ;; Try to resolve the conflicts.
 188           (cond
 189            ((member file '("configure" "lisp/ldefs-boot.el"
 190                            "lisp/emacs-lisp/cl-loaddefs.el"))
 191             ;; We are in the file's buffer, so names are relative.
 192             (call-process "bzr" nil t nil "revert"
 193                           (file-name-nondirectory file))
 194             (revert-buffer nil 'noconfirm))
 195            (t
 196             (goto-char (point-max))
 197             (while (re-search-backward smerge-begin-re nil t)
 198               (save-excursion
 199                 (ignore-errors
 200                   (smerge-match-conflict)
 201                   (smerge-resolve))))
 202             ;; (when (derived-mode-p 'change-log-mode)
 203             ;;   (pop-to-buffer (current-buffer)) (debug 'after-resolve))
 204             (save-buffer)))
 205           (goto-char (point-min))
 206           (prog1 (re-search-forward smerge-begin-re nil t)
 207             (unless exists (kill-buffer))))))))
 208
 209 (defun bzrmerge-add-metadata (from endrevno)
 210   "Add the metadata for a merge of FROM upto ENDREVNO.
 211 Does not make other difference."
 212   (if (with-temp-buffer
 213         (call-process "bzr" nil t nil "status")
 214         (goto-char (point-min))
 215         (re-search-forward "^conflicts:\n" nil t))
 216       (error "Don't know how to add metadata in the presence of conflicts")
 217     (call-process "bzr" nil t nil "shelve" "--all"
 218                   "-m" "Bzrmerge shelved merge during skipping")
 219     (call-process "bzr" nil t nil "revert")
 220     (call-process "bzr" nil t nil
 221                   "merge" "-r" (format "%s" endrevno) from)
 222     (call-process "bzr" nil t nil "revert" ".")
 223     (call-process "bzr" nil t nil "unshelve")))
 224
 225 (defvar bzrmerge-already-done nil)
 226
 227 (defun bzrmerge-apply (missing from)
 228   (setq from (expand-file-name from))
 229   (with-current-buffer (get-buffer-create bzrmerge-buffer)
 230     (erase-buffer)
 231     (when (equal (cdr bzrmerge-already-done) (list from missing))
 232       (setq missing (car bzrmerge-already-done)))
 233     (setq bzrmerge-already-done nil)
 234     (let ((merge (car missing))
 235           (skip (cdr missing))
 236           (unsafe nil)
 237           beg end)
 238       (when (or merge skip)
 239         (cond
 240          ((and skip (or (null merge) (< (car skip) (car merge))))
 241           ;; Do a "skip" (i.e. merge the meta-data only).
 242           (setq beg (1- (car skip)))
 243           (while (and skip (or (null merge) (< (car skip) (car merge))))
 244             (assert (> (car skip) (or end beg)))
 245             (setq end (pop skip)))
 246           (message "Skipping %s..%s" beg end)
 247           (bzrmerge-add-metadata from end))
 248
 249          (t
 250           ;; Do a "normal" merge.
 251           (assert (or (null skip) (< (car merge) (car skip))))
 252           (setq beg (1- (car merge)))
 253           (while (and merge (or (null skip) (< (car merge) (car skip))))
 254             (assert (> (car merge) (or end beg)))
 255             (setq end (pop merge)))
 256           (message "Merging %s..%s" beg end)
 257           (if (with-temp-buffer
 258                 (call-process "bzr" nil t nil "status")
 259                 (zerop (buffer-size)))
 260               (call-process "bzr" nil t nil
 261                             "merge" "-r" (format "%s" end) from)
 262             ;; Stupidly, "bzr merge --force -r A..B" dos not maintain the
 263             ;; metadata properly except when the checkout is clean.
 264             (call-process "bzr" nil t nil "merge"
 265                           "--force" "-r" (format "%s..%s" beg end) from)
 266             ;; The merge did not update the metadata, so force the next time
 267             ;; around to update it (as a "skip").
 268             (setq unsafe t)
 269             (push end skip))
 270           (pop-to-buffer (current-buffer))
 271           (sit-for 1)
 272           ;; (debug 'after-merge)
 273           ;; Check the conflicts.
 274           ;; FIXME if using the helpful bzr changelog_merge plugin,
 275           ;; there are normally no conflicts in ChangeLogs.
 276           ;; But we still want the dates fixing, like bzrmerge-resolve does.
 277           (let ((conflicted nil)
 278                 (files ()))
 279             (goto-char (point-min))
 280             (when (re-search-forward "bzr: ERROR:" nil t)
 281               (error "Internal Bazaar error!!"))
 282             (while (re-search-forward "^Text conflict in " nil t)
 283               (push (buffer-substring (point) (line-end-position)) files))
 284             (if (re-search-forward "^\\([0-9]+\\) conflicts encountered" nil t)
 285                 (if (/= (length files) (string-to-number (match-string 1)))
 286                     (setq conflicted t))
 287               (if files (setq conflicted t)))
 288             (dolist (file files)
 289               (if (bzrmerge-resolve file)
 290                   (setq conflicted t)))
 291             (when conflicted
 292               (setq bzrmerge-already-done
 293                     (list (cons merge skip) from missing))
 294               (if unsafe
 295                   ;; FIXME: Obviously, we'd rather make it right rather
 296                   ;; than output such a warning.  But I don't know how to add
 297                   ;; the metadata to bzr's since the technique used in
 298                   ;; bzrmerge-add-metadata does not work when there
 299                   ;; are conflicts.
 300                   (display-warning 'bzrmerge "Resolve conflicts manually.
 301 ¡BEWARE!  Important metadata is kept in this Emacs session!
 302 Do not commit without re-running `M-x bzrmerge' first!"
 303                                    :warning bzrmerge-warning-buffer))
 304               (error "Resolve conflicts manually")))))
 305         (cons merge skip)))))
 306
 307 (defun bzrmerge (from)
 308   "Merge from branch FROM into `default-directory'."
 309   (interactive
 310    (list
 311     (let ((def
 312            (with-temp-buffer
 313              (call-process "bzr" nil t nil "info")
 314              (goto-char (point-min))
 315              (when (re-search-forward "submit branch: *" nil t)
 316                (buffer-substring (point) (line-end-position))))))
 317       (read-file-name "From branch: " nil nil nil def))))
 318   ;; Eg we ran bzrmerge once, it stopped with conflicts, we fixed them
 319   ;; and are running it again.
 320   (if (get-buffer bzrmerge-warning-buffer)
 321       (kill-buffer bzrmerge-warning-buffer))
 322   (message "Merging from %s..." from)
 323   (require 'vc-bzr)
 324   (let ((default-directory (or (vc-bzr-root default-directory)
 325                                (error "Not in a Bzr tree"))))
 326     ;; First, check the status.
 327     (let* ((merges (bzrmerge-merges))
 328            ;; OK, we have the status, now check the missing data.
 329            (missing (bzrmerge-missing from merges)))
 330       (if (not missing)
 331           (message "Merging from %s...nothing to merge" from)
 332         (while missing
 333           (setq missing (bzrmerge-apply missing from)))
 334         (message "Merging from %s...done" from)))))
 335
 336 (provide 'bzrmerge)
 337 ;;; bzrmerge.el ends here