|
0
|
1 ;;; gnus-msg.el --- mail and post interface for Gnus
|
|
|
2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
|
|
|
3
|
|
|
4 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
|
|
|
5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
|
|
|
6 ;; Keywords: news
|
|
|
7
|
|
|
8 ;; This file is part of GNU Emacs.
|
|
|
9
|
|
|
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
|
11 ;; it under the terms of the GNU General Public License as published by
|
|
|
12 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
13 ;; any later version.
|
|
|
14
|
|
|
15 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
18 ;; GNU General Public License for more details.
|
|
|
19
|
|
|
20 ;; You should have received a copy of the GNU General Public License
|
|
|
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
|
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
|
23 ;; Boston, MA 02111-1307, USA.
|
|
|
24
|
|
|
25 ;;; Commentary:
|
|
|
26
|
|
|
27 ;;; Code:
|
|
|
28
|
|
|
29 (require 'gnus)
|
|
|
30 (require 'gnus-ems)
|
|
|
31 (require 'message)
|
|
|
32 (eval-when-compile (require 'cl))
|
|
|
33
|
|
|
34 ;; Added by Sudish Joseph <joseph@cis.ohio-state.edu>.
|
|
|
35 (defvar gnus-post-method nil
|
|
|
36 "*Preferred method for posting USENET news.
|
|
|
37 If this variable is nil, Gnus will use the current method to decide
|
|
|
38 which method to use when posting. If it is non-nil, it will override
|
|
|
39 the current method. This method will not be used in mail groups and
|
|
|
40 the like, only in \"real\" newsgroups.
|
|
|
41
|
|
|
42 The value must be a valid method as discussed in the documentation of
|
|
|
43 `gnus-select-method'. It can also be a list of methods. If that is
|
|
|
44 the case, the user will be queried for what select method to use when
|
|
|
45 posting.")
|
|
|
46
|
|
|
47 (defvar gnus-outgoing-message-group nil
|
|
|
48 "*All outgoing messages will be put in this group.
|
|
|
49 If you want to store all your outgoing mail and articles in the group
|
|
|
50 \"nnml:archive\", you set this variable to that value. This variable
|
|
|
51 can also be a list of group names.
|
|
|
52
|
|
|
53 If you want to have greater control over what group to put each
|
|
|
54 message in, you can set this variable to a function that checks the
|
|
|
55 current newsgroup name and then returns a suitable group name (or list
|
|
|
56 of names).")
|
|
|
57
|
|
|
58 (defvar gnus-mailing-list-groups nil
|
|
|
59 "*Regexp matching groups that are really mailing lists.
|
|
|
60 This is useful when you're reading a mailing list that has been
|
|
|
61 gatewayed to a newsgroup, and you want to followup to an article in
|
|
|
62 the group.")
|
|
|
63
|
|
|
64 (defvar gnus-sent-message-ids-file
|
|
|
65 (nnheader-concat gnus-directory "Sent-Message-IDs")
|
|
|
66 "File where Gnus saves a cache of sent message ids.")
|
|
|
67
|
|
|
68 (defvar gnus-sent-message-ids-length 1000
|
|
|
69 "The number of sent Message-IDs to save.")
|
|
|
70
|
|
|
71 ;;; Internal variables.
|
|
|
72
|
|
|
73 (defvar gnus-message-buffer "*Mail Gnus*")
|
|
|
74 (defvar gnus-article-copy nil)
|
|
|
75 (defvar gnus-last-posting-server nil)
|
|
|
76
|
|
|
77 (eval-and-compile
|
|
|
78 (autoload 'gnus-uu-post-news "gnus-uu" nil t)
|
|
|
79 (autoload 'news-setup "rnewspost")
|
|
|
80 (autoload 'news-reply-mode "rnewspost")
|
|
|
81 (autoload 'rmail-dont-reply-to "mail-utils")
|
|
|
82 (autoload 'rmail-output "rmailout"))
|
|
|
83
|
|
|
84
|
|
|
85 ;;;
|
|
|
86 ;;; Gnus Posting Functions
|
|
|
87 ;;;
|
|
|
88
|
|
|
89 (gnus-define-keys
|
|
|
90 (gnus-summary-send-map "S" gnus-summary-mode-map)
|
|
|
91 "p" gnus-summary-post-news
|
|
|
92 "f" gnus-summary-followup
|
|
|
93 "F" gnus-summary-followup-with-original
|
|
|
94 "c" gnus-summary-cancel-article
|
|
|
95 "s" gnus-summary-supersede-article
|
|
|
96 "r" gnus-summary-reply
|
|
|
97 "R" gnus-summary-reply-with-original
|
|
|
98 "m" gnus-summary-mail-other-window
|
|
|
99 "u" gnus-uu-post-news
|
|
|
100 "om" gnus-summary-mail-forward
|
|
|
101 "op" gnus-summary-post-forward
|
|
|
102 "Om" gnus-uu-digest-mail-forward
|
|
|
103 "Op" gnus-uu-digest-post-forward)
|
|
|
104
|
|
|
105 (gnus-define-keys
|
|
|
106 (gnus-send-bounce-map "D" gnus-summary-send-map)
|
|
|
107 "b" gnus-summary-resend-bounced-mail
|
|
|
108 ; "c" gnus-summary-send-draft
|
|
|
109 "r" gnus-summary-resend-message)
|
|
|
110
|
|
|
111 ;;; Internal functions.
|
|
|
112
|
|
|
113 (defvar gnus-article-reply nil)
|
|
|
114 (defmacro gnus-setup-message (config &rest forms)
|
|
|
115 (let ((winconf (make-symbol "winconf"))
|
|
|
116 (buffer (make-symbol "buffer"))
|
|
|
117 (article (make-symbol "article")))
|
|
|
118 `(let ((,winconf (current-window-configuration))
|
|
|
119 (,buffer (current-buffer))
|
|
|
120 (,article (and gnus-article-reply (gnus-summary-article-number)))
|
|
|
121 (message-header-setup-hook
|
|
|
122 (copy-sequence message-header-setup-hook)))
|
|
|
123 (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
|
|
|
124 (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
|
|
|
125 ,@forms
|
|
|
126 (gnus-inews-add-send-actions ,winconf ,buffer ,article)
|
|
|
127 (setq gnus-message-buffer (current-buffer))
|
|
|
128 (gnus-configure-windows ,config t))))
|
|
|
129
|
|
|
130 (defun gnus-inews-add-send-actions (winconf buffer article)
|
|
|
131 (gnus-make-local-hook 'message-sent-hook)
|
|
|
132 (gnus-add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t)
|
|
|
133 (setq message-post-method
|
|
|
134 `(lambda (arg)
|
|
|
135 (gnus-post-method arg ,gnus-newsgroup-name)))
|
|
|
136 (setq message-newsreader (setq message-mailer (gnus-extended-version)))
|
|
|
137 (message-add-action
|
|
|
138 `(set-window-configuration ,winconf) 'exit 'postpone 'kill)
|
|
|
139 (message-add-action
|
|
|
140 `(when (buffer-name ,buffer)
|
|
|
141 (save-excursion
|
|
|
142 (set-buffer ,buffer)
|
|
|
143 ,(when article
|
|
|
144 `(gnus-summary-mark-article-as-replied ,article))))
|
|
|
145 'send))
|
|
|
146
|
|
|
147 (put 'gnus-setup-message 'lisp-indent-function 1)
|
|
|
148 (put 'gnus-setup-message 'lisp-indent-hook 1)
|
|
|
149 (put 'gnus-setup-message 'edebug-form-spec '(form body))
|
|
|
150
|
|
|
151 ;;; Post news commands of Gnus group mode and summary mode
|
|
|
152
|
|
|
153 (defun gnus-group-mail ()
|
|
|
154 "Start composing a mail."
|
|
|
155 (interactive)
|
|
|
156 (gnus-setup-message 'message
|
|
|
157 (message-mail)))
|
|
|
158
|
|
|
159 (defun gnus-group-post-news (&optional arg)
|
|
|
160 "Start composing a news message.
|
|
|
161 If ARG, post to the group under point.
|
|
|
162 If ARG is 1, prompt for a group name."
|
|
|
163 (interactive "P")
|
|
|
164 ;; Bind this variable here to make message mode hooks
|
|
|
165 ;; work ok.
|
|
|
166 (let ((gnus-newsgroup-name
|
|
|
167 (if arg
|
|
|
168 (if (= 1 (prefix-numeric-value arg))
|
|
|
169 (completing-read "Newsgroup: " gnus-active-hashtb nil
|
|
|
170 (gnus-read-active-file-p))
|
|
|
171 (gnus-group-group-name))
|
|
|
172 "")))
|
|
|
173 (gnus-post-news 'post gnus-newsgroup-name)))
|
|
|
174
|
|
|
175 (defun gnus-summary-post-news ()
|
|
|
176 "Start composing a news message."
|
|
|
177 (interactive)
|
|
|
178 (gnus-set-global-variables)
|
|
|
179 (gnus-post-news 'post gnus-newsgroup-name))
|
|
|
180
|
|
|
181 (defun gnus-summary-followup (yank &optional force-news)
|
|
|
182 "Compose a followup to an article.
|
|
|
183 If prefix argument YANK is non-nil, original article is yanked automatically."
|
|
|
184 (interactive
|
|
|
185 (list (and current-prefix-arg
|
|
|
186 (gnus-summary-work-articles 1))))
|
|
|
187 (gnus-set-global-variables)
|
|
|
188 (when yank
|
|
|
189 (gnus-summary-goto-subject (car yank)))
|
|
|
190 (save-window-excursion
|
|
|
191 (gnus-summary-select-article))
|
|
|
192 (let ((headers (gnus-summary-article-header (gnus-summary-article-number)))
|
|
|
193 (gnus-newsgroup-name gnus-newsgroup-name))
|
|
|
194 ;; Send a followup.
|
|
|
195 (gnus-post-news nil gnus-newsgroup-name
|
|
|
196 headers gnus-article-buffer
|
|
|
197 yank nil force-news)))
|
|
|
198
|
|
|
199 (defun gnus-summary-followup-with-original (n &optional force-news)
|
|
|
200 "Compose a followup to an article and include the original article."
|
|
|
201 (interactive "P")
|
|
|
202 (gnus-summary-followup (gnus-summary-work-articles n) force-news))
|
|
|
203
|
|
|
204 (defun gnus-inews-yank-articles (articles)
|
|
|
205 (let (beg article)
|
|
|
206 (while (setq article (pop articles))
|
|
|
207 (save-window-excursion
|
|
|
208 (set-buffer gnus-summary-buffer)
|
|
|
209 (gnus-summary-select-article nil nil nil article)
|
|
|
210 (gnus-summary-remove-process-mark article))
|
|
|
211 (gnus-copy-article-buffer)
|
|
|
212 (let ((message-reply-buffer gnus-article-copy)
|
|
|
213 (message-reply-headers gnus-current-headers))
|
|
|
214 (message-yank-original)
|
|
|
215 (setq beg (or beg (mark t))))
|
|
|
216 (when articles (insert "\n")))
|
|
|
217
|
|
|
218 (push-mark)
|
|
|
219 (goto-char beg)))
|
|
|
220
|
|
|
221 (defun gnus-summary-cancel-article (n)
|
|
|
222 "Cancel an article you posted."
|
|
|
223 (interactive "P")
|
|
|
224 (gnus-set-global-variables)
|
|
|
225 (let ((articles (gnus-summary-work-articles n))
|
|
|
226 (message-post-method
|
|
|
227 `(lambda (arg)
|
|
|
228 (gnus-post-method nil ,gnus-newsgroup-name)))
|
|
|
229 article)
|
|
|
230 (while (setq article (pop articles))
|
|
|
231 (when (gnus-summary-select-article t nil nil article)
|
|
|
232 (when (gnus-eval-in-buffer-window
|
|
|
233 gnus-original-article-buffer (message-cancel-news))
|
|
|
234 (gnus-summary-mark-as-read article gnus-canceled-mark)
|
|
|
235 (gnus-cache-remove-article 1))
|
|
|
236 (gnus-article-hide-headers-if-wanted))
|
|
|
237 (gnus-summary-remove-process-mark article))))
|
|
|
238
|
|
|
239 (defun gnus-summary-supersede-article ()
|
|
|
240 "Compose an article that will supersede a previous article.
|
|
|
241 This is done simply by taking the old article and adding a Supersedes
|
|
|
242 header line with the old Message-ID."
|
|
|
243 (interactive)
|
|
|
244 (gnus-set-global-variables)
|
|
|
245 (let ((article (gnus-summary-article-number)))
|
|
|
246 (gnus-setup-message 'reply-yank
|
|
|
247 (gnus-summary-select-article t)
|
|
|
248 (set-buffer gnus-original-article-buffer)
|
|
|
249 (message-supersede)
|
|
|
250 (push
|
|
|
251 `((lambda ()
|
|
|
252 (gnus-cache-possibly-remove-article ,article nil nil nil t)))
|
|
|
253 message-send-actions))))
|
|
|
254
|
|
|
255
|
|
|
256
|
|
|
257 (defun gnus-copy-article-buffer (&optional article-buffer)
|
|
|
258 ;; make a copy of the article buffer with all text properties removed
|
|
|
259 ;; this copy is in the buffer gnus-article-copy.
|
|
|
260 ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
|
|
|
261 ;; this buffer should be passed to all mail/news reply/post routines.
|
|
|
262 (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
|
|
|
263 (buffer-disable-undo gnus-article-copy)
|
|
|
264 (or (memq gnus-article-copy gnus-buffer-list)
|
|
|
265 (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
|
|
|
266 (let ((article-buffer (or article-buffer gnus-article-buffer))
|
|
|
267 end beg contents)
|
|
|
268 (when (and (get-buffer article-buffer)
|
|
|
269 (buffer-name (get-buffer article-buffer)))
|
|
|
270 (save-excursion
|
|
|
271 (set-buffer article-buffer)
|
|
|
272 (save-restriction
|
|
|
273 (widen)
|
|
|
274 (setq contents (format "%s" (buffer-string)))
|
|
|
275 (set-buffer gnus-original-article-buffer)
|
|
|
276 (goto-char (point-min))
|
|
|
277 (while (looking-at message-unix-mail-delimiter)
|
|
|
278 (forward-line 1))
|
|
|
279 (setq beg (point))
|
|
|
280 (setq end (or (search-forward "\n\n" nil t) (point)))
|
|
|
281 (set-buffer gnus-article-copy)
|
|
|
282 (erase-buffer)
|
|
|
283 (insert contents)
|
|
|
284 (delete-region (goto-char (point-min))
|
|
|
285 (or (search-forward "\n\n" nil t) (point)))
|
|
|
286 (insert-buffer-substring gnus-original-article-buffer beg end)))
|
|
|
287 gnus-article-copy)))
|
|
|
288
|
|
|
289 (defun gnus-post-news (post &optional group header article-buffer yank subject
|
|
|
290 force-news)
|
|
|
291 (when article-buffer
|
|
|
292 (gnus-copy-article-buffer))
|
|
|
293 (let ((gnus-article-reply article-buffer))
|
|
|
294 (gnus-setup-message (cond (yank 'reply-yank)
|
|
|
295 (article-buffer 'reply)
|
|
|
296 (t 'message))
|
|
|
297 (let* ((group (or group gnus-newsgroup-name))
|
|
|
298 (pgroup group)
|
|
|
299 to-address to-group mailing-list to-list)
|
|
|
300 (when group
|
|
|
301 (setq to-address (gnus-group-get-parameter group 'to-address)
|
|
|
302 to-group (gnus-group-get-parameter group 'to-group)
|
|
|
303 to-list (gnus-group-get-parameter group 'to-list)
|
|
|
304 mailing-list (when gnus-mailing-list-groups
|
|
|
305 (string-match gnus-mailing-list-groups group))
|
|
|
306 group (gnus-group-real-name group)))
|
|
|
307 (if (or (and to-group
|
|
|
308 (gnus-news-group-p to-group))
|
|
|
309 force-news
|
|
|
310 (and (gnus-news-group-p
|
|
|
311 (or pgroup gnus-newsgroup-name)
|
|
|
312 (if header (mail-header-number header)
|
|
|
313 gnus-current-article))
|
|
|
314 (not mailing-list)
|
|
|
315 (not to-list)
|
|
|
316 (not to-address)))
|
|
|
317 ;; This is news.
|
|
|
318 (if post
|
|
|
319 (message-news (or to-group group))
|
|
|
320 (set-buffer gnus-article-copy)
|
|
|
321 (message-followup))
|
|
|
322 ;; The is mail.
|
|
|
323 (if post
|
|
|
324 (progn
|
|
|
325 (message-mail (or to-address to-list))
|
|
|
326 ;; Arrange for mail groups that have no `to-address' to
|
|
|
327 ;; get that when the user sends off the mail.
|
|
|
328 (push (list 'gnus-inews-add-to-address group)
|
|
|
329 message-send-actions))
|
|
|
330 (set-buffer gnus-article-copy)
|
|
|
331 (message-wide-reply to-address)))
|
|
|
332 (when yank
|
|
|
333 (gnus-inews-yank-articles yank))))))
|
|
|
334
|
|
|
335 (defun gnus-post-method (arg group &optional silent)
|
|
|
336 "Return the posting method based on GROUP and ARG.
|
|
|
337 If SILENT, don't prompt the user."
|
|
|
338 (let ((group-method (gnus-find-method-for-group group)))
|
|
|
339 (cond
|
|
|
340 ;; If the group-method is nil (which shouldn't happen) we use
|
|
|
341 ;; the default method.
|
|
|
342 ((null arg)
|
|
|
343 (or gnus-post-method gnus-select-method message-post-method))
|
|
|
344 ;; We want this group's method.
|
|
|
345 ((and arg (not (eq arg 0)))
|
|
|
346 group-method)
|
|
|
347 ;; We query the user for a post method.
|
|
|
348 ((or arg
|
|
|
349 (and gnus-post-method
|
|
|
350 (listp (car gnus-post-method))))
|
|
|
351 (let* ((methods
|
|
|
352 ;; Collect all methods we know about.
|
|
|
353 (append
|
|
|
354 (when gnus-post-method
|
|
|
355 (if (listp (car gnus-post-method))
|
|
|
356 gnus-post-method
|
|
|
357 (list gnus-post-method)))
|
|
|
358 gnus-secondary-select-methods
|
|
|
359 (list gnus-select-method)
|
|
|
360 (list group-method)))
|
|
|
361 method-alist post-methods method)
|
|
|
362 ;; Weed out all mail methods.
|
|
|
363 (while methods
|
|
|
364 (setq method (gnus-server-get-method "" (pop methods)))
|
|
|
365 (when (or (gnus-method-option-p method 'post)
|
|
|
366 (gnus-method-option-p method 'post-mail))
|
|
|
367 (push method post-methods)))
|
|
|
368 ;; Create a name-method alist.
|
|
|
369 (setq method-alist
|
|
|
370 (mapcar
|
|
|
371 (lambda (m)
|
|
|
372 (list (concat (cadr m) " (" (symbol-name (car m)) ")") m))
|
|
|
373 post-methods))
|
|
|
374 ;; Query the user.
|
|
|
375 (cadr
|
|
|
376 (assoc
|
|
|
377 (setq gnus-last-posting-server
|
|
|
378 (if (and silent
|
|
|
379 gnus-last-posting-server)
|
|
|
380 ;; Just use the last value.
|
|
|
381 gnus-last-posting-server
|
|
|
382 (completing-read
|
|
|
383 "Posting method: " method-alist nil t
|
|
|
384 (cons (or gnus-last-posting-server "") 0))))
|
|
|
385 method-alist))))
|
|
|
386 ;; Override normal method.
|
|
|
387 ((and gnus-post-method
|
|
|
388 (or (gnus-method-option-p group-method 'post)
|
|
|
389 (gnus-method-option-p group-method 'post-mail)))
|
|
|
390 gnus-post-method)
|
|
|
391 ;; Perhaps this is a mail group?
|
|
|
392 ((and (not (gnus-member-of-valid 'post group))
|
|
|
393 (not (gnus-method-option-p group-method 'post-mail)))
|
|
|
394 group-method)
|
|
|
395 ;; Use the normal select method.
|
|
|
396 (t gnus-select-method))))
|
|
|
397
|
|
|
398 (defun gnus-inews-narrow-to-headers ()
|
|
|
399 (widen)
|
|
|
400 (narrow-to-region
|
|
|
401 (goto-char (point-min))
|
|
|
402 (or (and (re-search-forward
|
|
|
403 (concat "^" (regexp-quote mail-header-separator) "$") nil t)
|
|
|
404 (match-beginning 0))
|
|
|
405 (point-max)))
|
|
|
406 (goto-char (point-min)))
|
|
|
407
|
|
|
408 ;;;
|
|
|
409 ;;; Check whether the message has been sent already.
|
|
|
410 ;;;
|
|
|
411
|
|
|
412 (defvar gnus-inews-sent-ids nil)
|
|
|
413
|
|
|
414 (defun gnus-inews-reject-message ()
|
|
|
415 "Check whether this message has already been sent."
|
|
|
416 (when gnus-sent-message-ids-file
|
|
|
417 (let ((message-id (save-restriction (gnus-inews-narrow-to-headers)
|
|
|
418 (mail-fetch-field "message-id")))
|
|
|
419 end)
|
|
|
420 (when message-id
|
|
|
421 (unless gnus-inews-sent-ids
|
|
|
422 (condition-case ()
|
|
|
423 (load t t t)
|
|
|
424 (error nil)))
|
|
|
425 (if (member message-id gnus-inews-sent-ids)
|
|
|
426 ;; Reject this message.
|
|
|
427 (not (gnus-yes-or-no-p
|
|
|
428 (format "Message %s already sent. Send anyway? "
|
|
|
429 message-id)))
|
|
|
430 (push message-id gnus-inews-sent-ids)
|
|
|
431 ;; Chop off the last Message-IDs.
|
|
|
432 (when (setq end (nthcdr gnus-sent-message-ids-length
|
|
|
433 gnus-inews-sent-ids))
|
|
|
434 (setcdr end nil))
|
|
|
435 (nnheader-temp-write gnus-sent-message-ids-file
|
|
|
436 (prin1 `(setq gnus-inews-sent-ids ',gnus-inews-sent-ids)
|
|
|
437 (current-buffer)))
|
|
|
438 nil)))))
|
|
|
439
|
|
|
440
|
|
|
441
|
|
|
442 ;; Dummy to avoid byte-compile warning.
|
|
|
443 (defvar nnspool-rejected-article-hook)
|
|
|
444
|
|
|
445 ;;; Since the X-Newsreader/X-Mailer are ``vanity'' headers, they might
|
|
|
446 ;;; as well include the Emacs version as well.
|
|
|
447 ;;; The following function works with later GNU Emacs, and XEmacs.
|
|
|
448 (defun gnus-extended-version ()
|
|
|
449 "Stringified Gnus version and Emacs version"
|
|
|
450 (interactive)
|
|
|
451 (concat
|
|
|
452 gnus-version
|
|
|
453 "/"
|
|
|
454 (cond
|
|
|
455 ((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version)
|
|
|
456 (concat "Emacs " (substring emacs-version
|
|
|
457 (match-beginning 1)
|
|
|
458 (match-end 1))))
|
|
|
459 ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)" emacs-version)
|
|
|
460 (concat (substring emacs-version
|
|
|
461 (match-beginning 1)
|
|
|
462 (match-end 1))
|
|
|
463 (format " %d.%d" emacs-major-version emacs-minor-version)))
|
|
|
464 (t emacs-version))))
|
|
|
465
|
|
|
466 ;; Written by "Mr. Per Persson" <pp@solace.mh.se>.
|
|
|
467 (defun gnus-inews-insert-mime-headers ()
|
|
|
468 (goto-char (point-min))
|
|
|
469 (let ((mail-header-separator
|
|
|
470 (progn
|
|
|
471 (goto-char (point-min))
|
|
|
472 (if (and (search-forward (concat "\n" mail-header-separator "\n")
|
|
|
473 nil t)
|
|
|
474 (not (search-backward "\n\n" nil t)))
|
|
|
475 mail-header-separator
|
|
|
476 ""))))
|
|
|
477 (or (mail-position-on-field "Mime-Version")
|
|
|
478 (insert "1.0")
|
|
|
479 (cond ((save-restriction
|
|
|
480 (widen)
|
|
|
481 (goto-char (point-min))
|
|
|
482 (re-search-forward "[\200-\377]" nil t))
|
|
|
483 (or (mail-position-on-field "Content-Type")
|
|
|
484 (insert "text/plain; charset=ISO-8859-1"))
|
|
|
485 (or (mail-position-on-field "Content-Transfer-Encoding")
|
|
|
486 (insert "8bit")))
|
|
|
487 (t (or (mail-position-on-field "Content-Type")
|
|
|
488 (insert "text/plain; charset=US-ASCII"))
|
|
|
489 (or (mail-position-on-field "Content-Transfer-Encoding")
|
|
|
490 (insert "7bit")))))))
|
|
|
491
|
|
|
492
|
|
|
493 ;;;
|
|
|
494 ;;; Gnus Mail Functions
|
|
|
495 ;;;
|
|
|
496
|
|
|
497 ;;; Mail reply commands of Gnus summary mode
|
|
|
498
|
|
|
499 (defun gnus-summary-reply (&optional yank)
|
|
|
500 "Reply mail to news author.
|
|
|
501 If prefix argument YANK is non-nil, original article is yanked automatically."
|
|
|
502 (interactive
|
|
|
503 (list (and current-prefix-arg
|
|
|
504 (gnus-summary-work-articles 1))))
|
|
|
505 ;; Bug fix by jbw@bigbird.bu.edu (Joe Wells)
|
|
|
506 ;; Stripping headers should be specified with mail-yank-ignored-headers.
|
|
|
507 (gnus-set-global-variables)
|
|
|
508 (when yank
|
|
|
509 (gnus-summary-goto-subject (car yank)))
|
|
|
510 (let ((gnus-article-reply t))
|
|
|
511 (gnus-setup-message (if yank 'reply-yank 'reply)
|
|
|
512 (gnus-summary-select-article)
|
|
|
513 (set-buffer (gnus-copy-article-buffer))
|
|
|
514 (message-reply nil nil (gnus-group-get-parameter
|
|
|
515 gnus-newsgroup-name 'broken-reply-to))
|
|
|
516 (when yank
|
|
|
517 (gnus-inews-yank-articles yank)))))
|
|
|
518
|
|
|
519 (defun gnus-summary-reply-with-original (n)
|
|
|
520 "Reply mail to news author with original article."
|
|
|
521 (interactive "P")
|
|
|
522 (gnus-summary-reply (gnus-summary-work-articles n)))
|
|
|
523
|
|
|
524 (defun gnus-summary-mail-forward (&optional post)
|
|
|
525 "Forward the current message to another user."
|
|
|
526 (interactive "P")
|
|
|
527 (gnus-set-global-variables)
|
|
|
528 (gnus-setup-message 'forward
|
|
|
529 (gnus-summary-select-article)
|
|
|
530 (set-buffer gnus-original-article-buffer)
|
|
|
531 (message-forward post)))
|
|
|
532
|
|
|
533 (defun gnus-summary-resend-message (address)
|
|
|
534 "Resend the current article to ADDRESS."
|
|
|
535 (interactive "sResend message to: ")
|
|
|
536 (gnus-summary-select-article)
|
|
|
537 (save-excursion
|
|
|
538 (set-buffer gnus-original-article-buffer)
|
|
|
539 (message-resend address)))
|
|
|
540
|
|
|
541 (defun gnus-summary-post-forward ()
|
|
|
542 "Forward the current article to a newsgroup."
|
|
|
543 (interactive)
|
|
|
544 (gnus-summary-mail-forward t))
|
|
|
545
|
|
|
546 (defvar gnus-nastygram-message
|
|
|
547 "The following article was inappropriately posted to %s.\n"
|
|
|
548 "Format string to insert in nastygrams.
|
|
|
549 The current group name will be inserted at \"%s\".")
|
|
|
550
|
|
|
551 (defun gnus-summary-mail-nastygram (n)
|
|
|
552 "Send a nastygram to the author of the current article."
|
|
|
553 (interactive "P")
|
|
|
554 (if (or gnus-expert-user
|
|
|
555 (gnus-y-or-n-p
|
|
|
556 "Really send a nastygram to the author of the current article? "))
|
|
|
557 (let ((group gnus-newsgroup-name))
|
|
|
558 (gnus-summary-reply-with-original n)
|
|
|
559 (set-buffer gnus-message-buffer)
|
|
|
560 (insert (format gnus-nastygram-message group))
|
|
|
561 (message-send-and-exit))))
|
|
|
562
|
|
|
563 (defun gnus-summary-mail-other-window ()
|
|
|
564 "Compose mail in other window."
|
|
|
565 (interactive)
|
|
|
566 (gnus-setup-message 'message
|
|
|
567 (message-mail)))
|
|
|
568
|
|
|
569 (defun gnus-mail-parse-comma-list ()
|
|
|
570 (let (accumulated
|
|
|
571 beg)
|
|
|
572 (skip-chars-forward " ")
|
|
|
573 (while (not (eobp))
|
|
|
574 (setq beg (point))
|
|
|
575 (skip-chars-forward "^,")
|
|
|
576 (while (zerop
|
|
|
577 (save-excursion
|
|
|
578 (save-restriction
|
|
|
579 (let ((i 0))
|
|
|
580 (narrow-to-region beg (point))
|
|
|
581 (goto-char beg)
|
|
|
582 (logand (progn
|
|
|
583 (while (search-forward "\"" nil t)
|
|
|
584 (incf i))
|
|
|
585 (if (zerop i) 2 i)) 2)))))
|
|
|
586 (skip-chars-forward ",")
|
|
|
587 (skip-chars-forward "^,"))
|
|
|
588 (skip-chars-backward " ")
|
|
|
589 (setq accumulated
|
|
|
590 (cons (buffer-substring beg (point))
|
|
|
591 accumulated))
|
|
|
592 (skip-chars-forward "^,")
|
|
|
593 (skip-chars-forward ", "))
|
|
|
594 accumulated))
|
|
|
595
|
|
|
596 (defun gnus-mail-yank-original ()
|
|
|
597 (interactive)
|
|
|
598 (save-excursion
|
|
|
599 (mail-yank-original nil))
|
|
|
600 (or mail-yank-hooks mail-citation-hook
|
|
|
601 (run-hooks 'news-reply-header-hook)))
|
|
|
602
|
|
|
603 (defun gnus-inews-add-to-address (group)
|
|
|
604 (let ((to-address (mail-fetch-field "to")))
|
|
|
605 (when (and to-address
|
|
|
606 (gnus-alive-p))
|
|
|
607 ;; This mail group doesn't have a `to-list', so we add one
|
|
|
608 ;; here. Magic!
|
|
|
609 (gnus-group-add-parameter group (cons 'to-list to-address)))))
|
|
|
610
|
|
|
611 (defun gnus-put-message ()
|
|
|
612 "Put the current message in some group and return to Gnus."
|
|
|
613 (interactive)
|
|
|
614 (let ((reply gnus-article-reply)
|
|
|
615 (winconf gnus-prev-winconf)
|
|
|
616 (group gnus-newsgroup-name))
|
|
|
617
|
|
|
618 (or (and group (not (gnus-group-read-only-p group)))
|
|
|
619 (setq group (read-string "Put in group: " nil
|
|
|
620 (gnus-writable-groups))))
|
|
|
621 (and (gnus-gethash group gnus-newsrc-hashtb)
|
|
|
622 (error "No such group: %s" group))
|
|
|
623
|
|
|
624 (save-excursion
|
|
|
625 (save-restriction
|
|
|
626 (widen)
|
|
|
627 (gnus-inews-narrow-to-headers)
|
|
|
628 (let (gnus-deletable-headers)
|
|
|
629 (if (message-news-p)
|
|
|
630 (message-generate-headers message-required-news-headers)
|
|
|
631 (message-generate-headers message-required-mail-headers)))
|
|
|
632 (goto-char (point-max))
|
|
|
633 (insert "Gcc: " group "\n")
|
|
|
634 (widen)))
|
|
|
635
|
|
|
636 (gnus-inews-do-gcc)
|
|
|
637
|
|
|
638 (if (get-buffer gnus-group-buffer)
|
|
|
639 (progn
|
|
|
640 (if (gnus-buffer-exists-p (car-safe reply))
|
|
|
641 (progn
|
|
|
642 (set-buffer (car reply))
|
|
|
643 (and (cdr reply)
|
|
|
644 (gnus-summary-mark-article-as-replied
|
|
|
645 (cdr reply)))))
|
|
|
646 (and winconf (set-window-configuration winconf))))))
|
|
|
647
|
|
|
648 (defun gnus-article-mail (yank)
|
|
|
649 "Send a reply to the address near point.
|
|
|
650 If YANK is non-nil, include the original article."
|
|
|
651 (interactive "P")
|
|
|
652 (let ((address
|
|
|
653 (buffer-substring
|
|
|
654 (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point)))
|
|
|
655 (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point))))))
|
|
|
656 (when address
|
|
|
657 (message-reply address)
|
|
|
658 (when yank
|
|
2
|
659 (gnus-inews-yank-articles (list (cdr gnus-article-current)))))))
|
|
0
|
660
|
|
|
661 (defun gnus-bug ()
|
|
|
662 "Send a bug report to the Gnus maintainers."
|
|
|
663 (interactive)
|
|
|
664 (gnus-setup-message 'bug
|
|
|
665 (delete-other-windows)
|
|
|
666 (switch-to-buffer "*Gnus Help Bug*")
|
|
|
667 (erase-buffer)
|
|
|
668 (insert gnus-bug-message)
|
|
|
669 (goto-char (point-min))
|
|
|
670 (message-pop-to-buffer "*Gnus Bug*")
|
|
|
671 (message-setup `((To . ,gnus-maintainer) (Subject . "")))
|
|
|
672 (push `(gnus-bug-kill-buffer) message-send-actions)
|
|
|
673 (goto-char (point-min))
|
|
|
674 (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
|
|
|
675 (forward-line 1)
|
|
|
676 (insert (gnus-version) "\n")
|
|
|
677 (insert (emacs-version))
|
|
|
678 (insert "\n\n\n\n\n")
|
|
|
679 (gnus-debug)
|
|
|
680 (goto-char (point-min))
|
|
|
681 (search-forward "Subject: " nil t)
|
|
|
682 (message "")))
|
|
|
683
|
|
|
684 (defun gnus-bug-kill-buffer ()
|
|
|
685 (and (get-buffer "*Gnus Help Bug*")
|
|
|
686 (kill-buffer "*Gnus Help Bug*")))
|
|
|
687
|
|
|
688 (defun gnus-debug ()
|
|
|
689 "Attemps to go through the Gnus source file and report what variables have been changed.
|
|
|
690 The source file has to be in the Emacs load path."
|
|
|
691 (interactive)
|
|
|
692 (let ((files '("gnus.el" "gnus-msg.el" "gnus-score.el" "nnmail.el"
|
|
|
693 "message.el"))
|
|
|
694 file dirs expr olist sym)
|
|
|
695 (gnus-message 4 "Please wait while we snoop your variables...")
|
|
|
696 (sit-for 0)
|
|
|
697 (save-excursion
|
|
|
698 (set-buffer (get-buffer-create " *gnus bug info*"))
|
|
|
699 (buffer-disable-undo (current-buffer))
|
|
|
700 (while files
|
|
|
701 (erase-buffer)
|
|
|
702 (setq dirs load-path)
|
|
|
703 (while dirs
|
|
|
704 (if (or (not (car dirs))
|
|
|
705 (not (stringp (car dirs)))
|
|
|
706 (not (file-exists-p
|
|
|
707 (setq file (concat (file-name-as-directory
|
|
|
708 (car dirs)) (car files))))))
|
|
|
709 (setq dirs (cdr dirs))
|
|
|
710 (setq dirs nil)
|
|
|
711 (insert-file-contents file)
|
|
|
712 (goto-char (point-min))
|
|
|
713 (if (not (re-search-forward "^;;* *Internal variables" nil t))
|
|
|
714 (gnus-message 4 "Malformed sources in file %s" file)
|
|
|
715 (narrow-to-region (point-min) (point))
|
|
|
716 (goto-char (point-min))
|
|
|
717 (while (setq expr (condition-case ()
|
|
|
718 (read (current-buffer)) (error nil)))
|
|
|
719 (condition-case ()
|
|
|
720 (and (eq (car expr) 'defvar)
|
|
|
721 (stringp (nth 3 expr))
|
|
|
722 (or (not (boundp (nth 1 expr)))
|
|
|
723 (not (equal (eval (nth 2 expr))
|
|
|
724 (symbol-value (nth 1 expr)))))
|
|
|
725 (setq olist (cons (nth 1 expr) olist)))
|
|
|
726 (error nil))))))
|
|
|
727 (setq files (cdr files)))
|
|
|
728 (kill-buffer (current-buffer)))
|
|
|
729 (when (setq olist (nreverse olist))
|
|
|
730 (insert "------------------ Environment follows ------------------\n\n"))
|
|
|
731 (while olist
|
|
|
732 (if (boundp (car olist))
|
|
|
733 (condition-case ()
|
|
|
734 (pp `(setq ,(car olist)
|
|
|
735 ,(if (or (consp (setq sym (symbol-value (car olist))))
|
|
|
736 (and (symbolp sym)
|
|
|
737 (not (or (eq sym nil)
|
|
|
738 (eq sym t)))))
|
|
|
739 (list 'quote (symbol-value (car olist)))
|
|
|
740 (symbol-value (car olist))))
|
|
|
741 (current-buffer))
|
|
|
742 (error
|
|
|
743 (format "(setq %s 'whatever)\n" (car olist))))
|
|
|
744 (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))
|
|
|
745 (setq olist (cdr olist)))
|
|
|
746 (insert "\n\n")
|
|
|
747 ;; Remove any null chars - they seem to cause trouble for some
|
|
|
748 ;; mailers. (Byte-compiled output from the stuff above.)
|
|
|
749 (goto-char (point-min))
|
|
|
750 (while (re-search-forward "[\000\200]" nil t)
|
|
|
751 (replace-match "" t t))))
|
|
|
752
|
|
|
753 ;;; Treatment of rejected articles.
|
|
|
754 ;;; Bounced mail.
|
|
|
755
|
|
|
756 (defun gnus-summary-resend-bounced-mail (&optional fetch)
|
|
|
757 "Re-mail the current message.
|
|
|
758 This only makes sense if the current message is a bounce message than
|
|
|
759 contains some mail you have written which has been bounced back to
|
|
|
760 you.
|
|
|
761 If FETCH, try to fetch the article that this is a reply to, if indeed
|
|
|
762 this is a reply."
|
|
|
763 (interactive "P")
|
|
|
764 (gnus-summary-select-article t)
|
|
|
765 (set-buffer gnus-original-article-buffer)
|
|
|
766 (gnus-setup-message 'compose-bounce
|
|
|
767 (let* ((references (mail-fetch-field "references"))
|
|
|
768 (parent (and references (gnus-parent-id references))))
|
|
|
769 (message-bounce)
|
|
|
770 ;; If there are references, we fetch the article we answered to.
|
|
|
771 (and fetch parent
|
|
|
772 (gnus-summary-refer-article parent)
|
|
|
773 (gnus-summary-show-all-headers)))))
|
|
|
774
|
|
|
775 ;;; Gcc handling.
|
|
|
776
|
|
|
777 ;; Do Gcc handling, which copied the message over to some group.
|
|
|
778 (defun gnus-inews-do-gcc (&optional gcc)
|
|
|
779 (when (gnus-alive-p)
|
|
|
780 (save-excursion
|
|
|
781 (save-restriction
|
|
|
782 (message-narrow-to-headers)
|
|
|
783 (let ((gcc (or gcc (mail-fetch-field "gcc" nil t)))
|
|
|
784 (cur (current-buffer))
|
|
|
785 groups group method)
|
|
|
786 (when gcc
|
|
|
787 (message-remove-header "gcc")
|
|
|
788 (widen)
|
|
|
789 (setq groups (message-tokenize-header gcc " ,"))
|
|
|
790 ;; Copy the article over to some group(s).
|
|
|
791 (while (setq group (pop groups))
|
|
|
792 (gnus-check-server
|
|
|
793 (setq method
|
|
|
794 (cond ((and (null (gnus-get-info group))
|
|
|
795 (eq (car gnus-message-archive-method)
|
|
|
796 (car
|
|
|
797 (gnus-server-to-method
|
|
|
798 (gnus-group-method group)))))
|
|
|
799 ;; If the group doesn't exist, we assume
|
|
|
800 ;; it's an archive group...
|
|
|
801 gnus-message-archive-method)
|
|
|
802 ;; Use the method.
|
|
|
803 ((gnus-info-method (gnus-get-info group))
|
|
|
804 (gnus-info-method (gnus-get-info group)))
|
|
|
805 ;; Find the method.
|
|
|
806 (t (gnus-group-method group)))))
|
|
|
807 (gnus-check-server method)
|
|
|
808 (unless (gnus-request-group group t method)
|
|
|
809 (gnus-request-create-group group method))
|
|
|
810 (save-excursion
|
|
|
811 (nnheader-set-temp-buffer " *acc*")
|
|
|
812 (insert-buffer-substring cur)
|
|
|
813 (goto-char (point-min))
|
|
|
814 (when (re-search-forward
|
|
|
815 (concat "^" (regexp-quote mail-header-separator) "$")
|
|
|
816 nil t)
|
|
|
817 (replace-match "" t t ))
|
|
|
818 (unless (gnus-request-accept-article group method t)
|
|
|
819 (gnus-message 1 "Couldn't store article in group %s: %s"
|
|
|
820 group (gnus-status-message method))
|
|
|
821 (sit-for 2))
|
|
|
822 (kill-buffer (current-buffer))))))))))
|
|
|
823
|
|
|
824 (defun gnus-inews-insert-gcc ()
|
|
|
825 "Insert Gcc headers based on `gnus-outgoing-message-group'."
|
|
|
826 (save-excursion
|
|
|
827 (save-restriction
|
|
|
828 (gnus-inews-narrow-to-headers)
|
|
|
829 (let* ((group gnus-outgoing-message-group)
|
|
|
830 (gcc (cond
|
|
|
831 ((gnus-functionp group)
|
|
|
832 (funcall group))
|
|
|
833 ((or (stringp group) (list group))
|
|
|
834 group))))
|
|
|
835 (when gcc
|
|
|
836 (insert "Gcc: "
|
|
|
837 (if (stringp gcc) gcc
|
|
|
838 (mapconcat 'identity gcc " "))
|
|
|
839 "\n"))))))
|
|
|
840
|
|
|
841 (defun gnus-inews-insert-archive-gcc (&optional group)
|
|
|
842 "Insert the Gcc to say where the article is to be archived."
|
|
|
843 (let* ((var gnus-message-archive-group)
|
|
|
844 (group (or group gnus-newsgroup-name ""))
|
|
|
845 result
|
|
|
846 (groups
|
|
|
847 (cond
|
|
|
848 ((null gnus-message-archive-method)
|
|
|
849 ;; Ignore.
|
|
|
850 nil)
|
|
|
851 ((stringp var)
|
|
|
852 ;; Just a single group.
|
|
|
853 (list var))
|
|
|
854 ((null var)
|
|
|
855 ;; We don't want this.
|
|
|
856 nil)
|
|
|
857 ((and (listp var) (stringp (car var)))
|
|
|
858 ;; A list of groups.
|
|
|
859 var)
|
|
|
860 ((gnus-functionp var)
|
|
|
861 ;; A function.
|
|
|
862 (funcall var group))
|
|
|
863 (t
|
|
|
864 ;; An alist of regexps/functions/forms.
|
|
|
865 (while (and var
|
|
|
866 (not
|
|
|
867 (setq result
|
|
|
868 (cond
|
|
|
869 ((stringp (caar var))
|
|
|
870 ;; Regexp.
|
|
|
871 (when (string-match (caar var) group)
|
|
|
872 (cdar var)))
|
|
|
873 ((gnus-functionp (car var))
|
|
|
874 ;; Function.
|
|
|
875 (funcall (car var) group))
|
|
|
876 (t
|
|
|
877 (eval (car var)))))))
|
|
|
878 (setq var (cdr var)))
|
|
|
879 result)))
|
|
|
880 name)
|
|
|
881 (when groups
|
|
|
882 (when (stringp groups)
|
|
|
883 (setq groups (list groups)))
|
|
|
884 (save-excursion
|
|
|
885 (save-restriction
|
|
|
886 (gnus-inews-narrow-to-headers)
|
|
|
887 (goto-char (point-max))
|
|
|
888 (insert "Gcc: ")
|
|
|
889 (while (setq name (pop groups))
|
|
|
890 (insert (if (string-match ":" name)
|
|
|
891 name
|
|
|
892 (gnus-group-prefixed-name
|
|
|
893 name gnus-message-archive-method)))
|
|
|
894 (if groups (insert " ")))
|
|
|
895 (insert "\n"))))))
|
|
|
896
|
|
|
897 (defun gnus-summary-send-draft ()
|
|
|
898 "Enter a mail/post buffer to edit and send the draft."
|
|
|
899 (interactive)
|
|
|
900 (gnus-set-global-variables)
|
|
|
901 (let (buf)
|
|
|
902 (if (not (setq buf (gnus-request-restore-buffer
|
|
|
903 (gnus-summary-article-number) gnus-newsgroup-name)))
|
|
|
904 (error "Couldn't restore the article")
|
|
|
905 (switch-to-buffer buf)
|
|
|
906 (when (eq major-mode 'news-reply-mode)
|
|
|
907 (local-set-key "\C-c\C-c" 'gnus-inews-news))
|
|
|
908 ;; Insert the separator.
|
|
|
909 (goto-char (point-min))
|
|
|
910 (search-forward "\n\n")
|
|
|
911 (forward-char -1)
|
|
|
912 (insert mail-header-separator)
|
|
|
913 ;; Configure windows.
|
|
|
914 (let ((gnus-draft-buffer (current-buffer)))
|
|
|
915 (gnus-configure-windows 'draft t)
|
|
|
916 (goto-char (point))))))
|
|
|
917
|
|
|
918 (gnus-add-shutdown 'gnus-inews-close 'gnus)
|
|
|
919
|
|
|
920 (defun gnus-inews-close ()
|
|
|
921 (setq gnus-inews-sent-ids nil))
|
|
|
922
|
|
|
923 ;;; Allow redefinition of functions.
|
|
|
924
|
|
|
925 (gnus-ems-redefine)
|
|
|
926
|
|
|
927 (provide 'gnus-msg)
|
|
|
928
|
|
|
929 ;;; gnus-msg.el ends here
|
