712 lines
26 KiB
EmacsLisp
712 lines
26 KiB
EmacsLisp
;;; xhg-mq.el --- dvc integration for hg's mq
|
|
|
|
;; Copyright (C) 2006-2009 by all contributors
|
|
|
|
;; Author: Stefan Reichoer, <stefan@xsteve.at>
|
|
|
|
;; This file 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 2, or (at your option)
|
|
;; any later version.
|
|
|
|
;; This file 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; see the file COPYING. If not, write to
|
|
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
;; Boston, MA 02110-1301, USA.
|
|
|
|
;;; Commentary:
|
|
|
|
;; For more information on mq see:
|
|
;; http://www.selenic.com/mercurial/wiki/index.cgi/MqTutorial
|
|
|
|
;;; Commands:
|
|
;;
|
|
;; Below is a complete command list:
|
|
;;
|
|
;; `xhg-qinit'
|
|
;; Run hg qinit.
|
|
;; `xhg-qnew'
|
|
;; Run hg qnew.
|
|
;; `xhg-qrefresh'
|
|
;; Run hg qrefresh.
|
|
;; `xhg-qrefresh-header'
|
|
;; Run hg qrefresh --message.
|
|
;; `xhg-qrefresh-edit-message-done'
|
|
;; Use the current buffer content as parameter for hg qrefresh --message.
|
|
;; `xhg-qrefresh-edit-message-mode'
|
|
;; Major mode to edit the mq header message for the current patch.
|
|
;; `xhg-qpop'
|
|
;; Run hg qpop.
|
|
;; `xhg-qpush'
|
|
;; Run hg qpush.
|
|
;; `xhg-qapplied'
|
|
;; Run hg qapplied.
|
|
;; `xhg-qunapplied'
|
|
;; Run hg qunapplied.
|
|
;; `xhg-qseries'
|
|
;; Run hg qseries.
|
|
;; `xhg-qdiff'
|
|
;; Run hg qdiff.
|
|
;; `xhg-qdelete'
|
|
;; Run hg qdelete
|
|
;; `xhg-qconvert-to-permanent'
|
|
;; Convert all applied patchs in permanent changeset.
|
|
;; `xhg-qrename'
|
|
;; Run hg qrename
|
|
;; `xhg-qtop'
|
|
;; Run hg qtop.
|
|
;; `xhg-qnext'
|
|
;; Run hg qnext.
|
|
;; `xhg-qprev'
|
|
;; Run hg qprev.
|
|
;; `xhg-qheader'
|
|
;; Run hg qheader.
|
|
;; `xhg-qsingle'
|
|
;; Merge applied patches in a single patch satrting from "qbase".
|
|
;; `xhg-qimport'
|
|
;; Run hg qimport
|
|
;; `xhg-mq-export-via-mail'
|
|
;; Prepare an email that contains a mq patch.
|
|
;; `xhg-mq-show-stack'
|
|
;; Show the mq stack.
|
|
;; `xhg-qdiff-at-point'
|
|
;; Show the diff for a given patch.
|
|
;; `xhg-mq-mode'
|
|
;; Major mode for xhg mq interaction.
|
|
;; `xhg-mq-edit-series-file'
|
|
;; Edit the mq patch series file
|
|
;;
|
|
|
|
;; The following commands are available for hg's mq:
|
|
;; X qapplied print the patches already applied
|
|
;; qclone clone main and patch repository at same time
|
|
;; qcommit commit changes in the queue repository
|
|
;; X qdelete remove a patch from the series file
|
|
;; X qdiff diff of the current patch
|
|
;; qfold fold the named patches into the current patch
|
|
;; qgoto push or pop patches until named patch is at top of stack
|
|
;; qguard set or print guards for a patch
|
|
;; X qheader Print the header of the topmost or specified patch
|
|
;; X qimport import a patch
|
|
;; X qinit init a new queue repository
|
|
;; X qnew create a new patch
|
|
;; X qnext print the name of the next patch
|
|
;; X qpop pop the current patch off the stack
|
|
;; X qprev print the name of the previous patch
|
|
;; X qpush push the next patch onto the stack
|
|
;; X qrefresh update the current patch
|
|
;; X qrename rename a patch
|
|
;; qrestore restore the queue state saved by a rev
|
|
;; qsave save current queue state
|
|
;; qselect set or print guarded patches to push
|
|
;; X qseries print the entire series file
|
|
;; X qtop print the name of the current patch
|
|
;; X qunapplied print the patches not yet applied
|
|
|
|
;;; Code:
|
|
|
|
(defvar xhg-mq-submenu
|
|
'("mq"
|
|
["Show mq stack" xhg-mq-show-stack t]
|
|
["mq refresh" xhg-qrefresh t]
|
|
["mq diff" xhg-qdiff t]
|
|
["mq push" xhg-qpush t]
|
|
["mq pop" xhg-qpop t]
|
|
["mq applied" xhg-qapplied t]
|
|
["mq unapplied" xhg-qunapplied t]
|
|
["mq series" xhg-qseries t]
|
|
["mq delete" xhg-qdelete t]
|
|
["mq rename" xhg-qrename t]
|
|
["mq header" xhg-qheader t]
|
|
"--"
|
|
["mq init" xhg-qinit t]
|
|
["mq new" xhg-qnew t]
|
|
))
|
|
|
|
(defvar xhg-mq-sub-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map [?A] 'xhg-qapplied)
|
|
(define-key map [?U] 'xhg-qunapplied)
|
|
(define-key map [?S] 'xhg-qseries)
|
|
(define-key map [?s] 'xhg-mq-show-stack)
|
|
(define-key map [?e] 'xhg-mq-edit-series-file)
|
|
(define-key map [?h] 'xhg-qheader)
|
|
(define-key map [?H] 'xhg-qrefresh-header)
|
|
(define-key map [?R] 'xhg-qrefresh)
|
|
(define-key map [?M] 'xhg-qrename)
|
|
(define-key map [?P] 'xhg-qpush) ;; mnemonic: stack gets bigger
|
|
(define-key map [?p] 'xhg-qpop) ;; mnemonic: stack gets smaller
|
|
(define-key map [?t] 'xhg-qtop)
|
|
(define-key map [?+] 'xhg-qnext)
|
|
(define-key map [?-] 'xhg-qprev)
|
|
(define-key map [?=] 'xhg-qdiff)
|
|
(define-key map [?d] 'xhg-qdelete)
|
|
(define-key map [?N] 'xhg-qnew)
|
|
(define-key map [?E] 'xhg-mq-export-via-mail)
|
|
(define-key map [?x] 'xhg-qsingle)
|
|
(define-key map [?C] 'xhg-qconvert-to-permanent)
|
|
map)
|
|
"Keymap used for xhg-mq commands.")
|
|
|
|
(defvar xhg-mq-cookie nil "Ewoc cookie for xhg mq buffers.")
|
|
|
|
;;;###autoload
|
|
(defun xhg-qinit (&optional dir qinit-switch)
|
|
"Run hg qinit.
|
|
When called without a prefix argument run hg qinit -c, otherwise hg qinit."
|
|
(interactive
|
|
(list (progn (setq qinit-switch (if current-prefix-arg "" "-c"))
|
|
(expand-file-name (dvc-read-directory-name (format "Directory for hg qinit %s: " qinit-switch)
|
|
(or default-directory
|
|
(getenv "HOME")))))
|
|
qinit-switch))
|
|
(let ((default-directory dir))
|
|
(dvc-run-dvc-sync 'xhg (list "qinit" qinit-switch)
|
|
:finished (dvc-capturing-lambda
|
|
(output error status arguments)
|
|
(message "hg qinit finished")))))
|
|
|
|
(defun xhg-qnew-name-patch ()
|
|
"Return a default name for a new patch based on last revision number"
|
|
(let ((cur-patch (xhg-qtop))
|
|
(cur-rev (xhg-dry-tip))
|
|
(patch-name)
|
|
(patch-templ-regex "\\(patch-r[0-9]+\\)"))
|
|
(if cur-patch
|
|
(if (string-match patch-templ-regex cur-patch)
|
|
(setq patch-name
|
|
(replace-regexp-in-string "\\([0-9]+\\)"
|
|
(int-to-string
|
|
(+ (string-to-number cur-rev) 1))
|
|
cur-patch))
|
|
(setq patch-name
|
|
(replace-regexp-in-string "\\([0-9]+\\)"
|
|
(int-to-string
|
|
(+ (string-to-number cur-rev) 1))
|
|
"patch-r0")))
|
|
(setq patch-name
|
|
"Initial-patch"))
|
|
patch-name))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qnew (patch-name &optional commit-description force)
|
|
"Run hg qnew.
|
|
Asks for the patch name and an optional commit description.
|
|
If the commit description is not empty, run hg qnew -m \"commit description\"
|
|
When called with a prefix argument run hg qnew -f."
|
|
(interactive
|
|
(list (read-from-minibuffer "qnew patch name: " nil nil nil nil (xhg-qnew-name-patch))
|
|
(read-from-minibuffer "qnew commit message (empty for none): " nil nil nil nil
|
|
"New patch, edit me when done with <M-x xhg-qrefresh-header>")
|
|
current-prefix-arg))
|
|
(when (string= commit-description "")
|
|
(setq commit-description nil))
|
|
(dvc-run-dvc-sync 'xhg (list "qnew"
|
|
(when force "-f")
|
|
(when commit-description "-m")
|
|
(when commit-description (concat "\"" commit-description "\""))
|
|
patch-name)))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qrefresh ()
|
|
"Run hg qrefresh."
|
|
(interactive)
|
|
(let ((top (xhg-qtop)))
|
|
(dvc-run-dvc-sync 'xhg (list "qrefresh"))
|
|
(message (format "hg qrefresh for %s finished" top))))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qrefresh-header ()
|
|
"Run hg qrefresh --message."
|
|
(interactive)
|
|
(let ((cur-message (xhg-qheader))
|
|
(cur-dir default-directory))
|
|
(dvc-buffer-push-previous-window-config)
|
|
(pop-to-buffer (get-buffer-create (format "*xhg header for %s*" (xhg-qtop))))
|
|
(setq default-directory (dvc-tree-root cur-dir))
|
|
(erase-buffer)
|
|
(insert cur-message)
|
|
(xhg-qrefresh-edit-message-mode)
|
|
(message "Edit the message and hit C-c C-c to accept it.")))
|
|
|
|
(defun xhg-qrefresh-edit-message-done ()
|
|
"Use the current buffer content as parameter for hg qrefresh --message."
|
|
(interactive)
|
|
(let ((logfile-name (make-temp-file "xhg-qrefresh"))
|
|
(new-message (buffer-substring-no-properties (point-min) (point-max)))
|
|
(message-buf))
|
|
(save-excursion
|
|
(find-file logfile-name)
|
|
(setq message-buf (current-buffer))
|
|
(insert new-message)
|
|
(save-buffer))
|
|
(dvc-run-dvc-sync 'xhg (list "qrefresh" "--logfile" logfile-name))
|
|
(kill-buffer message-buf)
|
|
(delete-file logfile-name)
|
|
(let ((dvc-buffer-quit-mode 'kill))
|
|
(dvc-buffer-quit))))
|
|
|
|
(defvar xhg-qrefresh-edit-message-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map [(control ?c) (control ?c)] 'xhg-qrefresh-edit-message-done)
|
|
map)
|
|
"Keymap used in a xhg qrefresh edit message buffer.")
|
|
|
|
(define-derived-mode xhg-qrefresh-edit-message-mode fundamental-mode
|
|
"xhg qrefresh edit message"
|
|
"Major mode to edit the mq header message for the current patch."
|
|
(dvc-install-buffer-menu))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qpop (&optional all)
|
|
"Run hg qpop.
|
|
When called with a prefix argument run hg qpop -a."
|
|
(interactive
|
|
(list current-prefix-arg))
|
|
(let ((curbuf (current-buffer)))
|
|
(message (format "qpop -> %s"
|
|
(dvc-run-dvc-sync 'xhg (list "qpop" (when all "-a"))
|
|
:finished 'dvc-output-buffer-handler
|
|
:error (lambda (output error status arguments)
|
|
(if (eq status 1)
|
|
(message "no patches applied")
|
|
(message "error status: %d" status))))))
|
|
(xhg-mq-maybe-refresh-patch-buffer)
|
|
(pop-to-buffer curbuf)))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qpush (&optional all)
|
|
"Run hg qpush.
|
|
When called with a prefix argument run hg qpush -a."
|
|
(interactive
|
|
(list current-prefix-arg))
|
|
(let ((curbuf (current-buffer)))
|
|
(message (format "qpush -> %s"
|
|
(dvc-run-dvc-sync 'xhg (list "qpush" (when all "-a"))
|
|
:finished 'dvc-output-buffer-handler
|
|
:error (lambda (output error status arguments)
|
|
(if (eq status 1)
|
|
(message "patch series fully applied")
|
|
(message "error status: %d" status))))))
|
|
(xhg-mq-maybe-refresh-patch-buffer)
|
|
(pop-to-buffer curbuf)))
|
|
|
|
(defun xhg-mq-maybe-refresh-patch-buffer ()
|
|
(let ((patch-buffer (dvc-get-buffer 'xhg 'patch-queue)))
|
|
(when patch-buffer
|
|
(with-current-buffer patch-buffer
|
|
(dvc-generic-refresh)))))
|
|
|
|
(defun xhg-mq-printer (elem)
|
|
"Print an element ELEM of the mq patch list."
|
|
(insert (dvc-face-add (car elem) (cadr elem))))
|
|
|
|
(defun xhg-process-mq-patches (cmd-list header refresh-function &optional only-show)
|
|
(let ((patches (delete "" (dvc-run-dvc-sync 'xhg cmd-list
|
|
:finished 'dvc-output-buffer-split-handler))))
|
|
(when only-show
|
|
(let ((curbuf (current-buffer)))
|
|
(pop-to-buffer (dvc-get-buffer-create 'xhg 'patch-queue))
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer)
|
|
(insert header)
|
|
(set (make-local-variable 'xhg-mq-cookie)
|
|
(ewoc-create (dvc-ewoc-create-api-select #'xhg-mq-printer)))
|
|
(put 'xhg-mq-cookie 'permanent-local t)
|
|
(dolist (patch patches)
|
|
(ewoc-enter-last xhg-mq-cookie (list patch nil))))
|
|
(xhg-mq-mode)
|
|
(setq dvc-buffer-refresh-function refresh-function)
|
|
(goto-char (point-min))
|
|
(forward-line 1)
|
|
(pop-to-buffer curbuf)))
|
|
patches))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qapplied ()
|
|
"Run hg qapplied."
|
|
(interactive)
|
|
(xhg-process-mq-patches '("qapplied") "hg qapplied:" 'xhg-qapplied (interactive-p)))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qunapplied ()
|
|
"Run hg qunapplied."
|
|
(interactive)
|
|
(xhg-process-mq-patches '("qunapplied") "hg qunapplied:" 'xhg-qunapplied (interactive-p)))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qseries ()
|
|
"Run hg qseries."
|
|
(interactive)
|
|
(xhg-process-mq-patches '("qseries") "hg series:" 'xhg-qseries (interactive-p)))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qdiff (&optional file)
|
|
"Run hg qdiff."
|
|
(interactive)
|
|
(let ((curbuf (current-buffer)))
|
|
(dvc-run-dvc-display-as-info 'xhg (list "qdiff" file) nil (format "hg qdiff %s:\n" (xhg-qtop)))
|
|
(with-current-buffer "*xhg-info*"
|
|
(diff-mode))
|
|
(pop-to-buffer curbuf)))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qdelete (patch)
|
|
"Run hg qdelete"
|
|
(interactive (list
|
|
(let ((unapplied (xhg-qunapplied)))
|
|
(if unapplied
|
|
(dvc-completing-read "Delete mq patch: " unapplied nil t
|
|
(car (member (xhg-mq-patch-name-at-point) unapplied)))
|
|
(message "No unapplied patch to delete from the mq series file")
|
|
nil))))
|
|
(when patch
|
|
(dvc-run-dvc-sync 'xhg (list "qdelete" patch))
|
|
(xhg-mq-maybe-refresh-patch-buffer)))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qconvert-to-permanent (&optional force)
|
|
"Convert all applied patchs in permanent changeset.
|
|
Run the command hg qdelete -r qbase:qtip
|
|
Called with prefix-arg, do not prompt for confirmation"
|
|
(interactive)
|
|
(let ((tip (with-temp-buffer
|
|
(apply #'call-process "hg" nil t nil
|
|
(list "tip" "--template" "#rev#"))
|
|
(buffer-string)))
|
|
(confirm))
|
|
(if current-prefix-arg
|
|
(progn
|
|
(dvc-run-dvc-sync 'xhg (list "qdelete" "-r" "qbase:qtip"))
|
|
(message "All patchs converted to permanent changeset: now at rev %s" tip))
|
|
(setq confirm (read-string "Really add permanent changesets to this repo?\(y/n\): "))
|
|
(if (equal confirm "y")
|
|
(progn
|
|
(dvc-run-dvc-sync 'xhg (list "qdelete" "-r" "qbase:qtip"))
|
|
(message "All patchs converted to permanent changeset: now at rev %s" tip))
|
|
(message "Operation cancelled")))))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qrename (from to)
|
|
"Run hg qrename"
|
|
(interactive (let ((old-name (or (xhg-mq-patch-name-at-point) (xhg-qtop))))
|
|
(list
|
|
old-name
|
|
(if old-name
|
|
(read-from-minibuffer (format "Rename mq patch '%s' to: " old-name) old-name)
|
|
(message "No mq patch to rename found")
|
|
nil))))
|
|
(message "Running hg qrename %s %s" from to)
|
|
(when (and from to)
|
|
(dvc-run-dvc-sync 'xhg (list "qrename" from to))))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qtop ()
|
|
"Run hg qtop."
|
|
(interactive)
|
|
(let ((top (dvc-run-dvc-sync 'xhg '("qtop")
|
|
:finished 'dvc-output-buffer-handler
|
|
:error (lambda (output error status arguments)
|
|
nil))))
|
|
(when (interactive-p)
|
|
(if top
|
|
(message "Mercurial qtop: %s" top)
|
|
(message "Mercurial qtop: no patches applied")))
|
|
top))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qnext ()
|
|
"Run hg qnext."
|
|
(interactive)
|
|
(let ((next (dvc-run-dvc-sync 'xhg '("qnext")
|
|
:finished 'dvc-output-buffer-handler)))
|
|
(when (interactive-p)
|
|
(message "Mercurial qnext: %s" next))
|
|
next))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qprev ()
|
|
"Run hg qprev."
|
|
(interactive)
|
|
(let ((prev (dvc-run-dvc-sync 'xhg '("qprev")
|
|
:finished 'dvc-output-buffer-handler)))
|
|
(when (interactive-p)
|
|
(message "Mercurial qprev: %s" prev))
|
|
prev))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qheader (&optional patch)
|
|
"Run hg qheader."
|
|
(interactive
|
|
(list
|
|
(xhg-mq-patch-name-at-point)))
|
|
(let ((header (dvc-run-dvc-sync 'xhg (list "qheader" patch)
|
|
:finished 'dvc-output-buffer-handler)))
|
|
(when (interactive-p)
|
|
(message "Mercurial qheader: %s" header))
|
|
header))
|
|
|
|
(defun xhg-mq-patch-file-name (patch)
|
|
(concat (xhg-tree-root) "/.hg/patches/" patch))
|
|
|
|
;;;###autoload
|
|
(defun* xhg-qsingle (file &optional (start-from "qbase"))
|
|
"Merge applied patches in a single patch starting from \"qbase\".
|
|
If prefix arg, merge applied patches starting from revision number or patch-name."
|
|
(interactive "FPatchName: ")
|
|
(when (and current-prefix-arg (interactive-p))
|
|
(let ((series (xhg-qseries)))
|
|
(setq start-from (completing-read "PatchName: "
|
|
series nil t
|
|
(car (member (xhg-mq-patch-name-at-point) series))))))
|
|
(let* ((base (with-temp-buffer
|
|
(apply #'call-process "hg" nil t nil
|
|
`("parents"
|
|
"-r"
|
|
,start-from
|
|
"--template"
|
|
"#rev#"))
|
|
(buffer-string)))
|
|
(patch (with-temp-buffer
|
|
(apply #'call-process "hg" nil t nil
|
|
(list "diff"
|
|
"-r"
|
|
base
|
|
"-r"
|
|
"qtip"
|
|
(when xhg-export-git-style-patches "--git")))
|
|
(buffer-string)))
|
|
(applied (split-string
|
|
(with-temp-buffer
|
|
(apply #'call-process "hg" nil t nil
|
|
(list "qapplied" "-s"))
|
|
(buffer-string)) "\n")))
|
|
(when (not (equal start-from "qbase"))
|
|
(let (pos elm)
|
|
(catch 'break
|
|
(dolist (i applied)
|
|
(when (string-match start-from i)
|
|
(throw 'break
|
|
(setq elm i)))))
|
|
(setq pos (position elm applied))
|
|
(setq applied (subseq applied pos))))
|
|
(find-file file)
|
|
(goto-char (point-min))
|
|
(erase-buffer)
|
|
(insert (format "##Merge of all patches applied from revision %s\n" base))
|
|
(mapc #'(lambda (x)
|
|
(insert (concat "## " x "\n")))
|
|
applied)
|
|
(insert patch)
|
|
(save-buffer)
|
|
(kill-buffer (current-buffer))
|
|
(message "Ok patch extracted from rev %s to tip in %s" base file)))
|
|
|
|
;;;###autoload
|
|
(defun xhg-qimport (patch &optional push)
|
|
"Run hg qimport"
|
|
(interactive (list (read-file-name "Import hg qpatch: "
|
|
nil
|
|
nil
|
|
t
|
|
(when
|
|
(eq major-mode 'dired-mode)
|
|
(file-name-nondirectory (dired-get-filename))))))
|
|
(if current-prefix-arg
|
|
(progn
|
|
(and (dvc-run-dvc-sync 'xhg (list "qimport" (expand-file-name patch)))
|
|
(dvc-run-dvc-sync 'xhg (list "qpush")))
|
|
(message "Ok patch %s added" patch))
|
|
(dvc-run-dvc-sync 'xhg (list "qimport" (expand-file-name patch)))
|
|
(message "Ok patch %s added ; don't forget to qpush" patch)))
|
|
|
|
;; --------------------------------------------------------------------------------
|
|
;; Higher level functions
|
|
;; --------------------------------------------------------------------------------
|
|
|
|
;;;###autoload
|
|
(defun xhg-mq-export-via-mail (patch &optional single)
|
|
"Prepare an email that contains a mq patch.
|
|
`xhg-submit-patch-mapping' is honored for the destination email address and the project name
|
|
that is used in the generated email."
|
|
(interactive (list
|
|
(let ((series (xhg-qseries)))
|
|
(dvc-completing-read (if current-prefix-arg
|
|
"Send single patch from: "
|
|
"Send mq patch via mail: ") series nil t
|
|
(car (member (xhg-mq-patch-name-at-point) series))))))
|
|
(let ((file-name)
|
|
(destination-email "")
|
|
(base-file-name nil)
|
|
(subject)
|
|
(log))
|
|
(dolist (m xhg-submit-patch-mapping)
|
|
(when (string= (dvc-uniquify-file-name (car m)) (dvc-uniquify-file-name (xhg-tree-root)))
|
|
;;(message "%S" (cadr m))
|
|
(setq destination-email (car (cadr m)))
|
|
(setq base-file-name (cadr (cadr m)))))
|
|
(message "Preparing an email for the mq patch '%s' for '%s'" patch destination-email)
|
|
(if (or current-prefix-arg single)
|
|
(let ((pname (format "single-from-%s-to-tip.patch" patch)))
|
|
(setq file-name (concat (dvc-uniquify-file-name dvc-temp-directory)
|
|
pname))
|
|
(xhg-qsingle file-name patch)
|
|
(setq log
|
|
(with-temp-buffer
|
|
(let (beg end)
|
|
(insert-file-contents file-name)
|
|
(goto-char (point-min))
|
|
(setq beg (point))
|
|
(when (re-search-forward "^diff" nil t)
|
|
(setq end (point-at-bol)))
|
|
(replace-regexp-in-string "^#*" "" (buffer-substring beg end)))))
|
|
(setq subject pname))
|
|
(setq file-name (concat (dvc-uniquify-file-name dvc-temp-directory)
|
|
(or base-file-name "") "-" patch ".patch"))
|
|
(copy-file (xhg-mq-patch-file-name patch) file-name t t))
|
|
|
|
(require 'reporter)
|
|
(delete-other-windows)
|
|
(reporter-submit-bug-report
|
|
destination-email
|
|
nil
|
|
nil
|
|
nil
|
|
nil
|
|
(if (or current-prefix-arg single)
|
|
log
|
|
dvc-patch-email-message-body-template))
|
|
(unless (or current-prefix-arg single)
|
|
(setq subject (if base-file-name (concat base-file-name ": " patch) patch)))
|
|
|
|
;; delete emacs version - its not needed here
|
|
(delete-region (point) (point-max))
|
|
|
|
(mml-attach-file file-name "text/x-patch")
|
|
(goto-char (point-min))
|
|
(mail-position-on-field "Subject")
|
|
(insert (concat "[MQ-PATCH] " subject))
|
|
(when (search-forward "<<LOG-START>>" nil t)
|
|
(forward-line 1))
|
|
(find-file-other-window file-name)
|
|
(other-window -1)))
|
|
|
|
;;;###autoload
|
|
(defun xhg-mq-show-stack ()
|
|
"Show the mq stack."
|
|
(interactive)
|
|
(xhg-process-mq-patches '("qseries") "hg stack:" 'xhg-mq-show-stack (interactive-p))
|
|
(let ((applied (xhg-qapplied))
|
|
(unapplied (xhg-qunapplied))
|
|
(top (xhg-qtop))
|
|
(top-pos))
|
|
(with-current-buffer (dvc-get-buffer 'xhg 'patch-queue)
|
|
(let ((buffer-read-only nil)
|
|
(old-applied-patches (progn (goto-char (point-min)) (next-line 1)
|
|
(split-string (buffer-substring-no-properties (point) (- (point-max) 1)))))
|
|
(act-patches (append applied unapplied)))
|
|
(dolist (u unapplied)
|
|
(goto-char (point-min))
|
|
(when (re-search-forward (concat "^" u "$") nil t)
|
|
(setcar (cdr (xhg-mq-ewoc-data-at-point)) nil)))
|
|
(dolist (a applied)
|
|
(goto-char (point-min))
|
|
(when (re-search-forward (concat "^" a "$") nil t)
|
|
(setcar (cdr (xhg-mq-ewoc-data-at-point)) 'dvc-move)))
|
|
(dolist (p old-applied-patches)
|
|
(when (not (member p act-patches))
|
|
(goto-char (point-min))
|
|
(when (re-search-forward (concat "^" p "$") nil t)
|
|
(message "Patch %s no longer present" p)
|
|
(dvc-ewoc-delete xhg-mq-cookie (ewoc-locate xhg-mq-cookie)))))
|
|
(when top
|
|
(goto-char (point-min))
|
|
(when (re-search-forward (concat "^" top "$") nil t)
|
|
(setq top-pos (line-beginning-position))
|
|
(setcar (cdr (xhg-mq-ewoc-data-at-point)) 'bold)))
|
|
(ewoc-refresh xhg-mq-cookie)
|
|
(when top-pos
|
|
(goto-char top-pos))))))
|
|
|
|
(defun xhg-qdiff-at-point (&optional patch)
|
|
"Show the diff for a given patch."
|
|
(interactive)
|
|
(let ((patch-name (or patch (xhg-mq-patch-name-at-point)))
|
|
(cur-buf (current-buffer)))
|
|
(find-file-other-window (xhg-mq-patch-file-name patch-name))
|
|
(toggle-read-only 1)
|
|
(diff-mode)
|
|
(pop-to-buffer cur-buf)))
|
|
|
|
;; --------------------------------------------------------------------------------
|
|
;; the xhg mq mode
|
|
;; --------------------------------------------------------------------------------
|
|
|
|
(defvar xhg-mq-mode-map
|
|
(let ((map (make-sparse-keymap)))
|
|
(define-key map (dvc-prefix-buffer ?L) 'dvc-open-internal-log-buffer)
|
|
(define-key map dvc-keyvec-quit 'dvc-buffer-quit)
|
|
(define-key map [?g] 'dvc-generic-refresh)
|
|
(define-key map [?e] 'xhg-mq-edit-series-file)
|
|
(define-key map [down] 'xhg-mq-next)
|
|
(define-key map [up] 'xhg-mq-previous)
|
|
(define-key map [?P] 'xhg-qpush) ;; mnemonic: stack gets bigger
|
|
(define-key map [?p] 'xhg-qpop) ;; mnemonic: stack gets smaller
|
|
(define-key map [?=] 'xhg-qdiff-at-point)
|
|
(define-key map [?E] 'xhg-mq-export-via-mail)
|
|
(define-key map [?M] 'xhg-qrename)
|
|
(define-key map [?x] 'xhg-qsingle)
|
|
(define-key map [?C] 'xhg-qconvert-to-permanent)
|
|
(define-key map [?Q] xhg-mq-sub-mode-map)
|
|
map)
|
|
"Keymap used in a xhg mq buffer.")
|
|
|
|
(easy-menu-define xhg-mq-mode-menu xhg-mq-mode-map
|
|
"`xhg-mq-mode' menu"
|
|
xhg-mq-submenu)
|
|
|
|
(define-derived-mode xhg-mq-mode fundamental-mode
|
|
"xhg mq mode"
|
|
"Major mode for xhg mq interaction."
|
|
(dvc-install-buffer-menu)
|
|
(toggle-read-only 1))
|
|
|
|
(defun xhg-mq-ewoc-data-at-point ()
|
|
(if (or (= (dvc-line-number-at-pos) 1)
|
|
(eq (line-beginning-position) (line-end-position))
|
|
(not (eq major-mode 'xhg-mq-mode)))
|
|
nil
|
|
(ewoc-data (ewoc-locate xhg-mq-cookie))))
|
|
|
|
(defun xhg-mq-patch-name-at-point ()
|
|
"Return the patch name at point in a xhg mq buffer."
|
|
(car (xhg-mq-ewoc-data-at-point)))
|
|
|
|
(defun xhg-mq-edit-series-file ()
|
|
"Edit the mq patch series file"
|
|
(interactive)
|
|
(find-file-other-window (concat (dvc-tree-root) "/.hg/patches/series"))
|
|
(message "You can carefully reorder the patches in the series file. Comments starting with '#' and empty lines are allowed."))
|
|
|
|
(defun xhg-mq-next ()
|
|
(interactive)
|
|
(let ((pos (point)))
|
|
(forward-line 1)
|
|
(unless (xhg-mq-ewoc-data-at-point)
|
|
(goto-char pos))))
|
|
|
|
(defun xhg-mq-previous ()
|
|
(interactive)
|
|
(let ((pos (point)))
|
|
(forward-line -1)
|
|
(unless (xhg-mq-ewoc-data-at-point)
|
|
(goto-char pos))))
|
|
|
|
(provide 'xhg-mq)
|
|
;;; xhg-mq.el ends here
|