X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-vm.el;h=3777a906d09944b8db9af6009466c4f92b9f3fa3;hp=842cee97228c9cecf577ee0a236265e12e5959d6;hb=997404c721a1de533aa9f82d4d5bbc5447bfc23d;hpb=a8951d79a6687b412f43ac1852b12342261c0dfd diff --git a/lisp/gnus-vm.el b/lisp/gnus-vm.el index 842cee972..3777a906d 100644 --- a/lisp/gnus-vm.el +++ b/lisp/gnus-vm.el @@ -1,15 +1,16 @@ ;;; gnus-vm.el --- vm interface for Gnus -;; Copyright (C) 1994,95 Free Software Foundation, Inc. -;; Author: Per Persson +;; Copyright (C) 1994-2015 Free Software Foundation, Inc. + +;; Author: Per Persson ;; Keywords: news, mail ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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 2, or (at your option) -;; any later version. +;; 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 @@ -17,43 +18,39 @@ ;; 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, 675 Mass Ave, Cambridge, MA 02139, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: -;; Major contributors: +;; Major contributors: ;; Christian Limpach -;; Some code stolen from: +;; Some code stolen from: ;; Rick Sladkey ;;; Code: (require 'sendmail) +(require 'message) (require 'gnus) (require 'gnus-msg) (eval-when-compile - (autoload 'vm-mode "vm") - (autoload 'vm-save-message "vm") - (autoload 'vm-forward-message "vm") - (autoload 'vm-reply "vm") - (autoload 'vm-mail "vm")) + (require 'cl)) + +(autoload 'vm-mode "vm") +(autoload 'vm-save-message "vm") (defvar gnus-vm-inhibit-window-system nil "Inhibit loading `win-vm' if using a window-system. Has to be set before gnus-vm is loaded.") -(or gnus-vm-inhibit-window-system - (condition-case nil - (if window-system - (require 'win-vm)) - (error nil))) - -(if (not (featurep 'vm)) - (load "vm")) +(unless gnus-vm-inhibit-window-system + (ignore-errors + (when window-system + (require 'win-vm)))) (defun gnus-vm-make-folder (&optional buffer) + (require 'vm) (let ((article (or buffer (current-buffer))) (tmp-folder (generate-new-buffer " *tmp-folder*")) (start (point-min)) @@ -72,186 +69,34 @@ Has to be set before gnus-vm is loaded.") (insert "\n") (vm-mode) tmp-folder)) - -(defun gnus-summary-save-article-vm (arg) + +(defun gnus-summary-save-article-vm (&optional arg) "Append the current article to a vm folder. If N is a positive number, save the N next articles. If N is a negative number, save the N previous articles. If N is nil and any articles have been marked with the process mark, save those articles instead." (interactive "P") + (require 'gnus-art) (let ((gnus-default-article-saver 'gnus-summary-save-in-vm)) (gnus-summary-save-article arg))) (defun gnus-summary-save-in-vm (&optional folder) (interactive) - (let ((default-name - (funcall gnus-mail-save-name gnus-newsgroup-name - gnus-current-headers gnus-newsgroup-last-mail))) - (or folder - (setq folder - (read-file-name - (concat "Save article in VM folder: (default " - (file-name-nondirectory default-name) ") ") - (file-name-directory default-name) - default-name))) - (setq folder - (expand-file-name folder - (and default-name - (file-name-directory default-name)))) - (gnus-make-directory (file-name-directory folder)) - (set-buffer gnus-article-buffer) + (require 'vm) + (setq folder + (gnus-read-save-file-name + "Save %s in VM folder:" folder + gnus-mail-save-name gnus-newsgroup-name + gnus-current-headers 'gnus-newsgroup-last-mail)) + (gnus-eval-in-buffer-window gnus-original-article-buffer (save-excursion (save-restriction (widen) (let ((vm-folder (gnus-vm-make-folder))) (vm-save-message folder) - (kill-buffer vm-folder)))) - ;; Remember the directory name to save articles. - (setq gnus-newsgroup-last-mail folder))) - -(defun gnus-mail-forward-using-vm (&optional buffer) - "Forward the current message to another user using vm." - (let ((gnus-buffer (or buffer (current-buffer))) - (subject (concat "[" gnus-newsgroup-name "] " - (or (gnus-fetch-field "Subject") "")))) - (or (featurep 'win-vm) - (if gnus-use-full-window - (pop-to-buffer gnus-article-buffer) - (switch-to-buffer gnus-article-buffer))) - (set-buffer gnus-article-buffer) - (save-excursion - (save-restriction - (widen) - (let ((vm-folder (gnus-vm-make-folder)) - (vm-forward-message-hook - (append (symbol-value 'vm-forward-message-hook) - '((lambda () - (save-excursion - (mail-position-on-field "Subject") - (beginning-of-line) - (looking-at "^\\(Subject: \\).*$") - (replace-match (concat "\\1" subject)))))))) - (vm-forward-message) - (gnus-vm-init-reply-buffer gnus-buffer) (kill-buffer vm-folder)))))) -(defun gnus-vm-init-reply-buffer (buffer) - (make-local-variable 'gnus-summary-buffer) - (setq gnus-summary-buffer buffer) - (set 'vm-mail-buffer nil) - (use-local-map (copy-keymap (current-local-map))) - (local-set-key "\C-c\C-y" 'gnus-yank-article)) - -(defun gnus-mail-reply-using-vm (&optional yank) - "Compose reply mail using vm. -Optional argument YANK means yank original article. -The command \\[vm-yank-message] yank the original message into current buffer." - (let ((gnus-buffer (current-buffer))) - (set-buffer gnus-article-buffer) - (save-excursion - (save-restriction - (widen) - (let ((vm-folder (gnus-vm-make-folder gnus-article-buffer))) - (vm-reply 1) - (gnus-vm-init-reply-buffer gnus-buffer) - (setq gnus-buffer (current-buffer)) - (and yank - ;; nil will (magically :-)) yank the current article - (gnus-yank-article nil)) - (kill-buffer vm-folder)))) - (if (featurep 'win-vm) nil - (pop-to-buffer gnus-buffer)))) - -(defun gnus-mail-other-window-using-vm () - "Compose mail in the other window using VM." - (interactive) - (let ((gnus-buffer (current-buffer))) - (vm-mail) - (gnus-vm-init-reply-buffer gnus-buffer))) - -(defun gnus-yank-article (article &optional prefix) - ;; Based on vm-yank-message by Kyle Jones. - "Yank article number N into the current buffer at point. -When called interactively N is read from the minibuffer. - -This command is meant to be used in GNUS created Mail mode buffers; -the yanked article comes from the newsgroup containing the article -you are replying to or forwarding. - -All article headers are yanked along with the text. Point is left -before the inserted text, the mark after. Any hook functions bound to -`mail-citation-hook' are run, after inserting the text and setting -point and mark. - -Prefix arg means to ignore `mail-citation-hook', don't set the mark, -prepend the value of `vm-included-text-prefix' to every yanked line. -For backwards compatibility, if `mail-citation-hook' is set to nil, -`mail-yank-hooks' is run instead. If that is also nil, a default -action is taken." - (interactive - (list - (let ((result 0) - default prompt) - (setq default (and gnus-summary-buffer - (save-excursion - (set-buffer gnus-summary-buffer) - (and gnus-current-article - (int-to-string gnus-current-article)))) - prompt (if default - (format "Yank article number: (default %s) " default) - "Yank article number: ")) - (while (and (not (stringp result)) (zerop result)) - (setq result (read-string prompt)) - (and (string= result "") default (setq result default)) - (or (string-match "^<.*>$" result) - (setq result (string-to-int result)))) - result) - current-prefix-arg)) - (if gnus-summary-buffer - (save-excursion - (let ((message (current-buffer)) - (start (point)) end - (tmp (generate-new-buffer " *tmp-yank*"))) - (set-buffer gnus-summary-buffer) - ;; Make sure the connection to the server is alive. - (or (gnus-server-opened (gnus-find-method-for-group - gnus-newsgroup-name)) - (progn - (gnus-check-news-server - (gnus-find-method-for-group gnus-newsgroup-name)) - (gnus-request-group gnus-newsgroup-name t))) - (and (stringp article) - (let ((gnus-override-method gnus-refer-article-method)) - (gnus-read-header article))) - (gnus-request-article (or article - gnus-current-article) - gnus-newsgroup-name tmp) - (set-buffer tmp) - (run-hooks 'gnus-article-prepare-hook) - ;; Decode MIME message. - (if (and gnus-show-mime - (gnus-fetch-field "Mime-Version")) - (funcall gnus-show-mime-method)) - ;; Perform the article display hooks. - (let ((buffer-read-only nil)) - (run-hooks 'gnus-article-display-hook)) - (append-to-buffer message (point-min) (point-max)) - (kill-buffer tmp) - (set-buffer message) - (setq end (point)) - (goto-char start) - (if (or prefix - (not (or mail-citation-hook mail-yank-hooks))) - (save-excursion - (while (< (point) end) - (insert (symbol-value 'vm-included-text-prefix)) - (forward-line 1))) - (push-mark end) - (cond - (mail-citation-hook (run-hooks 'mail-citation-hook)) - (mail-yank-hooks (run-hooks 'mail-yank-hooks)))))))) - (provide 'gnus-vm) -;;; gnus-vm.el ends here. +;;; gnus-vm.el ends here