Mercurial > emacs
comparison lisp/gnus-vm.el @ 13401:178d730efae2
entered into RCS
author | Lars Magne Ingebrigtsen <larsi@gnus.org> |
---|---|
date | Sat, 04 Nov 1995 03:54:42 +0000 |
parents | |
children | 83f275dcd93a |
comparison
equal
deleted
inserted
replaced
13400:4a57cda2a39a | 13401:178d730efae2 |
---|---|
1 ;;; gnus-vm.el --- vm interface for Gnus | |
2 ;; Copyright (C) 1994,95 Free Software Foundation, Inc. | |
3 | |
4 ;; Author: Per Persson <pp@solace.mh.se> | |
5 ;; Keywords: news, mail | |
6 | |
7 ;; This file is part of GNU Emacs. | |
8 | |
9 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 ;; it under the terms of the GNU General Public License as published by | |
11 ;; the Free Software Foundation; either version 2, or (at your option) | |
12 ;; any later version. | |
13 | |
14 ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 ;; GNU General Public License for more details. | |
18 | |
19 ;; You should have received a copy of the GNU General Public License | |
20 ;; along with GNU Emacs; see the file COPYING. If not, write to | |
21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
22 | |
23 ;;; Commentary: | |
24 | |
25 ;; Major contributors: | |
26 ;; Christian Limpach <Christian.Limpach@nice.ch> | |
27 ;; Some code stolen from: | |
28 ;; Rick Sladkey <jrs@world.std.com> | |
29 | |
30 ;;; Code: | |
31 | |
32 (require 'sendmail) | |
33 (require 'gnus) | |
34 (require 'gnus-msg) | |
35 | |
36 (eval-when-compile | |
37 (autoload 'vm-mode "vm") | |
38 (autoload 'vm-save-message "vm") | |
39 (autoload 'vm-forward-message "vm") | |
40 (autoload 'vm-reply "vm") | |
41 (autoload 'vm-mail "vm")) | |
42 | |
43 (defvar gnus-vm-inhibit-window-system nil | |
44 "Inhibit loading `win-vm' if using a window-system. | |
45 Has to be set before gnus-vm is loaded.") | |
46 | |
47 (or gnus-vm-inhibit-window-system | |
48 (condition-case nil | |
49 (if window-system | |
50 (require 'win-vm)) | |
51 (error nil))) | |
52 | |
53 (if (not (featurep 'vm)) | |
54 (load "vm")) | |
55 | |
56 (defun gnus-vm-make-folder (&optional buffer) | |
57 (let ((article (or buffer (current-buffer))) | |
58 (tmp-folder (generate-new-buffer " *tmp-folder*")) | |
59 (start (point-min)) | |
60 (end (point-max))) | |
61 (set-buffer tmp-folder) | |
62 (insert-buffer-substring article start end) | |
63 (goto-char (point-min)) | |
64 (if (looking-at "^\\(From [^ ]+ \\).*$") | |
65 (replace-match (concat "\\1" (current-time-string))) | |
66 (insert "From " gnus-newsgroup-name " " | |
67 (current-time-string) "\n")) | |
68 (while (re-search-forward "\n\nFrom " nil t) | |
69 (replace-match "\n\n>From ")) | |
70 ;; insert a newline, otherwise the last line gets lost | |
71 (goto-char (point-max)) | |
72 (insert "\n") | |
73 (vm-mode) | |
74 tmp-folder)) | |
75 | |
76 (defun gnus-summary-save-article-vm (&optional arg) | |
77 "Append the current article to a vm folder. | |
78 If N is a positive number, save the N next articles. | |
79 If N is a negative number, save the N previous articles. | |
80 If N is nil and any articles have been marked with the process mark, | |
81 save those articles instead." | |
82 (interactive "P") | |
83 (let ((gnus-default-article-saver 'gnus-summary-save-in-vm)) | |
84 (gnus-summary-save-article arg))) | |
85 | |
86 (defun gnus-summary-save-in-vm (&optional folder) | |
87 (interactive) | |
88 (let ((default-name | |
89 (funcall gnus-mail-save-name gnus-newsgroup-name | |
90 gnus-current-headers gnus-newsgroup-last-mail))) | |
91 (or folder | |
92 (setq folder | |
93 (read-file-name | |
94 (concat "Save article in VM folder: (default " | |
95 (file-name-nondirectory default-name) ") ") | |
96 (file-name-directory default-name) | |
97 default-name))) | |
98 (setq folder | |
99 (expand-file-name folder | |
100 (and default-name | |
101 (file-name-directory default-name)))) | |
102 (gnus-make-directory (file-name-directory folder)) | |
103 (set-buffer gnus-article-buffer) | |
104 (save-excursion | |
105 (save-restriction | |
106 (widen) | |
107 (let ((vm-folder (gnus-vm-make-folder))) | |
108 (vm-save-message folder) | |
109 (kill-buffer vm-folder)))) | |
110 ;; Remember the directory name to save articles. | |
111 (setq gnus-newsgroup-last-mail folder))) | |
112 | |
113 (defun gnus-mail-forward-using-vm (&optional buffer) | |
114 "Forward the current message to another user using vm." | |
115 (let* ((gnus-buffer (or buffer (current-buffer))) | |
116 (subject (gnus-forward-make-subject gnus-buffer))) | |
117 (or (featurep 'win-vm) | |
118 (if gnus-use-full-window | |
119 (pop-to-buffer gnus-article-buffer) | |
120 (switch-to-buffer gnus-article-buffer))) | |
121 (gnus-copy-article-buffer) | |
122 (set-buffer gnus-article-copy) | |
123 (save-excursion | |
124 (save-restriction | |
125 (widen) | |
126 (let ((vm-folder (gnus-vm-make-folder)) | |
127 (vm-forward-message-hook | |
128 (append (symbol-value 'vm-forward-message-hook) | |
129 '((lambda () | |
130 (save-excursion | |
131 (mail-position-on-field "Subject") | |
132 (beginning-of-line) | |
133 (looking-at "^\\(Subject: \\).*$") | |
134 (replace-match (concat "\\1" subject)))))))) | |
135 (vm-forward-message) | |
136 (gnus-vm-init-reply-buffer gnus-buffer) | |
137 (run-hooks 'gnus-mail-hook) | |
138 (kill-buffer vm-folder)))))) | |
139 | |
140 (defun gnus-vm-init-reply-buffer (buffer) | |
141 (make-local-variable 'gnus-summary-buffer) | |
142 (setq gnus-summary-buffer buffer) | |
143 (set 'vm-mail-buffer nil) | |
144 (use-local-map (copy-keymap (current-local-map))) | |
145 (local-set-key "\C-c\C-y" 'gnus-yank-article)) | |
146 | |
147 (defun gnus-mail-reply-using-vm (&optional yank) | |
148 "Compose reply mail using vm. | |
149 Optional argument YANK means yank original article. | |
150 The command \\[vm-yank-message] yank the original message into current buffer." | |
151 (let ((gnus-buffer (current-buffer))) | |
152 (gnus-copy-article-buffer) | |
153 (set-buffer gnus-article-copy) | |
154 (save-excursion | |
155 (save-restriction | |
156 (widen) | |
157 (let ((vm-folder (gnus-vm-make-folder gnus-article-copy))) | |
158 (vm-reply 1) | |
159 (gnus-vm-init-reply-buffer gnus-buffer) | |
160 (setq gnus-buffer (current-buffer)) | |
161 (and yank | |
162 ;; nil will (magically :-)) yank the current article | |
163 (gnus-yank-article nil)) | |
164 (kill-buffer vm-folder)))) | |
165 (if (featurep 'win-vm) nil | |
166 (pop-to-buffer gnus-buffer)) | |
167 (run-hooks 'gnus-mail-hook))) | |
168 | |
169 (defun gnus-mail-other-window-using-vm () | |
170 "Compose mail in the other window using VM." | |
171 (interactive) | |
172 (let ((gnus-buffer (current-buffer))) | |
173 (vm-mail) | |
174 (gnus-vm-init-reply-buffer gnus-buffer)) | |
175 (run-hooks 'gnus-mail-hook)) | |
176 | |
177 (defun gnus-yank-article (article &optional prefix) | |
178 ;; Based on vm-yank-message by Kyle Jones. | |
179 "Yank article number N into the current buffer at point. | |
180 When called interactively N is read from the minibuffer. | |
181 | |
182 This command is meant to be used in GNUS created Mail mode buffers; | |
183 the yanked article comes from the newsgroup containing the article | |
184 you are replying to or forwarding. | |
185 | |
186 All article headers are yanked along with the text. Point is left | |
187 before the inserted text, the mark after. Any hook functions bound to | |
188 `mail-citation-hook' are run, after inserting the text and setting | |
189 point and mark. | |
190 | |
191 Prefix arg means to ignore `mail-citation-hook', don't set the mark, | |
192 prepend the value of `vm-included-text-prefix' to every yanked line. | |
193 For backwards compatibility, if `mail-citation-hook' is set to nil, | |
194 `mail-yank-hooks' is run instead. If that is also nil, a default | |
195 action is taken." | |
196 (interactive | |
197 (list | |
198 (let ((result 0) | |
199 default prompt) | |
200 (setq default (and gnus-summary-buffer | |
201 (save-excursion | |
202 (set-buffer gnus-summary-buffer) | |
203 (and gnus-current-article | |
204 (int-to-string gnus-current-article)))) | |
205 prompt (if default | |
206 (format "Yank article number: (default %s) " default) | |
207 "Yank article number: ")) | |
208 (while (and (not (stringp result)) (zerop result)) | |
209 (setq result (read-string prompt)) | |
210 (and (string= result "") default (setq result default)) | |
211 (or (string-match "^<.*>$" result) | |
212 (setq result (string-to-int result)))) | |
213 result) | |
214 current-prefix-arg)) | |
215 (if gnus-summary-buffer | |
216 (save-excursion | |
217 (let ((message (current-buffer)) | |
218 (start (point)) end | |
219 (tmp (generate-new-buffer " *tmp-yank*"))) | |
220 (set-buffer gnus-summary-buffer) | |
221 ;; Make sure the connection to the server is alive. | |
222 (or (gnus-server-opened (gnus-find-method-for-group | |
223 gnus-newsgroup-name)) | |
224 (progn | |
225 (gnus-check-server | |
226 (gnus-find-method-for-group gnus-newsgroup-name)) | |
227 (gnus-request-group gnus-newsgroup-name t))) | |
228 (and (stringp article) | |
229 (let ((gnus-override-method gnus-refer-article-method)) | |
230 (gnus-read-header article))) | |
231 (gnus-request-article (or article | |
232 gnus-current-article) | |
233 gnus-newsgroup-name tmp) | |
234 (set-buffer tmp) | |
235 (run-hooks 'gnus-article-prepare-hook) | |
236 ;; Decode MIME message. | |
237 (if (and gnus-show-mime | |
238 (gnus-fetch-field "Mime-Version")) | |
239 (funcall gnus-show-mime-method)) | |
240 ;; Perform the article display hooks. | |
241 (let ((buffer-read-only nil)) | |
242 (run-hooks 'gnus-article-display-hook)) | |
243 (append-to-buffer message (point-min) (point-max)) | |
244 (kill-buffer tmp) | |
245 (set-buffer message) | |
246 (setq end (point)) | |
247 (goto-char start) | |
248 (if (or prefix | |
249 (not (or mail-citation-hook mail-yank-hooks))) | |
250 (save-excursion | |
251 (while (< (point) end) | |
252 (insert (symbol-value 'vm-included-text-prefix)) | |
253 (forward-line 1))) | |
254 (push-mark end) | |
255 (cond | |
256 (mail-citation-hook (run-hooks 'mail-citation-hook)) | |
257 (mail-yank-hooks (run-hooks 'mail-yank-hooks)))))))) | |
258 | |
259 (provide 'gnus-vm) | |
260 | |
261 ;;; gnus-vm.el ends here. |