X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/14beddf4711854b01d400f36166dc71eb39435bb..ce92397425d29ec27fc701c36c589a5e1f894898:/admin/bzrmerge.el diff --git a/admin/bzrmerge.el b/admin/bzrmerge.el index e9fd0ea00f..1de7bc445e 100644 --- a/admin/bzrmerge.el +++ b/admin/bzrmerge.el @@ -1,9 +1,9 @@ -;;; bzrmerge.el --- +;;; bzrmerge.el --- help merge one Emacs bzr branch to another -;; Copyright (C) 2010-2011 Free Software Foundation, Inc. +;; Copyright (C) 2010-2016 Free Software Foundation, Inc. ;; Author: Stefan Monnier -;; Keywords: +;; 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 @@ -20,36 +20,49 @@ ;;; Commentary: -;; +;; Some usage notes are in admin/notes/bzr. ;;; Code: -(eval-when-compile - (require 'cl)) ; assert +(eval-when-compile (require 'cl-lib)) (defvar bzrmerge-skip-regexp - "back[- ]?port\\|merge\\|sync\\|re-?generate\\|bump version" + "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*") + (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). + ;; 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) - (error "You still have unresolved conflicts")) - (let ((merges ())) + (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)) - (re-search-forward "^[a-z ]*:\n" nil t)) - (error "You still have uncommitted changes")) + (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 @@ -99,7 +112,7 @@ 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*") + (with-current-buffer (get-buffer-create bzrmerge-buffer) (erase-buffer) (call-process "bzr" nil t nil "missing" "--theirs-only" (expand-file-name from)) @@ -127,21 +140,38 @@ are both lists of revnos, in oldest-first order." (setq str (substring str (match-end 0)))) (when (string-match "[.!;, ]+\\'" str) (setq str (substring str 0 (match-beginning 0)))) - (if (save-excursion (y-or-n-p (concat str ": Skip? "))) - (setq skip t)))) - (if skip + (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))) - (cons (nreverse revnos) (nreverse skipped))))) + (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 (find-file-noselect file) + (with-current-buffer (let ((enable-local-variables :safe) + (enable-local-eval nil)) + (find-file-noselect file)) (if (buffer-modified-p) - (error "Unsaved changes in %s" (current-buffer))) + (user-error "Unsaved changes in %s" (current-buffer))) (save-excursion (cond ((derived-mode-p 'change-log-mode) @@ -180,7 +210,9 @@ are both lists of revnos, in oldest-first order." (cond ((member file '("configure" "lisp/ldefs-boot.el" "lisp/emacs-lisp/cl-loaddefs.el")) - (call-process "bzr" nil t nil "revert" file) + ;; 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)) @@ -216,7 +248,7 @@ Does not make other difference." (defun bzrmerge-apply (missing from) (setq from (expand-file-name from)) - (with-current-buffer (get-buffer-create "*bzrmerge*") + (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))) @@ -231,17 +263,17 @@ Does not make other difference." ;; 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)))) - (assert (> (car skip) (or end beg))) + (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. - (assert (or (null skip) (< (car merge) (car skip)))) + (cl-assert (or (null skip) (< (car merge) (car skip)))) (setq beg (1- (car merge))) (while (and merge (or (null skip) (< (car merge) (car skip)))) - (assert (> (car merge) (or end beg))) + (cl-assert (> (car merge) (or end beg))) (setq end (pop merge))) (message "Merging %s..%s" beg end) (if (with-temp-buffer @@ -261,6 +293,9 @@ Does not make other difference." (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)) @@ -285,9 +320,10 @@ Does not make other difference." ;; 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!")) - (error "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) @@ -301,6 +337,10 @@ Do not commit without re-running `M-x bzrmerge' first!")) (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) @@ -309,8 +349,11 @@ Do not commit without re-running `M-x bzrmerge' first!")) (let* ((merges (bzrmerge-merges)) ;; OK, we have the status, now check the missing data. (missing (bzrmerge-missing from merges))) - (while missing - (setq missing (bzrmerge-apply missing from)))))) + (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