admin/bzrmerge.el

   1 ;;; bzrmerge.el ---
   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 ;;
  24
  25 ;;; Code:
  26
  27 (eval-when-compile
  28   (require 'cl))                        ; assert
  29
  30 (defun bzrmerge-merges ()
  31   "Return the list of already merged (not yet committed) revisions.
  32 The list returned is sorted by oldest-first."
  33   (with-current-buffer (get-buffer-create "*bzrmerge*")
  34     (erase-buffer)
  35     ;; We generally want to make sure we start with a clean tree, but we also
  36     ;; want to allow restarts (i.e. with some part of FROM already merged but
  37     ;; not yet committed).
  38     (call-process "bzr" nil t nil "status" "-v")
  39     (goto-char (point-min))
  40     (when (re-search-forward "^conflicts:\n" nil t)
  41       (error "You still have unresolved conflicts"))
  42     (let ((merges ()))
  43       (if (not (re-search-forward "^pending merges:\n" nil t))
  44           (when (save-excursion
  45                   (goto-char (point-min))
  46                   (re-search-forward "^[a-z ]*:\n" nil t))
  47             (error "You still have uncommitted changes"))
  48         ;; This is really stupid, but it seems there's no easy way to figure
  49         ;; out which revisions have been merged already.  The only info I can
  50         ;; find is the "pending merges" from "bzr status -v", which is not
  51         ;; very machine-friendly.
  52         (while (not (eobp))
  53           (skip-chars-forward " ")
  54           (push (buffer-substring (point) (line-end-position)) merges)
  55           (forward-line 1)))
  56       merges)))
  57
  58 (defun bzrmerge-check-match (merge)
  59   ;; Make sure the MERGES match the revisions on the FROM branch.
  60   ;; Stupidly the best form of MERGES I can find is the one from
  61   ;; "bzr status -v" which is very machine non-friendly, so I have
  62   ;; to do some fuzzy matching.
  63   (let ((author
  64          (or
  65           (save-excursion
  66             (if (re-search-forward "^author: *\\([^<]*[^ ]\\) +<.*"
  67                                    nil t)
  68                 (match-string 1)))
  69           (save-excursion
  70             (if (re-search-forward
  71                  "^committer: *\\([^<]*[^< ]\\) +<" nil t)
  72                 (match-string 1)))))
  73         (timestamp
  74          (save-excursion
  75            (if (re-search-forward
  76                 "^timestamp:[^0-9]*\\([-0-9]+\\)" nil t)
  77                (match-string 1))))
  78         (line1
  79          (save-excursion
  80            (if (re-search-forward "^message:[ \n]*" nil t)
  81                (buffer-substring (point) (line-end-position))))))
  82     ;; The `merge' may have a truncated line1 with "...", so get
  83     ;; rid of any "..." and then look for a prefix match.
  84     (when (string-match "\\.+\\'" merge)
  85       (setq merge (substring merge 0 (match-beginning 0))))
  86     (or (string-prefix-p
  87          merge (concat author " " timestamp " " line1))
  88         (string-prefix-p
  89          merge (concat author " " timestamp " [merge] " line1)))))
  90
  91 (defun bzrmerge-missing (from merges)
  92   "Return the list of revisions that need to be merged.
  93 MERGES is the revisions already merged but not yet committed.
  94 The result is of the form (TOMERGE . TOSKIP) where TOMERGE and TOSKIP
  95 are both lists of revnos, in oldest-first order."
  96   (with-current-buffer (get-buffer-create "*bzrmerge*")
  97     (erase-buffer)
  98     (call-process "bzr" nil t nil "missing" "--theirs-only"
  99                   (expand-file-name from))
 100     (let ((revnos ()) (skipped ()))
 101       (pop-to-buffer (current-buffer))
 102       (goto-char (point-max))
 103       (while (re-search-backward "^------------------------------------------------------------\nrevno: \\([0-9.]+\\).*" nil t)
 104         (save-excursion
 105           (if merges
 106               (while (not (bzrmerge-check-match (pop merges)))
 107                 (unless merges
 108                   (error "Unmatched tip of merged revisions")))
 109             (let ((case-fold-search t)
 110                   (revno (match-string 1))
 111                   (skip nil))
 112               (if (string-match "\\." revno)
 113                   (error "Unexpected dotted revno!")
 114                 (setq revno (string-to-number revno)))
 115               (re-search-forward "^message:\n")
 116               (while (and (not skip)
 117                           (re-search-forward
 118                            "back[- ]?port\\|merge\\|re-?generate\\|bump version" nil t))
 119                 (let ((str (buffer-substring (line-beginning-position)
 120                                              (line-end-position))))
 121                   (when (string-match "\\` *" str)
 122                     (setq str (substring str (match-end 0))))
 123                   (when (string-match "[.!;, ]+\\'" str)
 124                     (setq str (substring str 0 (match-beginning 0))))
 125                   (if (save-excursion (y-or-n-p (concat str ": Skip? ")))
 126                       (setq skip t))))
 127               (if skip
 128                   (push revno skipped)
 129                 (push revno revnos)))))
 130         (delete-region (point) (point-max)))
 131       (cons (nreverse revnos) (nreverse skipped)))))
 132
 133 (defun bzrmerge-resolve (file)
 134   (unless (file-exists-p file) (error "Bzrmerge-resolve: Can't find %s" file))
 135   (with-demoted-errors
 136     (let ((exists (find-buffer-visiting file)))
 137       (with-current-buffer (find-file-noselect file)
 138         (if (buffer-modified-p)
 139             (error "Unsaved changes in %s" (current-buffer)))
 140         (save-excursion
 141           (cond
 142            ((derived-mode-p 'change-log-mode)
 143             ;; Fix up dates before resolving the conflicts.
 144             (goto-char (point-min))
 145             (let ((diff-auto-refine-mode nil))
 146               (while (re-search-forward smerge-begin-re nil t)
 147                 (smerge-match-conflict)
 148                 (smerge-ensure-match 3)
 149                 (let ((start1 (match-beginning 1))
 150                       (end1 (match-end 1))
 151                       (start3 (match-beginning 3))
 152                       (end3 (copy-marker (match-end 3) t)))
 153                   (goto-char start3)
 154                   (while (re-search-forward change-log-start-entry-re end3 t)
 155                     (let* ((str (match-string 0))
 156                            (newstr (save-match-data
 157                                      (concat (add-log-iso8601-time-string)
 158                                              (when (string-match " *\\'" str)
 159                                                (match-string 0 str))))))
 160                       (replace-match newstr t t)))
 161                   ;; change-log-resolve-conflict prefers to put match-1's
 162                   ;; elements first (for equal dates), whereas we want to put
 163                   ;; match-3's first.
 164                   (let ((match3 (buffer-substring start3 end3))
 165                         (match1 (buffer-substring start1 end1)))
 166                     (delete-region start3 end3)
 167                     (goto-char start3)
 168                     (insert match1)
 169                     (delete-region start1 end1)
 170                     (goto-char start1)
 171                     (insert match3)))))
 172             ;; (pop-to-buffer (current-buffer)) (debug 'before-resolve)
 173             ))
 174           ;; Try to resolve the conflicts.
 175           (cond
 176            ((member file '("configure" "lisp/ldefs-boot.el"))
 177             (call-process "bzr" nil t nil "revert" file)
 178             (revert-buffer nil 'noconfirm))
 179            (t
 180             (goto-char (point-max))
 181             (while (re-search-backward smerge-begin-re nil t)
 182               (save-excursion
 183                 (ignore-errors
 184                   (smerge-match-conflict)
 185                   (smerge-resolve))))
 186             ;; (when (derived-mode-p 'change-log-mode)
 187             ;;   (pop-to-buffer (current-buffer)) (debug 'after-resolve))
 188             (save-buffer)))
 189           (goto-char (point-min))
 190           (prog1 (re-search-forward smerge-begin-re nil t)
 191             (unless exists (kill-buffer))))))))
 192
 193 (defun bzrmerge-add-metadata (from endrevno)
 194   "Add the metadata for a merge of FROM upto ENDREVNO.
 195 Does not make other difference."
 196   (if (with-temp-buffer
 197         (call-process "bzr" nil t nil "status")
 198         (goto-char (point-min))
 199         (re-search-forward "^conflicts:\n" nil t))
 200       (error "Don't know how to add metadata in the presence of conflicts")
 201     (call-process "bzr" nil t nil "shelve" "--all"
 202                   "-m" "Bzrmerge shelved merge during skipping")
 203     (call-process "bzr" nil t nil "revert")
 204     (call-process "bzr" nil t nil
 205                   "merge" "-r" (format "%s" endrevno) from)
 206     (call-process "bzr" nil t nil "revert" ".")
 207     (call-process "bzr" nil t nil "unshelve")))
 208
 209 (defvar bzrmerge-already-done nil)
 210
 211 (defun bzrmerge-apply (missing from)
 212   (setq from (expand-file-name from))
 213   (with-current-buffer (get-buffer-create "*bzrmerge*")
 214     (erase-buffer)
 215     (when (equal (cdr bzrmerge-already-done) (list from missing))
 216       (setq missing (car bzrmerge-already-done)))
 217     (setq bzrmerge-already-done nil)
 218     (let ((merge (car missing))
 219           (skip (cdr missing))
 220           beg end)
 221       (when (or merge skip)
 222         (cond
 223          ((and skip (or (null merge) (< (car skip) (car merge))))
 224           ;; Do a "skip" (i.e. merge the meta-data only).
 225           (setq beg (1- (car skip)))
 226           (while (and skip (or (null merge) (< (car skip) (car merge))))
 227             (assert (> (car skip) (or end beg)))
 228             (setq end (pop skip)))
 229           (message "Skipping %s..%s" beg end)
 230           (bzrmerge-add-metadata from end))
 231
 232          (t
 233           ;; Do a "normal" merge.
 234           (assert (or (null skip) (< (car merge) (car skip))))
 235           (setq beg (1- (car merge)))
 236           (while (and merge (or (null skip) (< (car merge) (car skip))))
 237             (assert (> (car merge) (or end beg)))
 238             (setq end (pop merge)))
 239           (message "Merging %s..%s" beg end)
 240           (if (with-temp-buffer
 241                 (call-process "bzr" nil t nil "status")
 242                 (zerop (buffer-size)))
 243               (call-process "bzr" nil t nil
 244                             "merge" "-r" (format "%s" end) from)
 245             ;; Stupidly, "bzr merge --force -r A..B" dos not maintain the
 246             ;; metadata properly except when the checkout is clean.
 247             (call-process "bzr" nil t nil "merge"
 248                           "--force" "-r" (format "%s..%s" beg end) from)
 249             ;; The merge did not update the metadata, so force the next time
 250             ;; around to update it (as a "skip").
 251             (push end skip))
 252           (pop-to-buffer (current-buffer))
 253           (sit-for 1)
 254           ;; (debug 'after-merge)
 255           ;; Check the conflicts.
 256           (let ((conflicted nil)
 257                 (files ()))
 258             (goto-char (point-min))
 259             (when (re-search-forward "bzr: ERROR:" nil t)
 260               (error "Internal Bazaar error!!"))
 261             (while (re-search-forward "^Text conflict in " nil t)
 262               (push (buffer-substring (point) (line-end-position)) files))
 263             (if (re-search-forward "^\\([0-9]+\\) conflicts encountered" nil t)
 264                 (if (/= (length files) (string-to-number (match-string 1)))
 265                     (setq conflicted t))
 266               (if files (setq conflicted t)))
 267             (dolist (file files)
 268               (if (bzrmerge-resolve file)
 269                   (setq conflicted t)))
 270             (when conflicted
 271               (setq bzrmerge-already-done
 272                     (list (cons merge skip) from missing))
 273               (error "Resolve conflicts manually")))))
 274         (cons merge skip)))))
 275
 276 (defun bzrmerge (from)
 277   "Merge from branch FROM into `default-directory'."
 278   (interactive
 279    (list
 280     (let ((def
 281            (with-temp-buffer
 282              (call-process "bzr" nil t nil "info")
 283              (goto-char (point-min))
 284              (when (re-search-forward "submit branch: *" nil t)
 285                (buffer-substring (point) (line-end-position))))))
 286       (read-file-name "From branch: " nil nil nil def))))
 287   (message "Merging from %s..." from)
 288   (require 'vc-bzr)
 289   (let ((default-directory (or (vc-bzr-root default-directory)
 290                                (error "Not in a Bzr tree"))))
 291     ;; First, check the status.
 292     (let* ((merges (bzrmerge-merges))
 293            ;; OK, we have the status, now check the missing data.
 294            (missing (bzrmerge-missing from merges)))
 295       (while missing
 296         (setq missing (bzrmerge-apply missing from))))))
 297
 298 (provide 'bzrmerge)
 299 ;;; bzrmerge.el ends here