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 (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*")
  31     (erase-buffer)
  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"))
  39     (let ((merges ()))
  40       (if (not (re-search-forward "^pending merges:\n" nil t))
  41           (when (save-excursion
  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.
  49         (while (not (eobp))
  50           (skip-chars-forward " ")
  51           (push (buffer-substring (point) (line-end-position)) merges)
  52           (forward-line 1)))
  53       merges)))
  54
  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.
  60   (let ((author
  61          (or
  62           (save-excursion
  63             (if (re-search-forward "^author: *\\([^<]*[^ ]\\) +<.*"
  64                                    nil t)
  65                 (match-string 1)))
  66           (save-excursion
  67             (if (re-search-forward
  68                  "^committer: *\\([^<]*[^< ]\\) +<" nil t)
  69                 (match-string 1)))))
  70         (timestamp
  71          (save-excursion
  72            (if (re-search-forward
  73                 "^timestamp:[^0-9]*\\([-0-9]+\\)" nil t)
  74                (match-string 1))))
  75         (line1
  76          (save-excursion
  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))))
  83     (or (string-prefix-p
  84          merge (concat author " " timestamp " " line1))
  85         (string-prefix-p
  86          merge (concat author " " timestamp " [merge] " line1)))))
  87
  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*")
  94     (erase-buffer)
  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)
 101         (save-excursion
 102           (if merges
 103               (while (not (bzrmerge-check-match (pop merges)))
 104                 (unless merges
 105                   (error "Unmatched tip of merged revisions")))
 106             (let ((case-fold-search t)
 107                   (revno (match-string 1))
 108                   (skip nil))
 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)
 114                           (re-search-forward
 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? ")))
 123                       (setq skip t))))
 124               (if skip
 125                   (push revno skipped)
 126                 (push revno revnos)))))
 127         (delete-region (point) (point-max)))
 128       (cons (nreverse revnos) (nreverse skipped)))))
 129
 130 (defun bzrmerge-resolve (file)
 131   (unless (file-exists-p file) (error "Bzrmerge-resolve: Can't find %s" file))
 132   (with-demoted-errors
 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)))
 137         (save-excursion
 138           (cond
 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))
 147                       (end1 (match-end 1))
 148                       (start3 (match-beginning 3))
 149                       (end3 (copy-marker (match-end 3) t)))
 150                   (goto-char start3)
 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
 160                   ;; match-3's first.
 161                   (let ((match3 (buffer-substring start3 end3))
 162                         (match1 (buffer-substring start1 end1)))
 163                     (delete-region start3 end3)
 164                     (goto-char start3)
 165                     (insert match1)
 166                     (delete-region start1 end1)
 167                     (goto-char start1)
 168                     (insert match3)))))
 169             ;; (pop-to-buffer (current-buffer)) (debug 'before-resolve)
 170             ))
 171           ;; Try to resolve the conflicts.
 172           (cond
 173            ((member file '("configure" "lisp/ldefs-boot.el"))
 174             (call-process "bzr" nil t nil "revert" file)
 175             (revert-buffer nil 'noconfirm))
 176            (t
 177             (goto-char (point-max))
 178             (while (re-search-backward smerge-begin-re nil t)
 179               (save-excursion
 180                 (ignore-errors
 181                   (smerge-match-conflict)
 182                   (smerge-resolve))))
 183             ;; (when (derived-mode-p 'change-log-mode)
 184             ;;   (pop-to-buffer (current-buffer)) (debug 'after-resolve))
 185             (save-buffer)))
 186           (goto-char (point-min))
 187           (prog1 (re-search-forward smerge-begin-re nil t)
 188             (unless exists (kill-buffer))))))))
 189
 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")))
 205
 206 (defvar bzrmerge-already-done nil)
 207
 208 (defun bzrmerge-apply (missing from)
 209   (setq from (expand-file-name from))
 210   (with-current-buffer (get-buffer-create "*bzrmerge*")
 211     (erase-buffer)
 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))
 216           (skip (cdr missing))
 217           beg end)
 218       (when (or merge skip)
 219         (cond
 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))
 228
 229          (t
 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").
 248             (push end skip))
 249           (pop-to-buffer (current-buffer))
 250           (sit-for 1)
 251           ;; (debug 'after-merge)
 252           ;; Check the conflicts.
 253           (let ((conflicted nil)
 254                 (files ()))
 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)))
 262                     (setq conflicted t))
 263               (if files (setq conflicted t)))
 264             (dolist (file files)
 265               (if (bzrmerge-resolve file)
 266                   (setq conflicted t)))
 267             (when conflicted
 268               (setq bzrmerge-already-done
 269                     (list (cons merge skip) from missing))
 270               (error "Resolve conflicts manually")))))
 271         (cons merge skip)))))
 272
 273 (defun bzrmerge (from)
 274   "Merge from branch FROM into `default-directory'."
 275   (interactive
 276    (list
 277     (let ((def
 278            (with-temp-buffer
 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)
 285   (require 'vc-bzr)
 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)))
 292       (while missing
 293         (setq missing (bzrmerge-apply missing from))))))
 294
 295 (provide 'bzrmerge)
 296 ;;; bzrmerge.el ends here