Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-msg.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents 131b0175ea99
children 360340f9fd5f
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;;; gnus-msg.el --- mail and post interface for Gnus 1 ;;; gnus-msg.el --- mail and post interface for Gnus
2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
3 3
4 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 4 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 5 ;; Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
6 ;; Keywords: news 6 ;; Keywords: news
7 7
27 ;;; Code: 27 ;;; Code:
28 28
29 (require 'gnus) 29 (require 'gnus)
30 (require 'gnus-ems) 30 (require 'gnus-ems)
31 (require 'message) 31 (require 'message)
32 (eval-when-compile (require 'cl)) 32 (require 'gnus-art)
33 33
34 ;; Added by Sudish Joseph <joseph@cis.ohio-state.edu>. 34 ;; Added by Sudish Joseph <joseph@cis.ohio-state.edu>.
35 (defvar gnus-post-method nil 35 (defvar gnus-post-method nil
36 "*Preferred method for posting USENET news. 36 "*Preferred method for posting USENET news.
37 If this variable is nil, Gnus will use the current method to decide 37 If this variable is nil, Gnus will use the current method to decide
45 posting.") 45 posting.")
46 46
47 (defvar gnus-outgoing-message-group nil 47 (defvar gnus-outgoing-message-group nil
48 "*All outgoing messages will be put in this group. 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 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 50 \"nnml:archive\", you set this variable to that value. This variable
51 can also be a list of group names. 51 can also be a list of group names.
52 52
53 If you want to have greater control over what group to put each 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 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 55 current newsgroup name and then returns a suitable group name (or list
66 "File where Gnus saves a cache of sent message ids.") 66 "File where Gnus saves a cache of sent message ids.")
67 67
68 (defvar gnus-sent-message-ids-length 1000 68 (defvar gnus-sent-message-ids-length 1000
69 "The number of sent Message-IDs to save.") 69 "The number of sent Message-IDs to save.")
70 70
71 (defvar gnus-crosspost-complaint
72 "Hi,
73
74 You posted the article below with the following Newsgroups header:
75
76 Newsgroups: %s
77
78 The %s group, at least, was an inappropriate recipient
79 of this message. Please trim your Newsgroups header to exclude this
80 group before posting in the future.
81
82 Thank you.
83
84 "
85 "Format string to be inserted when complaining about crossposts.
86 The first %s will be replaced by the Newsgroups header;
87 the second with the current group name.")
88
89 (defvar gnus-message-setup-hook nil
90 "Hook run after setting up a message buffer.")
91
71 ;;; Internal variables. 92 ;;; Internal variables.
72 93
73 (defvar gnus-message-buffer "*Mail Gnus*") 94 (defvar gnus-message-buffer "*Mail Gnus*")
74 (defvar gnus-article-copy nil) 95 (defvar gnus-article-copy nil)
75 (defvar gnus-last-posting-server nil) 96 (defvar gnus-last-posting-server nil)
97
98 (defconst gnus-bug-message
99 "Sending a bug report to the Gnus Towers.
100 ========================================
101
102 The buffer below is a mail buffer. When you press `C-c C-c', it will
103 be sent to the Gnus Bug Exterminators.
104
105 At the bottom of the buffer you'll see lots of variable settings.
106 Please do not delete those. They will tell the Bug People what your
107 environment is, so that it will be easier to locate the bugs.
108
109 If you have found a bug that makes Emacs go \"beep\", set
110 debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET')
111 and include the backtrace in your bug report.
112
113 Please describe the bug in annoying, painstaking detail.
114
115 Thank you for your help in stamping out bugs.
116 ")
76 117
77 (eval-and-compile 118 (eval-and-compile
78 (autoload 'gnus-uu-post-news "gnus-uu" nil t) 119 (autoload 'gnus-uu-post-news "gnus-uu" nil t)
79 (autoload 'news-setup "rnewspost") 120 (autoload 'news-setup "rnewspost")
80 (autoload 'news-reply-mode "rnewspost") 121 (autoload 'news-reply-mode "rnewspost")
84 125
85 ;;; 126 ;;;
86 ;;; Gnus Posting Functions 127 ;;; Gnus Posting Functions
87 ;;; 128 ;;;
88 129
89 (gnus-define-keys 130 (gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map)
90 (gnus-summary-send-map "S" gnus-summary-mode-map) 131 "p" gnus-summary-post-news
91 "p" gnus-summary-post-news 132 "f" gnus-summary-followup
92 "f" gnus-summary-followup 133 "F" gnus-summary-followup-with-original
93 "F" gnus-summary-followup-with-original 134 "c" gnus-summary-cancel-article
94 "c" gnus-summary-cancel-article 135 "s" gnus-summary-supersede-article
95 "s" gnus-summary-supersede-article 136 "r" gnus-summary-reply
96 "r" gnus-summary-reply 137 "R" gnus-summary-reply-with-original
97 "R" gnus-summary-reply-with-original 138 "w" gnus-summary-wide-reply
98 "m" gnus-summary-mail-other-window 139 "W" gnus-summary-wide-reply-with-original
99 "u" gnus-uu-post-news 140 "n" gnus-summary-followup-to-mail
100 "om" gnus-summary-mail-forward 141 "N" gnus-summary-followup-to-mail-with-original
101 "op" gnus-summary-post-forward 142 "m" gnus-summary-mail-other-window
102 "Om" gnus-uu-digest-mail-forward 143 "u" gnus-uu-post-news
103 "Op" gnus-uu-digest-post-forward) 144 "\M-c" gnus-summary-mail-crosspost-complaint
104 145 "om" gnus-summary-mail-forward
105 (gnus-define-keys 146 "op" gnus-summary-post-forward
106 (gnus-send-bounce-map "D" gnus-summary-send-map) 147 "Om" gnus-uu-digest-mail-forward
107 "b" gnus-summary-resend-bounced-mail 148 "Op" gnus-uu-digest-post-forward)
108 ; "c" gnus-summary-send-draft 149
109 "r" gnus-summary-resend-message) 150 (gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map)
151 "b" gnus-summary-resend-bounced-mail
152 ;; "c" gnus-summary-send-draft
153 "r" gnus-summary-resend-message)
110 154
111 ;;; Internal functions. 155 ;;; Internal functions.
112 156
113 (defvar gnus-article-reply nil) 157 (defvar gnus-article-reply nil)
114 (defmacro gnus-setup-message (config &rest forms) 158 (defmacro gnus-setup-message (config &rest forms)
115 (let ((winconf (make-symbol "winconf")) 159 (let ((winconf (make-symbol "winconf"))
116 (buffer (make-symbol "buffer")) 160 (buffer (make-symbol "buffer"))
117 (article (make-symbol "article"))) 161 (article (make-symbol "article")))
118 `(let ((,winconf (current-window-configuration)) 162 `(let ((,winconf (current-window-configuration))
119 (,buffer (current-buffer)) 163 (,buffer (buffer-name (current-buffer)))
120 (,article (and gnus-article-reply (gnus-summary-article-number))) 164 (,article (and gnus-article-reply (gnus-summary-article-number)))
121 (message-header-setup-hook 165 (message-header-setup-hook
122 (copy-sequence message-header-setup-hook))) 166 (copy-sequence message-header-setup-hook)))
123 (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc) 167 (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
124 (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc) 168 (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
125 ,@forms 169 (unwind-protect
126 (gnus-inews-add-send-actions ,winconf ,buffer ,article) 170 ,@forms
127 (setq gnus-message-buffer (current-buffer)) 171 (gnus-inews-add-send-actions ,winconf ,buffer ,article)
172 (setq gnus-message-buffer (current-buffer))
173 (make-local-variable 'gnus-newsgroup-name)
174 (run-hooks 'gnus-message-setup-hook))
128 (gnus-configure-windows ,config t)))) 175 (gnus-configure-windows ,config t))))
129 176
130 (defun gnus-inews-add-send-actions (winconf buffer article) 177 (defun gnus-inews-add-send-actions (winconf buffer article)
131 (gnus-make-local-hook 'message-sent-hook) 178 (make-local-hook 'message-sent-hook)
132 (gnus-add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t) 179 (gnus-add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t)
133 (setq message-post-method 180 (setq message-post-method
134 `(lambda (arg) 181 `(lambda (arg)
135 (gnus-post-method arg ,gnus-newsgroup-name))) 182 (gnus-post-method arg ,gnus-newsgroup-name)))
136 (setq message-newsreader (setq message-mailer (gnus-extended-version))) 183 (setq message-newsreader (setq message-mailer (gnus-extended-version)))
137 (message-add-action 184 (message-add-action
138 `(set-window-configuration ,winconf) 'exit 'postpone 'kill) 185 `(set-window-configuration ,winconf) 'exit 'postpone 'kill)
139 (message-add-action 186 (message-add-action
140 `(when (buffer-name ,buffer) 187 `(when (buffer-name (get-buffer ,buffer))
141 (save-excursion 188 (save-excursion
142 (set-buffer ,buffer) 189 (set-buffer (get-buffer ,buffer))
143 ,(when article 190 ,(when article
144 `(gnus-summary-mark-article-as-replied ,article)))) 191 `(gnus-summary-mark-article-as-replied ,article))))
145 'send)) 192 'send))
146 193
147 (put 'gnus-setup-message 'lisp-indent-function 1) 194 (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)) 195 (put 'gnus-setup-message 'edebug-form-spec '(form body))
150 196
151 ;;; Post news commands of Gnus group mode and summary mode 197 ;;; Post news commands of Gnus group mode and summary mode
152 198
153 (defun gnus-group-mail () 199 (defun gnus-group-mail ()
199 (defun gnus-summary-followup-with-original (n &optional force-news) 245 (defun gnus-summary-followup-with-original (n &optional force-news)
200 "Compose a followup to an article and include the original article." 246 "Compose a followup to an article and include the original article."
201 (interactive "P") 247 (interactive "P")
202 (gnus-summary-followup (gnus-summary-work-articles n) force-news)) 248 (gnus-summary-followup (gnus-summary-work-articles n) force-news))
203 249
250 (defun gnus-summary-followup-to-mail (&optional arg)
251 "Followup to the current mail message via news."
252 (interactive
253 (list (and current-prefix-arg
254 (gnus-summary-work-articles 1))))
255 (gnus-summary-followup arg t))
256
257 (defun gnus-summary-followup-to-mail-with-original (&optional arg)
258 "Followup to the current mail message via news."
259 (interactive "P")
260 (gnus-summary-followup (gnus-summary-work-articles arg) t))
261
204 (defun gnus-inews-yank-articles (articles) 262 (defun gnus-inews-yank-articles (articles)
205 (let (beg article) 263 (let (beg article)
264 (message-goto-body)
206 (while (setq article (pop articles)) 265 (while (setq article (pop articles))
207 (save-window-excursion 266 (save-window-excursion
208 (set-buffer gnus-summary-buffer) 267 (set-buffer gnus-summary-buffer)
209 (gnus-summary-select-article nil nil nil article) 268 (gnus-summary-select-article nil nil nil article)
210 (gnus-summary-remove-process-mark article)) 269 (gnus-summary-remove-process-mark article))
211 (gnus-copy-article-buffer) 270 (gnus-copy-article-buffer)
212 (let ((message-reply-buffer gnus-article-copy) 271 (let ((message-reply-buffer gnus-article-copy)
213 (message-reply-headers gnus-current-headers)) 272 (message-reply-headers gnus-current-headers))
214 (message-yank-original) 273 (message-yank-original)
215 (setq beg (or beg (mark t)))) 274 (setq beg (or beg (mark t))))
216 (when articles (insert "\n"))) 275 (when articles
217 276 (insert "\n")))
218 (push-mark) 277 (push-mark)
219 (goto-char beg))) 278 (goto-char beg)))
220 279
221 (defun gnus-summary-cancel-article (n) 280 (defun gnus-summary-cancel-article (n)
222 "Cancel an article you posted." 281 "Cancel an article you posted."
227 `(lambda (arg) 286 `(lambda (arg)
228 (gnus-post-method nil ,gnus-newsgroup-name))) 287 (gnus-post-method nil ,gnus-newsgroup-name)))
229 article) 288 article)
230 (while (setq article (pop articles)) 289 (while (setq article (pop articles))
231 (when (gnus-summary-select-article t nil nil article) 290 (when (gnus-summary-select-article t nil nil article)
232 (when (gnus-eval-in-buffer-window 291 (when (gnus-eval-in-buffer-window gnus-original-article-buffer
233 gnus-original-article-buffer (message-cancel-news)) 292 (message-cancel-news))
234 (gnus-summary-mark-as-read article gnus-canceled-mark) 293 (gnus-summary-mark-as-read article gnus-canceled-mark)
235 (gnus-cache-remove-article 1)) 294 (gnus-cache-remove-article 1))
236 (gnus-article-hide-headers-if-wanted)) 295 (gnus-article-hide-headers-if-wanted))
237 (gnus-summary-remove-process-mark article)))) 296 (gnus-summary-remove-process-mark article))))
238 297
248 (set-buffer gnus-original-article-buffer) 307 (set-buffer gnus-original-article-buffer)
249 (message-supersede) 308 (message-supersede)
250 (push 309 (push
251 `((lambda () 310 `((lambda ()
252 (gnus-cache-possibly-remove-article ,article nil nil nil t))) 311 (gnus-cache-possibly-remove-article ,article nil nil nil t)))
312 message-send-actions)
313 (push
314 `((lambda ()
315 (when (buffer-name (get-buffer ,gnus-summary-buffer))
316 (save-excursion
317 (set-buffer (get-buffer ,gnus-summary-buffer))
318 (gnus-summary-mark-as-read ,article gnus-canceled-mark)))))
253 message-send-actions)))) 319 message-send-actions))))
254 320
255 321
256 322
257 (defun gnus-copy-article-buffer (&optional article-buffer) 323 (defun gnus-copy-article-buffer (&optional article-buffer)
260 ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used 326 ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
261 ;; this buffer should be passed to all mail/news reply/post routines. 327 ;; this buffer should be passed to all mail/news reply/post routines.
262 (setq gnus-article-copy (get-buffer-create " *gnus article copy*")) 328 (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
263 (buffer-disable-undo gnus-article-copy) 329 (buffer-disable-undo gnus-article-copy)
264 (or (memq gnus-article-copy gnus-buffer-list) 330 (or (memq gnus-article-copy gnus-buffer-list)
265 (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list))) 331 (push gnus-article-copy gnus-buffer-list))
266 (let ((article-buffer (or article-buffer gnus-article-buffer)) 332 (let ((article-buffer (or article-buffer gnus-article-buffer))
267 end beg contents) 333 end beg contents)
268 (when (and (get-buffer article-buffer) 334 (if (not (and (get-buffer article-buffer)
269 (buffer-name (get-buffer article-buffer))) 335 (buffer-name (get-buffer article-buffer))))
336 (error "Can't find any article buffer")
270 (save-excursion 337 (save-excursion
271 (set-buffer article-buffer) 338 (set-buffer article-buffer)
272 (save-restriction 339 (save-restriction
340 ;; Copy over the (displayed) article buffer, delete
341 ;; hidden text and remove text properties.
273 (widen) 342 (widen)
274 (setq contents (format "%s" (buffer-string))) 343 (copy-to-buffer gnus-article-copy (point-min) (point-max))
344 (set-buffer gnus-article-copy)
345 (gnus-article-delete-text-of-type 'annotation)
346 (gnus-remove-text-with-property 'gnus-prev)
347 (gnus-remove-text-with-property 'gnus-next)
348 (insert
349 (prog1
350 (format "%s" (buffer-string))
351 (erase-buffer)))
352 ;; Find the original headers.
275 (set-buffer gnus-original-article-buffer) 353 (set-buffer gnus-original-article-buffer)
276 (goto-char (point-min)) 354 (goto-char (point-min))
277 (while (looking-at message-unix-mail-delimiter) 355 (while (looking-at message-unix-mail-delimiter)
278 (forward-line 1)) 356 (forward-line 1))
279 (setq beg (point)) 357 (setq beg (point))
280 (setq end (or (search-forward "\n\n" nil t) (point))) 358 (setq end (or (search-forward "\n\n" nil t) (point)))
359 ;; Delete the headers from the displayed articles.
281 (set-buffer gnus-article-copy) 360 (set-buffer gnus-article-copy)
282 (erase-buffer)
283 (insert contents)
284 (delete-region (goto-char (point-min)) 361 (delete-region (goto-char (point-min))
285 (or (search-forward "\n\n" nil t) (point))) 362 (or (search-forward "\n\n" nil t) (point)))
286 (insert-buffer-substring gnus-original-article-buffer beg end))) 363 ;; Insert the original article headers.
364 (insert-buffer-substring gnus-original-article-buffer beg end)
365 (gnus-article-decode-rfc1522)))
287 gnus-article-copy))) 366 gnus-article-copy)))
288 367
289 (defun gnus-post-news (post &optional group header article-buffer yank subject 368 (defun gnus-post-news (post &optional group header article-buffer yank subject
290 force-news) 369 force-news)
291 (when article-buffer 370 (when article-buffer
294 (gnus-setup-message (cond (yank 'reply-yank) 373 (gnus-setup-message (cond (yank 'reply-yank)
295 (article-buffer 'reply) 374 (article-buffer 'reply)
296 (t 'message)) 375 (t 'message))
297 (let* ((group (or group gnus-newsgroup-name)) 376 (let* ((group (or group gnus-newsgroup-name))
298 (pgroup group) 377 (pgroup group)
299 to-address to-group mailing-list to-list) 378 to-address to-group mailing-list to-list
379 newsgroup-p)
300 (when group 380 (when group
301 (setq to-address (gnus-group-get-parameter group 'to-address) 381 (setq to-address (gnus-group-find-parameter group 'to-address)
302 to-group (gnus-group-get-parameter group 'to-group) 382 to-group (gnus-group-find-parameter group 'to-group)
303 to-list (gnus-group-get-parameter group 'to-list) 383 to-list (gnus-group-find-parameter group 'to-list)
384 newsgroup-p (gnus-group-find-parameter group 'newsgroup)
304 mailing-list (when gnus-mailing-list-groups 385 mailing-list (when gnus-mailing-list-groups
305 (string-match gnus-mailing-list-groups group)) 386 (string-match gnus-mailing-list-groups group))
306 group (gnus-group-real-name group))) 387 group (gnus-group-real-name group)))
307 (if (or (and to-group 388 (if (or (and to-group
308 (gnus-news-group-p to-group)) 389 (gnus-news-group-p to-group))
390 newsgroup-p
309 force-news 391 force-news
310 (and (gnus-news-group-p 392 (and (gnus-news-group-p
311 (or pgroup gnus-newsgroup-name) 393 (or pgroup gnus-newsgroup-name)
312 (if header (mail-header-number header) 394 (if header (mail-header-number header)
313 gnus-current-article)) 395 gnus-current-article))
316 (not to-address))) 398 (not to-address)))
317 ;; This is news. 399 ;; This is news.
318 (if post 400 (if post
319 (message-news (or to-group group)) 401 (message-news (or to-group group))
320 (set-buffer gnus-article-copy) 402 (set-buffer gnus-article-copy)
321 (message-followup)) 403 (message-followup (if (or newsgroup-p force-news) nil to-group)))
322 ;; The is mail. 404 ;; The is mail.
323 (if post 405 (if post
324 (progn 406 (progn
325 (message-mail (or to-address to-list)) 407 (message-mail (or to-address to-list))
326 ;; Arrange for mail groups that have no `to-address' to 408 ;; Arrange for mail groups that have no `to-address' to
337 If SILENT, don't prompt the user." 419 If SILENT, don't prompt the user."
338 (let ((group-method (gnus-find-method-for-group group))) 420 (let ((group-method (gnus-find-method-for-group group)))
339 (cond 421 (cond
340 ;; If the group-method is nil (which shouldn't happen) we use 422 ;; If the group-method is nil (which shouldn't happen) we use
341 ;; the default method. 423 ;; the default method.
342 ((null arg) 424 ((null group-method)
343 (or gnus-post-method gnus-select-method message-post-method)) 425 (or gnus-post-method gnus-select-method message-post-method))
344 ;; We want this group's method. 426 ;; We want this group's method.
345 ((and arg (not (eq arg 0))) 427 ((and arg (not (eq arg 0)))
346 group-method) 428 group-method)
347 ;; We query the user for a post method. 429 ;; We query the user for a post method.
382 (completing-read 464 (completing-read
383 "Posting method: " method-alist nil t 465 "Posting method: " method-alist nil t
384 (cons (or gnus-last-posting-server "") 0)))) 466 (cons (or gnus-last-posting-server "") 0))))
385 method-alist)))) 467 method-alist))))
386 ;; Override normal method. 468 ;; Override normal method.
387 ((and gnus-post-method 469 (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) 470 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. 471 ;; Use the normal select method.
396 (t gnus-select-method)))) 472 (t gnus-select-method))))
397 473
398 (defun gnus-inews-narrow-to-headers () 474 (defun gnus-inews-narrow-to-headers ()
399 (widen) 475 (widen)
417 (let ((message-id (save-restriction (gnus-inews-narrow-to-headers) 493 (let ((message-id (save-restriction (gnus-inews-narrow-to-headers)
418 (mail-fetch-field "message-id"))) 494 (mail-fetch-field "message-id")))
419 end) 495 end)
420 (when message-id 496 (when message-id
421 (unless gnus-inews-sent-ids 497 (unless gnus-inews-sent-ids
422 (condition-case () 498 (ignore-errors
423 (load t t t) 499 (load t t t)))
424 (error nil)))
425 (if (member message-id gnus-inews-sent-ids) 500 (if (member message-id gnus-inews-sent-ids)
426 ;; Reject this message. 501 ;; Reject this message.
427 (not (gnus-yes-or-no-p 502 (not (gnus-yes-or-no-p
428 (format "Message %s already sent. Send anyway? " 503 (format "Message %s already sent. Send anyway? "
429 message-id))) 504 message-id)))
431 ;; Chop off the last Message-IDs. 506 ;; Chop off the last Message-IDs.
432 (when (setq end (nthcdr gnus-sent-message-ids-length 507 (when (setq end (nthcdr gnus-sent-message-ids-length
433 gnus-inews-sent-ids)) 508 gnus-inews-sent-ids))
434 (setcdr end nil)) 509 (setcdr end nil))
435 (nnheader-temp-write gnus-sent-message-ids-file 510 (nnheader-temp-write gnus-sent-message-ids-file
436 (prin1 `(setq gnus-inews-sent-ids ',gnus-inews-sent-ids) 511 (gnus-prin1 `(setq gnus-inews-sent-ids ',gnus-inews-sent-ids)))
437 (current-buffer)))
438 nil))))) 512 nil)))))
439 513
440 514
441 515
442 ;; Dummy to avoid byte-compile warning. 516 ;; Dummy to avoid byte-compile warning.
461 (match-beginning 1) 535 (match-beginning 1)
462 (match-end 1)) 536 (match-end 1))
463 (format " %d.%d" emacs-major-version emacs-minor-version))) 537 (format " %d.%d" emacs-major-version emacs-minor-version)))
464 (t emacs-version)))) 538 (t emacs-version))))
465 539
466 ;; Written by "Mr. Per Persson" <pp@solace.mh.se>. 540 ;; Written by "Mr. Per Persson" <pp@gnu.ai.mit.edu>.
467 (defun gnus-inews-insert-mime-headers () 541 (defun gnus-inews-insert-mime-headers ()
468 (goto-char (point-min)) 542 (goto-char (point-min))
469 (let ((mail-header-separator 543 (let ((mail-header-separator
470 (progn 544 (progn
471 (goto-char (point-min)) 545 (goto-char (point-min))
494 ;;; Gnus Mail Functions 568 ;;; Gnus Mail Functions
495 ;;; 569 ;;;
496 570
497 ;;; Mail reply commands of Gnus summary mode 571 ;;; Mail reply commands of Gnus summary mode
498 572
499 (defun gnus-summary-reply (&optional yank) 573 (defun gnus-summary-reply (&optional yank wide)
500 "Reply mail to news author. 574 "Start composing a reply mail to the current message.
501 If prefix argument YANK is non-nil, original article is yanked automatically." 575 If prefix argument YANK is non-nil, the original article is yanked
576 automatically."
502 (interactive 577 (interactive
503 (list (and current-prefix-arg 578 (list (and current-prefix-arg
504 (gnus-summary-work-articles 1)))) 579 (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. 580 ;; Stripping headers should be specified with mail-yank-ignored-headers.
507 (gnus-set-global-variables) 581 (gnus-set-global-variables)
508 (when yank 582 (when yank
509 (gnus-summary-goto-subject (car yank))) 583 (gnus-summary-goto-subject (car yank)))
510 (let ((gnus-article-reply t)) 584 (let ((gnus-article-reply t))
511 (gnus-setup-message (if yank 'reply-yank 'reply) 585 (gnus-setup-message (if yank 'reply-yank 'reply)
512 (gnus-summary-select-article) 586 (gnus-summary-select-article)
513 (set-buffer (gnus-copy-article-buffer)) 587 (set-buffer (gnus-copy-article-buffer))
514 (message-reply nil nil (gnus-group-get-parameter 588 (message-reply nil wide (gnus-group-find-parameter
515 gnus-newsgroup-name 'broken-reply-to)) 589 gnus-newsgroup-name 'broken-reply-to))
516 (when yank 590 (when yank
517 (gnus-inews-yank-articles yank))))) 591 (gnus-inews-yank-articles yank)))))
518 592
519 (defun gnus-summary-reply-with-original (n) 593 (defun gnus-summary-reply-with-original (n &optional wide)
520 "Reply mail to news author with original article." 594 "Start composing a reply mail to the current message.
521 (interactive "P") 595 The original article will be yanked."
522 (gnus-summary-reply (gnus-summary-work-articles n))) 596 (interactive "P")
523 597 (gnus-summary-reply (gnus-summary-work-articles n) wide))
524 (defun gnus-summary-mail-forward (&optional post) 598
525 "Forward the current message to another user." 599 (defun gnus-summary-wide-reply (&optional yank)
600 "Start composing a wide reply mail to the current message.
601 If prefix argument YANK is non-nil, the original article is yanked
602 automatically."
603 (interactive
604 (list (and current-prefix-arg
605 (gnus-summary-work-articles 1))))
606 (gnus-summary-reply yank t))
607
608 (defun gnus-summary-wide-reply-with-original (n)
609 "Start composing a wide reply mail to the current message.
610 The original article will be yanked."
611 (interactive "P")
612 (gnus-summary-reply-with-original n t))
613
614 (defun gnus-summary-mail-forward (&optional full-headers post)
615 "Forward the current message to another user.
616 If FULL-HEADERS (the prefix), include full headers when forwarding."
526 (interactive "P") 617 (interactive "P")
527 (gnus-set-global-variables) 618 (gnus-set-global-variables)
528 (gnus-setup-message 'forward 619 (gnus-setup-message 'forward
529 (gnus-summary-select-article) 620 (gnus-summary-select-article)
530 (set-buffer gnus-original-article-buffer) 621 (set-buffer gnus-original-article-buffer)
531 (message-forward post))) 622 (let ((message-included-forward-headers
532 623 (if full-headers "" message-included-forward-headers)))
533 (defun gnus-summary-resend-message (address) 624 (message-forward post))))
625
626 (defun gnus-summary-resend-message (address n)
534 "Resend the current article to ADDRESS." 627 "Resend the current article to ADDRESS."
535 (interactive "sResend message to: ") 628 (interactive "sResend message(s) to: \nP")
536 (gnus-summary-select-article) 629 (let ((articles (gnus-summary-work-articles n))
537 (save-excursion 630 article)
538 (set-buffer gnus-original-article-buffer) 631 (while (setq article (pop articles))
539 (message-resend address))) 632 (gnus-summary-select-article nil nil nil article)
540 633 (save-excursion
541 (defun gnus-summary-post-forward () 634 (set-buffer gnus-original-article-buffer)
542 "Forward the current article to a newsgroup." 635 (message-resend address)))))
543 (interactive) 636
544 (gnus-summary-mail-forward t)) 637 (defun gnus-summary-post-forward (&optional full-headers)
638 "Forward the current article to a newsgroup.
639 If FULL-HEADERS (the prefix), include full headers when forwarding."
640 (interactive "P")
641 (gnus-summary-mail-forward full-headers t))
545 642
546 (defvar gnus-nastygram-message 643 (defvar gnus-nastygram-message
547 "The following article was inappropriately posted to %s.\n" 644 "The following article was inappropriately posted to %s.\n\n"
548 "Format string to insert in nastygrams. 645 "Format string to insert in nastygrams.
549 The current group name will be inserted at \"%s\".") 646 The current group name will be inserted at \"%s\".")
550 647
551 (defun gnus-summary-mail-nastygram (n) 648 (defun gnus-summary-mail-nastygram (n)
552 "Send a nastygram to the author of the current article." 649 "Send a nastygram to the author of the current article."
553 (interactive "P") 650 (interactive "P")
554 (if (or gnus-expert-user 651 (when (or gnus-expert-user
555 (gnus-y-or-n-p 652 (gnus-y-or-n-p
556 "Really send a nastygram to the author of the current article? ")) 653 "Really send a nastygram to the author of the current article? "))
557 (let ((group gnus-newsgroup-name)) 654 (let ((group gnus-newsgroup-name))
558 (gnus-summary-reply-with-original n) 655 (gnus-summary-reply-with-original n)
559 (set-buffer gnus-message-buffer) 656 (set-buffer gnus-message-buffer)
560 (insert (format gnus-nastygram-message group)) 657 (message-goto-body)
561 (message-send-and-exit)))) 658 (insert (format gnus-nastygram-message group))
659 (message-send-and-exit))))
660
661 (defun gnus-summary-mail-crosspost-complaint (n)
662 "Send a complaint about crossposting to the current article(s)."
663 (interactive "P")
664 (let ((articles (gnus-summary-work-articles n))
665 article)
666 (while (setq article (pop articles))
667 (set-buffer gnus-summary-buffer)
668 (gnus-summary-goto-subject article)
669 (let ((group (gnus-group-real-name gnus-newsgroup-name))
670 newsgroups followup-to)
671 (gnus-summary-select-article)
672 (set-buffer gnus-original-article-buffer)
673 (if (and (<= (length (message-tokenize-header
674 (setq newsgroups (mail-fetch-field "newsgroups"))
675 ", "))
676 1)
677 (or (not (setq followup-to (mail-fetch-field "followup-to")))
678 (not (member group (message-tokenize-header
679 followup-to ", ")))))
680 (if followup-to
681 (gnus-message 1 "Followup-to restricted")
682 (gnus-message 1 "Not a crossposted article"))
683 (set-buffer gnus-summary-buffer)
684 (gnus-summary-reply-with-original 1)
685 (set-buffer gnus-message-buffer)
686 (message-goto-body)
687 (insert (format gnus-crosspost-complaint newsgroups group))
688 (message-goto-subject)
689 (re-search-forward " *$")
690 (replace-match " (crosspost notification)" t t)
691 (when (gnus-y-or-n-p "Send this complaint? ")
692 (message-send-and-exit)))))))
562 693
563 (defun gnus-summary-mail-other-window () 694 (defun gnus-summary-mail-other-window ()
564 "Compose mail in other window." 695 "Compose mail in other window."
565 (interactive) 696 (interactive)
566 (gnus-setup-message 'message 697 (gnus-setup-message 'message
580 (narrow-to-region beg (point)) 711 (narrow-to-region beg (point))
581 (goto-char beg) 712 (goto-char beg)
582 (logand (progn 713 (logand (progn
583 (while (search-forward "\"" nil t) 714 (while (search-forward "\"" nil t)
584 (incf i)) 715 (incf i))
585 (if (zerop i) 2 i)) 2))))) 716 (if (zerop i) 2 i))
717 2)))))
586 (skip-chars-forward ",") 718 (skip-chars-forward ",")
587 (skip-chars-forward "^,")) 719 (skip-chars-forward "^,"))
588 (skip-chars-backward " ") 720 (skip-chars-backward " ")
589 (setq accumulated 721 (push (buffer-substring beg (point))
590 (cons (buffer-substring beg (point)) 722 accumulated)
591 accumulated))
592 (skip-chars-forward "^,") 723 (skip-chars-forward "^,")
593 (skip-chars-forward ", ")) 724 (skip-chars-forward ", "))
594 accumulated)) 725 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 726
603 (defun gnus-inews-add-to-address (group) 727 (defun gnus-inews-add-to-address (group)
604 (let ((to-address (mail-fetch-field "to"))) 728 (let ((to-address (mail-fetch-field "to")))
605 (when (and to-address 729 (when (and to-address
606 (gnus-alive-p)) 730 (gnus-alive-p))
616 (group gnus-newsgroup-name)) 740 (group gnus-newsgroup-name))
617 741
618 (or (and group (not (gnus-group-read-only-p group))) 742 (or (and group (not (gnus-group-read-only-p group)))
619 (setq group (read-string "Put in group: " nil 743 (setq group (read-string "Put in group: " nil
620 (gnus-writable-groups)))) 744 (gnus-writable-groups))))
621 (and (gnus-gethash group gnus-newsrc-hashtb) 745 (when (gnus-gethash group gnus-newsrc-hashtb)
622 (error "No such group: %s" group)) 746 (error "No such group: %s" group))
623 747
624 (save-excursion 748 (save-excursion
625 (save-restriction 749 (save-restriction
626 (widen) 750 (widen)
627 (gnus-inews-narrow-to-headers) 751 (gnus-inews-narrow-to-headers)
633 (insert "Gcc: " group "\n") 757 (insert "Gcc: " group "\n")
634 (widen))) 758 (widen)))
635 759
636 (gnus-inews-do-gcc) 760 (gnus-inews-do-gcc)
637 761
638 (if (get-buffer gnus-group-buffer) 762 (when (get-buffer gnus-group-buffer)
639 (progn 763 (when (gnus-buffer-exists-p (car-safe reply))
640 (if (gnus-buffer-exists-p (car-safe reply)) 764 (set-buffer (car reply))
641 (progn 765 (and (cdr reply)
642 (set-buffer (car reply)) 766 (gnus-summary-mark-article-as-replied
643 (and (cdr reply) 767 (cdr reply))))
644 (gnus-summary-mark-article-as-replied 768 (when winconf
645 (cdr reply))))) 769 (set-window-configuration winconf)))))
646 (and winconf (set-window-configuration winconf))))))
647 770
648 (defun gnus-article-mail (yank) 771 (defun gnus-article-mail (yank)
649 "Send a reply to the address near point. 772 "Send a reply to the address near point.
650 If YANK is non-nil, include the original article." 773 If YANK is non-nil, include the original article."
651 (interactive "P") 774 (interactive "P")
656 (when address 779 (when address
657 (message-reply address) 780 (message-reply address)
658 (when yank 781 (when yank
659 (gnus-inews-yank-articles (list (cdr gnus-article-current))))))) 782 (gnus-inews-yank-articles (list (cdr gnus-article-current)))))))
660 783
784 (defvar nntp-server-type)
661 (defun gnus-bug () 785 (defun gnus-bug ()
662 "Send a bug report to the Gnus maintainers." 786 "Send a bug report to the Gnus maintainers."
663 (interactive) 787 (interactive)
788 (unless (gnus-alive-p)
789 (error "Gnus has been shut down"))
664 (gnus-setup-message 'bug 790 (gnus-setup-message 'bug
665 (delete-other-windows) 791 (delete-other-windows)
666 (switch-to-buffer "*Gnus Help Bug*") 792 (switch-to-buffer "*Gnus Help Bug*")
667 (erase-buffer) 793 (erase-buffer)
668 (insert gnus-bug-message) 794 (insert gnus-bug-message)
672 (push `(gnus-bug-kill-buffer) message-send-actions) 798 (push `(gnus-bug-kill-buffer) message-send-actions)
673 (goto-char (point-min)) 799 (goto-char (point-min))
674 (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) 800 (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
675 (forward-line 1) 801 (forward-line 1)
676 (insert (gnus-version) "\n") 802 (insert (gnus-version) "\n")
677 (insert (emacs-version)) 803 (insert (emacs-version) "\n")
804 (when (and (boundp 'nntp-server-type)
805 (stringp nntp-server-type))
806 (insert nntp-server-type))
678 (insert "\n\n\n\n\n") 807 (insert "\n\n\n\n\n")
679 (gnus-debug) 808 (gnus-debug)
680 (goto-char (point-min)) 809 (goto-char (point-min))
681 (search-forward "Subject: " nil t) 810 (search-forward "Subject: " nil t)
682 (message ""))) 811 (message "")))
683 812
684 (defun gnus-bug-kill-buffer () 813 (defun gnus-bug-kill-buffer ()
685 (and (get-buffer "*Gnus Help Bug*") 814 (when (get-buffer "*Gnus Help Bug*")
686 (kill-buffer "*Gnus Help Bug*"))) 815 (kill-buffer "*Gnus Help Bug*")))
687 816
688 (defun gnus-debug () 817 (defun gnus-debug ()
689 "Attemps to go through the Gnus source file and report what variables have been changed. 818 "Attempts 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." 819 The source file has to be in the Emacs load path."
691 (interactive) 820 (interactive)
692 (let ((files '("gnus.el" "gnus-msg.el" "gnus-score.el" "nnmail.el" 821 (let ((files '("gnus.el" "gnus-sum.el" "gnus-group.el"
693 "message.el")) 822 "gnus-art.el" "gnus-start.el" "gnus-async.el"
694 file dirs expr olist sym) 823 "gnus-msg.el" "gnus-score.el" "gnus-win.el"
824 "nnmail.el" "message.el"))
825 file expr olist sym)
695 (gnus-message 4 "Please wait while we snoop your variables...") 826 (gnus-message 4 "Please wait while we snoop your variables...")
696 (sit-for 0) 827 (sit-for 0)
828 ;; Go through all the files looking for non-default values for variables.
697 (save-excursion 829 (save-excursion
698 (set-buffer (get-buffer-create " *gnus bug info*")) 830 (set-buffer (get-buffer-create " *gnus bug info*"))
699 (buffer-disable-undo (current-buffer)) 831 (buffer-disable-undo (current-buffer))
700 (while files 832 (while files
701 (erase-buffer) 833 (erase-buffer)
702 (setq dirs load-path) 834 (when (and (setq file (locate-library (pop files)))
703 (while dirs 835 (file-exists-p file))
704 (if (or (not (car dirs)) 836 (insert-file-contents file)
705 (not (stringp (car dirs))) 837 (goto-char (point-min))
706 (not (file-exists-p 838 (if (not (re-search-forward "^;;* *Internal variables" nil t))
707 (setq file (concat (file-name-as-directory 839 (gnus-message 4 "Malformed sources in file %s" file)
708 (car dirs)) (car files)))))) 840 (narrow-to-region (point-min) (point))
709 (setq dirs (cdr dirs))
710 (setq dirs nil)
711 (insert-file-contents file)
712 (goto-char (point-min)) 841 (goto-char (point-min))
713 (if (not (re-search-forward "^;;* *Internal variables" nil t)) 842 (while (setq expr (ignore-errors (read (current-buffer))))
714 (gnus-message 4 "Malformed sources in file %s" file) 843 (ignore-errors
715 (narrow-to-region (point-min) (point)) 844 (and (or (eq (car expr) 'defvar)
716 (goto-char (point-min)) 845 (eq (car expr) 'defcustom))
717 (while (setq expr (condition-case () 846 (stringp (nth 3 expr))
718 (read (current-buffer)) (error nil))) 847 (or (not (boundp (nth 1 expr)))
719 (condition-case () 848 (not (equal (eval (nth 2 expr))
720 (and (eq (car expr) 'defvar) 849 (symbol-value (nth 1 expr)))))
721 (stringp (nth 3 expr)) 850 (push (nth 1 expr) olist)))))))
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))) 851 (kill-buffer (current-buffer)))
729 (when (setq olist (nreverse olist)) 852 (when (setq olist (nreverse olist))
730 (insert "------------------ Environment follows ------------------\n\n")) 853 (insert "------------------ Environment follows ------------------\n\n"))
731 (while olist 854 (while olist
732 (if (boundp (car olist)) 855 (if (boundp (car olist))
743 (format "(setq %s 'whatever)\n" (car olist)))) 866 (format "(setq %s 'whatever)\n" (car olist))))
744 (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n")) 867 (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))
745 (setq olist (cdr olist))) 868 (setq olist (cdr olist)))
746 (insert "\n\n") 869 (insert "\n\n")
747 ;; Remove any null chars - they seem to cause trouble for some 870 ;; Remove any null chars - they seem to cause trouble for some
748 ;; mailers. (Byte-compiled output from the stuff above.) 871 ;; mailers. (Byte-compiled output from the stuff above.)
749 (goto-char (point-min)) 872 (goto-char (point-min))
750 (while (re-search-forward "[\000\200]" nil t) 873 (while (re-search-forward "[\000\200]" nil t)
751 (replace-match "" t t)))) 874 (replace-match "" t t))))
752 875
753 ;;; Treatment of rejected articles. 876 ;;; Treatment of rejected articles.
841 (defun gnus-inews-insert-archive-gcc (&optional group) 964 (defun gnus-inews-insert-archive-gcc (&optional group)
842 "Insert the Gcc to say where the article is to be archived." 965 "Insert the Gcc to say where the article is to be archived."
843 (let* ((var gnus-message-archive-group) 966 (let* ((var gnus-message-archive-group)
844 (group (or group gnus-newsgroup-name "")) 967 (group (or group gnus-newsgroup-name ""))
845 result 968 result
969 gcc-self-val
846 (groups 970 (groups
847 (cond 971 (cond
848 ((null gnus-message-archive-method) 972 ((null gnus-message-archive-method)
849 ;; Ignore. 973 ;; Ignore.
850 nil) 974 nil)
884 (save-excursion 1008 (save-excursion
885 (save-restriction 1009 (save-restriction
886 (gnus-inews-narrow-to-headers) 1010 (gnus-inews-narrow-to-headers)
887 (goto-char (point-max)) 1011 (goto-char (point-max))
888 (insert "Gcc: ") 1012 (insert "Gcc: ")
889 (while (setq name (pop groups)) 1013 (if (and gnus-newsgroup-name
890 (insert (if (string-match ":" name) 1014 (setq gcc-self-val
891 name 1015 (gnus-group-find-parameter
892 (gnus-group-prefixed-name 1016 gnus-newsgroup-name 'gcc-self)))
893 name gnus-message-archive-method))) 1017 (progn
894 (if groups (insert " "))) 1018 (insert
895 (insert "\n")))))) 1019 (if (stringp gcc-self-val)
1020 gcc-self-val
1021 group))
1022 (if (not (eq gcc-self-val 'none))
1023 (insert "\n")
1024 (progn
1025 (beginning-of-line)
1026 (kill-line))))
1027 (while (setq name (pop groups))
1028 (insert (if (string-match ":" name)
1029 name
1030 (gnus-group-prefixed-name
1031 name gnus-message-archive-method)))
1032 (when groups
1033 (insert " ")))
1034 (insert "\n")))))))
896 1035
897 (defun gnus-summary-send-draft () 1036 (defun gnus-summary-send-draft ()
898 "Enter a mail/post buffer to edit and send the draft." 1037 "Enter a mail/post buffer to edit and send the draft."
899 (interactive) 1038 (interactive)
900 (gnus-set-global-variables) 1039 (gnus-set-global-variables)