335 lines
14 KiB
EmacsLisp
335 lines
14 KiB
EmacsLisp
;;; dvc-gnus.el --- dvc integration to gnus
|
|
|
|
;; Copyright (C) 2003-2009 by all contributors
|
|
|
|
;; Author: Matthieu Moy <Matthieu.Moy@imag.fr>
|
|
;; Contributions from:
|
|
;; Stefan Reichoer <stefan@xsteve.at>
|
|
|
|
;; DVC 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.
|
|
|
|
;; DVC 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:
|
|
|
|
(require 'tla-core)
|
|
|
|
;; gnus is optional. Load it at compile-time to avoid warnings.
|
|
(eval-when-compile
|
|
(condition-case nil
|
|
(progn
|
|
(require 'gnus)
|
|
(require 'gnus-art)
|
|
(require 'gnus-sum))
|
|
(error nil)))
|
|
|
|
(defvar gnus-summary-dvc-submap nil
|
|
"DVC Key mapping added to gnus summary.")
|
|
|
|
(defun dvc-gnus-initialize-keymap ()
|
|
"Initialize the keymap for DVC in `gnus-summary-mode-map'.
|
|
|
|
Prefix key is 'K t'."
|
|
(unless gnus-summary-dvc-submap
|
|
(require 'gnus)
|
|
(require 'gnus-sum)
|
|
(require 'gnus-art)
|
|
(setq gnus-summary-dvc-submap (make-sparse-keymap))
|
|
(define-key gnus-summary-mode-map [?K ?t] gnus-summary-dvc-submap)))
|
|
|
|
;;;###autoload
|
|
(defun dvc-insinuate-gnus ()
|
|
"Insinuate Gnus for each registered DVC back-end.
|
|
|
|
Runs (<backend>-insinuate-gnus) for each registered back-end having
|
|
this function.
|
|
|
|
Additionally the following key binding is defined for the gnus summary mode map:
|
|
K t l `dvc-gnus-article-extract-log-message'
|
|
K t v `dvc-gnus-article-view-patch'
|
|
K t m `dvc-gnus-article-view-missing'
|
|
K t a `dvc-gnus-article-apply-patch'
|
|
K t p `dvc-gnus-article-apply-patch-with-selected-destination'"
|
|
(interactive)
|
|
(dvc-gnus-initialize-keymap)
|
|
(define-key gnus-summary-dvc-submap [?a] 'dvc-gnus-article-apply-patch)
|
|
(define-key gnus-summary-dvc-submap [?p] 'dvc-gnus-article-apply-patch-with-selected-destination)
|
|
(define-key gnus-summary-dvc-submap [?l] 'dvc-gnus-article-extract-log-message)
|
|
(define-key gnus-summary-dvc-submap [?v] 'dvc-gnus-article-view-patch)
|
|
(define-key gnus-summary-dvc-submap [?m] 'dvc-gnus-article-view-missing)
|
|
(mapcar (lambda (x)
|
|
(let ((fn (dvc-function x "insinuate-gnus" t)))
|
|
(when (fboundp fn)
|
|
(dvc-trace "Insinuating Gnus for %S" x)
|
|
(funcall fn))))
|
|
dvc-registered-backends))
|
|
|
|
(defun dvc-gnus-article-extract-log-message ()
|
|
"Parse the mail and extract the log information.
|
|
Save it to `dvc-memorized-log-header', `dvc-memorized-patch-sender',
|
|
`dvc-memorized-log-message' and `dvc-memorized-version'."
|
|
(interactive)
|
|
(gnus-summary-select-article-buffer)
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(let* ((start-pos (or (search-forward "[PATCH] " nil t) (search-forward "Subject: ")))
|
|
(end-pos (line-end-position))
|
|
(log-header (buffer-substring-no-properties start-pos end-pos)))
|
|
(setq dvc-memorized-log-header log-header))
|
|
(goto-char (point-min))
|
|
(let* ((start-pos (re-search-forward "From: +" nil t))
|
|
(end-pos (line-end-position))
|
|
(sender (when start-pos (buffer-substring-no-properties start-pos end-pos))))
|
|
(setq dvc-memorized-patch-sender (and start-pos sender)))
|
|
(goto-char (point-min))
|
|
(let* ((start-pos (search-forward "[VERSION] " nil t))
|
|
(end-pos (line-end-position))
|
|
(version (when start-pos (buffer-substring-no-properties start-pos end-pos))))
|
|
(setq dvc-memorized-version (and start-pos version)))
|
|
(dolist (delim-pair '(("^<<LOG-START>>" "^<<LOG-END>>") ("^\\[\\[\\[" "^\\]\\]\\]")))
|
|
(goto-char (point-min))
|
|
(when (and (re-search-forward (car delim-pair) nil t)
|
|
(re-search-forward (cadr delim-pair) nil t))
|
|
(goto-char (point-min))
|
|
(let* ((start-pos (+ (re-search-forward (car delim-pair)) 1))
|
|
(end-pos (- (progn (re-search-forward (cadr delim-pair)) (line-beginning-position)) 1))
|
|
(log-message (buffer-substring-no-properties start-pos end-pos)))
|
|
(setq dvc-memorized-log-message log-message)
|
|
(message "Extracted the patch log message from '%s'" dvc-memorized-log-header)))))
|
|
(gnus-article-show-summary))
|
|
|
|
(defvar dvc-gnus-article-apply-patch-deciders nil
|
|
"A list of functions that can be used to determine the patch type in a given mail.
|
|
The function is called when the article buffer is active. It should return nil if
|
|
the patch type could not be determined, otherwise one of the following:
|
|
'tla, 'xhg, 'bzr-merge-or-pull-url, 'bzr-merge-bundle, 'xgit")
|
|
(defvar dvc-gnus-override-window-config nil)
|
|
(defun dvc-gnus-article-apply-patch (n)
|
|
"Apply MIME part N, as patchset.
|
|
When called with no prefix arg, set N := 2.
|
|
|
|
DVC will try to figure out which VCS to use when applying the patch.
|
|
|
|
First we check to see if it is a tla changeset created with DVC.
|
|
If that is the case, `tla-gnus-apply-patch' is called.
|
|
|
|
The next check is whether it is a patch suitable for xhg. In that case
|
|
`xhg-gnus-article-import-patch' is called.
|
|
|
|
Then we check to see whether the patch was prepared with git
|
|
format-patch. If so, then call `xgit-gnus-article-apply-patch'.
|
|
|
|
Otherwise `dvc-gnus-apply-patch' is called."
|
|
(interactive "p")
|
|
(unless current-prefix-arg
|
|
(setq n 2))
|
|
(let ((patch-type)
|
|
(bzr-merge-or-pull-url)
|
|
(patch-decider-list dvc-gnus-article-apply-patch-deciders))
|
|
(save-window-excursion
|
|
(gnus-summary-select-article-buffer)
|
|
(goto-char (point-min))
|
|
(while (and (not patch-type) patch-decider-list)
|
|
(setq patch-type (funcall (car patch-decider-list)))
|
|
(setq patch-decider-list (cdr patch-decider-list)))
|
|
(unless patch-type
|
|
(cond ((re-search-forward (concat "\\[VERSION\\] "
|
|
(tla-make-name-regexp 4 t t))
|
|
nil t)
|
|
(setq patch-type 'tla))
|
|
((progn (goto-char (point-min))
|
|
(re-search-forward "^# Bazaar merge directive format" nil t))
|
|
(setq patch-type 'bzr-merge-bundle))
|
|
((progn (goto-char (point-min))
|
|
(or
|
|
(re-search-forward "^changeset: +[0-9]+:[0-9a-f]+$" nil t)
|
|
(re-search-forward "^Merge of all patches applied from revision" nil t)))
|
|
(setq patch-type 'xhg))
|
|
((progn (goto-char (point-min))
|
|
(or (re-search-forward "^New revision in \\(.+\\)$" nil t)
|
|
(re-search-forward "^Committed revision [0-9]+ to \\(.+\\)$" nil t)))
|
|
(setq patch-type 'bzr-merge-or-pull
|
|
bzr-merge-or-pull-url (match-string-no-properties 1)))
|
|
((progn (goto-char (point-min))
|
|
(and (re-search-forward "^---$" nil t)
|
|
(re-search-forward "^diff --git" nil t)))
|
|
(setq patch-type 'xgit))
|
|
(t (setq patch-type 'dvc)))))
|
|
(message "patch-type: %S" patch-type)
|
|
(cond ((eq patch-type 'tla)
|
|
(tla-gnus-article-apply-patch n))
|
|
((eq patch-type 'xhg)
|
|
(xhg-gnus-article-import-patch n))
|
|
((eq patch-type 'xgit)
|
|
(xgit-gnus-article-apply-patch n))
|
|
((eq patch-type 'bzr-merge-or-pull)
|
|
(bzr-merge-or-pull-from-url bzr-merge-or-pull-url))
|
|
((eq patch-type 'bzr-merge-bundle)
|
|
(bzr-gnus-article-merge-bundle n))
|
|
((eq patch-type 'bzr-pull-bundle-in-branch)
|
|
(bzr-gnus-article-pull-bundle-in-branch n))
|
|
((eq patch-type nil)
|
|
(let ((dvc-gnus-override-window-config))
|
|
(gnus-article-part-wrapper n 'dvc-gnus-apply-patch)
|
|
(when dvc-gnus-override-window-config
|
|
(set-window-configuration dvc-gnus-override-window-config))))
|
|
(t
|
|
(error "Unknown patch type %S" patch-type)))))
|
|
|
|
(defvar dvc-gnus-select-patch-dir-function nil)
|
|
(defun dvc-gnus-article-apply-patch-with-selected-destination (n)
|
|
"Apply a patch via the emacs diff-mode.
|
|
Allow to select the target directory from one of
|
|
`dvc-gnus-patch-desitination-candidates'."
|
|
(interactive "p")
|
|
(unless current-prefix-arg
|
|
(setq n 2))
|
|
(let ((dvc-gnus-override-window-config)
|
|
(dvc-gnus-select-patch-dir-function 'dvc-gnus-select-patch-destination))
|
|
(gnus-article-part-wrapper n 'dvc-gnus-apply-patch)
|
|
(when dvc-gnus-override-window-config
|
|
(set-window-configuration dvc-gnus-override-window-config))))
|
|
|
|
(defvar dvc-gnus-patch-desitination-candidates nil)
|
|
(defun dvc-gnus-select-patch-destination ()
|
|
(expand-file-name (dvc-completing-read "Patch destination: " dvc-gnus-patch-desitination-candidates)))
|
|
|
|
(defun dvc-gnus-article-view-missing ()
|
|
"Apply MIME part N, as patchset.
|
|
When called with no prefix arg, set N := 2.
|
|
First is checked, if it is a tla changeset created with DVC.
|
|
If that is the case, `tla-gnus-apply-patch' is called.
|
|
The next check is whether it is a patch suitable for xhg. In that case
|
|
`xhg-gnus-article-import-patch' is called.
|
|
Otherwise `dvc-gnus-apply-patch' is called."
|
|
(interactive)
|
|
(save-window-excursion
|
|
(gnus-summary-select-article-buffer)
|
|
(goto-char (point-min))
|
|
(goto-char (point-min))
|
|
(if (or (re-search-forward "^New revision in \\(.+\\)$" nil t)
|
|
(re-search-forward "^Committed revision [0-9]+ to \\(.+\\)$" nil t))
|
|
(let* ((bzr-missing-url (match-string-no-properties 1))
|
|
(dest (cdr (assoc bzr-missing-url bzr-merge-or-pull-from-url-rules)))
|
|
(path (cadr dest))
|
|
(doit t))
|
|
(when path
|
|
(setq doit (y-or-n-p (format "Run missing from %s in %s? " bzr-missing-url path))))
|
|
(when doit
|
|
(unless path
|
|
(setq path (dvc-read-directory-name (format "Run missing from %s in: " bzr-missing-url))))
|
|
(let ((default-directory path))
|
|
(message "Running bzr missing from %s in %s" bzr-missing-url path)
|
|
(bzr-missing bzr-missing-url)))))))
|
|
|
|
(defun dvc-gnus-article-view-patch (n)
|
|
"View MIME part N, as patchset.
|
|
When called with no prefix arg, set N := 2.
|
|
First is checked, if it is a tla changeset created with DVC.
|
|
If that is the case, `tla-gnus-article-view-patch' is called.
|
|
The next check looks at commit notification mails for bzr, when
|
|
such a message is detected, `bzr-gnus-article-view-patch' is called.
|
|
Otherwise `dvc-gnus-view-patch' is called."
|
|
(interactive "p")
|
|
(unless current-prefix-arg
|
|
(setq n 2))
|
|
(let ((patch-type))
|
|
(save-window-excursion
|
|
(gnus-summary-select-article-buffer)
|
|
(goto-char (point-min))
|
|
(if (or (re-search-forward (concat "\\[VERSION\\] " (tla-make-name-regexp 4 t t)) nil t)
|
|
(progn (goto-char (point-min))
|
|
(and (search-forward "Revision: " nil t)
|
|
(search-forward "Archive: " nil t))))
|
|
(setq patch-type 'tla)
|
|
(goto-char (point-min))
|
|
;; Committed revision 129 to http://my-arch.org/branch1
|
|
(if (re-search-forward "^Committed revision [0-9]+ to " nil t)
|
|
(setq patch-type 'bzr)
|
|
(setq patch-type 'dvc))))
|
|
(cond ((eq patch-type 'tla)
|
|
(tla-gnus-article-view-patch n))
|
|
((eq patch-type 'bzr)
|
|
(bzr-gnus-article-view-patch n))
|
|
(t
|
|
(let ((dvc-gnus-override-window-config))
|
|
(gnus-article-part-wrapper n 'dvc-gnus-view-patch)
|
|
(when dvc-gnus-override-window-config
|
|
(set-window-configuration dvc-gnus-override-window-config)))))))
|
|
|
|
(defvar dvc-apply-patch-mapping nil)
|
|
;;e.g.: (add-to-list 'dvc-apply-patch-mapping '("psvn" "~/work/myprg/psvn"))
|
|
|
|
(defun dvc-gnus-suggest-apply-patch-directory ()
|
|
"Use `dvc-apply-patch-mapping' to suggest a directory where
|
|
the patch sould be applied."
|
|
(if dvc-gnus-select-patch-dir-function
|
|
(funcall dvc-gnus-select-patch-dir-function)
|
|
(save-window-excursion
|
|
(gnus-summary-select-article-buffer)
|
|
(let ((patch-directory "~/")
|
|
(m dvc-apply-patch-mapping))
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(when (search-forward "text/x-patch; " nil t)
|
|
(while m
|
|
(if (looking-at (caar m))
|
|
(progn
|
|
(setq patch-directory (cadar m))
|
|
(setq m nil))
|
|
(setq m (cdr m))))))
|
|
(gnus-article-show-summary)
|
|
(expand-file-name patch-directory)))))
|
|
|
|
(defun dvc-gnus-apply-patch (handle)
|
|
"Apply the patch corresponding to HANDLE."
|
|
(dvc-gnus-article-extract-log-message)
|
|
(let ((dvc-patch-name (concat (dvc-make-temp-name "dvc-patch") ".diff"))
|
|
(window-conf (current-window-configuration))
|
|
(patch-buff))
|
|
(dvc-buffer-push-previous-window-config window-conf)
|
|
(mm-save-part-to-file handle dvc-patch-name)
|
|
(find-file dvc-patch-name)
|
|
(diff-mode)
|
|
(toggle-read-only 1)
|
|
(setq patch-buff (current-buffer))
|
|
(delete-other-windows)
|
|
(setq default-directory (dvc-gnus-suggest-apply-patch-directory))
|
|
;; 07.07.2008: applying with ediff only works well when only one file is given.
|
|
;; (flet ((ediff-get-default-file-name (&optional default) (if default default default-directory)))
|
|
;; (ediff-patch-file 2 patch-buff))
|
|
(diff-hunk-next)
|
|
(message "You can apply the patch hunks now by using C-c C-a.")
|
|
(setq dvc-gnus-override-window-config (current-window-configuration))))
|
|
|
|
(defun dvc-gnus-view-patch (handle)
|
|
"View the patch corresponding to HANDLE."
|
|
(let ((dvc-patch-name (concat (dvc-make-temp-name "dvc-patch") ".diff"))
|
|
(cur-buf (current-buffer))
|
|
(window-conf (current-window-configuration))
|
|
(patch-buff))
|
|
(mm-save-part-to-file handle dvc-patch-name)
|
|
(gnus-summary-select-article-buffer)
|
|
(split-window-vertically)
|
|
(find-file-other-window dvc-patch-name)
|
|
(diff-mode)
|
|
(setq dvc-gnus-override-window-config (current-window-configuration))
|
|
(dvc-buffer-push-previous-window-config window-conf)
|
|
(toggle-read-only 1)
|
|
(other-window -1)
|
|
(gnus-article-show-summary)))
|
|
|
|
(provide 'dvc-gnus)
|
|
;;; dvc-gnus.el ends here
|