summaryrefslogtreecommitdiff
path: root/admin/bzrmerge.el
blob: 46a5e42aa7bb484372d24026088b1093c530fb7b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
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
211
212
213
214
215
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
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
;;; bzrmerge.el --- help merge one Emacs bzr branch to another

;; Copyright (C) 2010-2017 Free Software Foundation, Inc.

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

;; GNU Emacs is free software: you can redistribute it and/or modify
;; 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.

;; GNU Emacs is distributed in the hope that it will be useful,
;; 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
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Some usage notes are in admin/notes/bzr.

;;; Code:

(eval-when-compile (require 'cl-lib))

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

(defconst bzrmerge-buffer "*bzrmerge*"
  "Working buffer for bzrmerge.")

(defconst bzrmerge-warning-buffer "*bzrmerge warnings*"
  "Buffer where bzrmerge will display any warnings.")

(defun bzrmerge-merges ()
  "Return the list of already merged (not yet committed) revisions.
The list returned is sorted by oldest-first."
  (with-current-buffer (get-buffer-create bzrmerge-buffer)
    (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
    ;; not yet committed).  Unversioned (unknown) files in the tree
    ;; are also ok.
    (call-process "bzr" nil t nil "status" "-v")
    (goto-char (point-min))
    (when (re-search-forward "^conflicts:\n" nil t)
      (user-error "You still have unresolved conflicts"))
    (let ((merges ())
          found)
      (if (not (re-search-forward "^pending merges:\n" nil t))
          (when (save-excursion
                  (goto-char (point-min))
                  (while (and
                          (re-search-forward "^\\([a-z ]*\\):\n" nil t)
                          (not
                           (setq found
                                 (not (equal "unknown" (match-string 1)))))))
                  found)
            (user-error "You still have uncommitted changes"))
        ;; 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.
Asks about skipping revisions with logs matching `bzrmerge-skip-regexp'.
The result is of the form (TOMERGE . TOSKIP) where TOMERGE and TOSKIP
are both lists of revnos, in oldest-first order."
  (with-current-buffer (get-buffer-create bzrmerge-buffer)
    (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)
                          (re-search-forward bzrmerge-skip-regexp nil t))
                (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))))
                  (let ((help-form (substitute-command-keys "\
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.")))
                    (pcase (save-excursion
                            (read-char-choice
                             (format "%s: Skip (y/n/N/q/%s)? " str
                                     (key-description (vector help-char)))
                             '(?y ?n ?N ?q)))
                      (`?y (setq skip t))
                      (`?q (keyboard-quit))
                      ;; 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.
                      (`?N (setq skip 'no))))))
              (if (eq skip t)
                  (push revno skipped)
                (push revno revnos)))))
        (delete-region (point) (point-max)))
      (and (or revnos skipped)
           (cons (nreverse revnos) (nreverse skipped))))))

(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)))
      (with-current-buffer (let ((enable-local-variables :safe)
                                 (enable-local-eval nil))
                             (find-file-noselect file))
        (if (buffer-modified-p)
            (user-error "Unsaved changes in %s" (current-buffer)))
        (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
           ((member file '("configure" "lisp/ldefs-boot.el"
                           "lisp/emacs-lisp/cl-loaddefs.el"))
            ;; We are in the file's buffer, so names are relative.
            (call-process "bzr" nil t nil "revert"
                          (file-name-nondirectory file))
            (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")))

(defvar bzrmerge-already-done nil)

(defun bzrmerge-apply (missing from)
  (setq from (expand-file-name from))
  (with-current-buffer (get-buffer-create bzrmerge-buffer)
    (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))
          (unsafe nil)
          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))))
            (cl-assert (> (car skip) (or end beg)))
            (setq end (pop skip)))
          (message "Skipping %s..%s" beg end)
          (bzrmerge-add-metadata from end))

         (t
          ;; Do a "normal" merge.
          (cl-assert (or (null skip) (< (car merge) (car skip))))
          (setq beg (1- (car merge)))
          (while (and merge (or (null skip) (< (car merge) (car skip))))
            (cl-assert (> (car merge) (or end beg)))
            (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").
            (setq unsafe t)
            (push end skip))
          (pop-to-buffer (current-buffer))
          (sit-for 1)
          ;; (debug 'after-merge)
          ;; Check the conflicts.
          ;; 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.
          (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))
              (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.
BEWARE!  Important metadata is kept in this Emacs session!
Do not commit without re-running `M-x bzrmerge' first!"
                                   :warning bzrmerge-warning-buffer))
              (user-error "Resolve conflicts manually")))))
        (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))))
  ;; 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))
  (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)))
      (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)))))

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