145 lines
5.6 KiB
EmacsLisp
145 lines
5.6 KiB
EmacsLisp
;;; xhg-gnus.el --- dvc integration to gnus
|
|
|
|
;; Copyright (C) 2003-2007 by all contributors
|
|
|
|
;; Author: Stefan Reichoer, <stefan@xsteve.at>
|
|
;; Contributions from:
|
|
;; Matthieu Moy <Matthieu.Moy@imag.fr>
|
|
|
|
;; Xtla 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.
|
|
|
|
;; Xtla 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)))
|
|
|
|
;;;###autoload
|
|
(defun xhg-insinuate-gnus ()
|
|
"Integrate Xhg into Gnus.
|
|
The following keybindings are installed for gnus-summary:
|
|
K t s `xhg-gnus-article-view-status-for-import-patch'"
|
|
(interactive)
|
|
(dvc-gnus-initialize-keymap)
|
|
(define-key gnus-summary-dvc-submap [?s] 'xhg-gnus-article-view-status-for-import-patch)
|
|
)
|
|
|
|
(defvar xhg-apply-patch-mapping nil)
|
|
;;(add-to-list 'xhg-apply-patch-mapping '("my-wiki" "~/work/wiki/"))
|
|
|
|
(defvar xhg-gnus-patch-from-user nil)
|
|
|
|
(defvar xhg-gnus-import-patch-force nil)
|
|
(defun xhg-gnus-article-import-patch (n)
|
|
"Import MIME part N, as hg patch.
|
|
When N is negative, force applying the patch, even if there are
|
|
outstanding uncommitted changes."
|
|
(interactive "p")
|
|
(if (and (numberp n) (< n 0))
|
|
(progn
|
|
(setq xhg-gnus-import-patch-force t)
|
|
(setq n (- n)))
|
|
(setq xhg-gnus-import-patch-force nil))
|
|
(gnus-article-part-wrapper n 'xhg-gnus-import-patch))
|
|
|
|
(defun xhg-gnus-import-patch (handle)
|
|
"Import a hg patch via gnus. HANDLE should be the handle of the part."
|
|
(let ((patch-file-name (concat (dvc-make-temp-name "gnus-xhg-import-") ".patch"))
|
|
(window-conf (current-window-configuration))
|
|
(import-dir))
|
|
(gnus-summary-select-article-buffer)
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
;; handle does not seem to exist for text/x-patch ...
|
|
(when (re-search-forward "^user: +\\(.+\\)$" nil t)
|
|
(setq xhg-gnus-patch-from-user (match-string-no-properties 1))))
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
;; handle does not seem to exist for text/x-patch ...
|
|
(search-forward "text/x-patch; ")
|
|
(mm-save-part-to-file (get-text-property (point) 'gnus-data) patch-file-name)
|
|
(dolist (m xhg-apply-patch-mapping)
|
|
(when (looking-at (car m))
|
|
(setq import-dir (dvc-uniquify-file-name (cadr m))))))
|
|
(delete-other-windows)
|
|
(dvc-buffer-push-previous-window-config)
|
|
(find-file patch-file-name)
|
|
(setq import-dir (dvc-read-directory-name "Import hg patch to: " nil nil t import-dir))
|
|
(when import-dir
|
|
(let ((default-directory import-dir)
|
|
(current-dvc))
|
|
(setq current-dvc (dvc-current-active-dvc))
|
|
(case current-dvc
|
|
('xhg (xhg-import patch-file-name xhg-gnus-import-patch-force))
|
|
('xgit (xgit-apply-patch patch-file-name))
|
|
;; TODO Add here new backend
|
|
(t (error "Unknow backend")))))
|
|
(delete-file patch-file-name)
|
|
(kill-buffer (current-buffer)) ;; the patch file
|
|
(set-window-configuration window-conf)
|
|
(let ((default-directory import-dir)
|
|
(current-dvc))
|
|
(setq current-dvc (dvc-current-active-dvc))
|
|
(case current-dvc
|
|
;; TODO Add here new backend
|
|
('xhg (when (and import-dir (y-or-n-p "Run hg log in patched directory? "))
|
|
(xhg-log "tip" "-10")
|
|
(delete-other-windows)))
|
|
('xgit (when (and import-dir (y-or-n-p "Run xgit-status?"))
|
|
(xgit-status)))))))
|
|
|
|
|
|
(defvar xhg-gnus-status-window-configuration nil)
|
|
(defun xhg-gnus-article-view-status-for-import-patch (n)
|
|
"View the status for the repository, where MIME part N would be applied as hg patch.
|
|
|
|
Use the same logic as in `xhg-gnus-article-import-patch' to guess the repository path
|
|
via `xhg-apply-patch-mapping'."
|
|
(interactive "p")
|
|
(gnus-article-part-wrapper n 'xhg-gnus-view-status-for-import-patch)
|
|
(set-window-configuration xhg-gnus-status-window-configuration))
|
|
|
|
(defun xhg-gnus-view-status-for-import-patch (handle)
|
|
"View the status for a repository before applying a hg patch via gnus.
|
|
HANDLE should be the handle of the part."
|
|
(let ((window-conf (current-window-configuration))
|
|
(import-dir))
|
|
(gnus-summary-select-article-buffer)
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
;; handle does not seem to exist for text/x-patch ...
|
|
(search-forward "text/x-patch; ")
|
|
(dolist (m xhg-apply-patch-mapping)
|
|
(when (looking-at (car m))
|
|
(setq import-dir (dvc-uniquify-file-name (cadr m))))))
|
|
(unless import-dir ;; when we find the directory in xhg-apply-patch-mapping don't ask for confirmation
|
|
(setq import-dir (dvc-read-directory-name "View hg repository status for: " nil nil t import-dir)))
|
|
(let ((default-directory import-dir))
|
|
(xhg-dvc-status)
|
|
(delete-other-windows)
|
|
(setq xhg-gnus-status-window-configuration (current-window-configuration))
|
|
(dvc-buffer-push-previous-window-config window-conf))))
|
|
|
|
(provide 'xhg-gnus)
|
|
;;; xhg-gnus.el ends here
|