Mercurial > emacs

comparison lisp/gnus/gnus-msg.el @ 31716:9968f55ad26e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Update to emacs-21-branch of the Gnus CVS repository.
author Gerd Moellmann <gerd@gnu.org>
date Tue, 19 Sep 2000 13:37:09 +0000
parents cbe304a26771
children 51cea22fd2aa
comparison
equal deleted inserted replaced
31715:7c896543d225 31716:9968f55ad26e
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,97,98 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
3 ;; Free Software Foundation, Inc.
3 4
4 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> 5 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
5 ;; Lars Magne Ingebrigtsen <larsi@gnus.org> 6 ;; Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: news 7 ;; Keywords: news
7 8
26 27
27 ;;; Code: 28 ;;; Code:
28 29
29 (eval-when-compile (require 'cl)) 30 (eval-when-compile (require 'cl))
30 31
31 (eval-when-compile (require 'cl))
32
33 (require 'gnus) 32 (require 'gnus)
34 (require 'gnus-ems) 33 (require 'gnus-ems)
35 (require 'message) 34 (require 'message)
36 (require 'gnus-art) 35 (require 'gnus-art)
37 36
38 (defcustom gnus-post-method nil 37 (defcustom gnus-post-method 'current
39 "*Preferred method for posting USENET news. 38 "*Preferred method for posting USENET news.
40 39
41 If this variable is `current', Gnus will use the \"current\" select 40 If this variable is `current', Gnus will use the \"current\" select
42 method when posting. If it is nil (which is the default), Gnus will 41 method when posting. If it is nil (which is the default), Gnus will
43 use the native posting method of the server. 42 use the native select method when posting.
44 43
45 This method will not be used in mail groups and the like, only in 44 This method will not be used in mail groups and the like, only in
46 \"real\" newsgroups. 45 \"real\" newsgroups.
47 46
48 If not nil nor `native', the value must be a valid method as discussed 47 If not nil nor `native', the value must be a valid method as discussed
49 in the documentation of `gnus-select-method'. It can also be a list of 48 in the documentation of `gnus-select-method'. It can also be a list of
50 methods. If that is the case, the user will be queried for what select 49 methods. If that is the case, the user will be queried for what select
51 method to use when posting." 50 method to use when posting."
52 :group 'gnus-group-foreign 51 :group 'gnus-group-foreign
53 :type `(choice (const nil) 52 :type `(choice (const nil)
54 (const current) 53 (const current)
55 (const native) 54 (const native)
100 "*Should we create the *Gnus Help Bug* buffer?") 99 "*Should we create the *Gnus Help Bug* buffer?")
101 100
102 (defvar gnus-posting-styles nil 101 (defvar gnus-posting-styles nil
103 "*Alist of styles to use when posting.") 102 "*Alist of styles to use when posting.")
104 103
105 (defvar gnus-posting-style-alist 104 (defcustom gnus-group-posting-charset-alist
106 '((organization . message-user-organization) 105 '(("^\\(no\\|fr\\|dk\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\|dk\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1))
107 (signature . message-signature) 106 ("^\\(fido7\\|relcom\\)\\.[^,]*\\(,[ \t\n]*\\(fido7\\|relcom\\)\\.[^,]*\\)*$" koi8-r (koi8-r))
108 (signature-file . message-signature-file) 107 (message-this-is-mail nil nil)
109 (address . user-mail-address) 108 (message-this-is-news nil t))
110 (name . user-full-name)) 109 "Alist of regexps and permitted unencoded charsets for posting.
111 "*Mapping from style parameters to variables.") 110 Each element of the alist has the form (TEST HEADER BODY-LIST), where
111 TEST is either a regular expression matching the newsgroup header or a
112 variable to query,
113 HEADER is the charset which may be left unencoded in the header (nil
114 means encode all charsets),
115 BODY-LIST is a list of charsets which may be encoded using 8bit
116 content-transfer encoding in the body, or one of the special values
117 nil (always encode using quoted-printable) or t (always use 8bit).
118
119 Note that any value other than nil for HEADER infringes some RFCs, so
120 use this option with care."
121 :type '(repeat (list :tag "Permitted unencoded charsets"
122 (choice :tag "Where"
123 (regexp :tag "Group")
124 (const :tag "Mail message" :value message-this-is-mail)
125 (const :tag "News article" :value message-this-is-news))
126 (choice :tag "Header"
127 (const :tag "None" nil)
128 (symbol :tag "Charset"))
129 (choice :tag "Body"
130 (const :tag "Any" :value t)
131 (const :tag "None" :value nil)
132 (repeat :tag "Charsets"
133 (symbol :tag "Charset")))))
134 :group 'gnus-charset)
112 135
113 ;;; Internal variables. 136 ;;; Internal variables.
114 137
115 (defvar gnus-inhibit-posting-styles nil 138 (defvar gnus-inhibit-posting-styles nil
116 "Inhibit the use of posting styles.") 139 "Inhibit the use of posting styles.")
125 ======================================== 148 ========================================
126 149
127 The buffer below is a mail buffer. When you press `C-c C-c', it will 150 The buffer below is a mail buffer. When you press `C-c C-c', it will
128 be sent to the Gnus Bug Exterminators. 151 be sent to the Gnus Bug Exterminators.
129 152
130 At the bottom of the buffer you'll see lots of variable settings. 153 The thing near the bottom of the buffer is how the environment
131 Please do not delete those. They will tell the Bug People what your 154 settings will be included in the mail. Please do not delete that.
132 environment is, so that it will be easier to locate the bugs. 155 They will tell the Bug People what your environment is, so that it
156 will be easier to locate the bugs.
133 157
134 If you have found a bug that makes Emacs go \"beep\", set 158 If you have found a bug that makes Emacs go \"beep\", set
135 debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET') 159 debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET')
136 and include the backtrace in your bug report. 160 and include the backtrace in your bug report.
137 161
157 "f" gnus-summary-followup 181 "f" gnus-summary-followup
158 "F" gnus-summary-followup-with-original 182 "F" gnus-summary-followup-with-original
159 "c" gnus-summary-cancel-article 183 "c" gnus-summary-cancel-article
160 "s" gnus-summary-supersede-article 184 "s" gnus-summary-supersede-article
161 "r" gnus-summary-reply 185 "r" gnus-summary-reply
186 "y" gnus-summary-yank-message
162 "R" gnus-summary-reply-with-original 187 "R" gnus-summary-reply-with-original
163 "w" gnus-summary-wide-reply 188 "w" gnus-summary-wide-reply
164 "W" gnus-summary-wide-reply-with-original 189 "W" gnus-summary-wide-reply-with-original
165 "n" gnus-summary-followup-to-mail 190 "n" gnus-summary-followup-to-mail
166 "N" gnus-summary-followup-to-mail-with-original 191 "N" gnus-summary-followup-to-mail-with-original
175 (gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map) 200 (gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map)
176 "b" gnus-summary-resend-bounced-mail 201 "b" gnus-summary-resend-bounced-mail
177 ;; "c" gnus-summary-send-draft 202 ;; "c" gnus-summary-send-draft
178 "r" gnus-summary-resend-message) 203 "r" gnus-summary-resend-message)
179 204
205 ;;;###autoload
206 (defun gnus-msg-mail (&rest args)
207 "Start editing a mail message to be sent.
208 Like `message-mail', but with Gnus paraphernalia, particularly the
209 the Gcc: header for archiving purposes."
210 (interactive)
211 (gnus-setup-message 'message
212 (apply 'message-mail args)))
213
214 ;;;###autoload
215 (define-mail-user-agent 'gnus-user-agent
216 'gnus-msg-mail 'message-send-and-exit
217 'message-kill-buffer 'message-send-hook)
218
180 ;;; Internal functions. 219 ;;; Internal functions.
181 220
182 (defvar gnus-article-reply nil) 221 (defvar gnus-article-reply nil)
183 (defmacro gnus-setup-message (config &rest forms) 222 (defmacro gnus-setup-message (config &rest forms)
184 (let ((winconf (make-symbol "gnus-setup-message-winconf")) 223 (let ((winconf (make-symbol "gnus-setup-message-winconf"))
189 (,buffer (buffer-name (current-buffer))) 228 (,buffer (buffer-name (current-buffer)))
190 (,article (and gnus-article-reply (gnus-summary-article-number))) 229 (,article (and gnus-article-reply (gnus-summary-article-number)))
191 (,group gnus-newsgroup-name) 230 (,group gnus-newsgroup-name)
192 (message-header-setup-hook 231 (message-header-setup-hook
193 (copy-sequence message-header-setup-hook)) 232 (copy-sequence message-header-setup-hook))
233 (mbl mml-buffer-list)
194 (message-mode-hook (copy-sequence message-mode-hook))) 234 (message-mode-hook (copy-sequence message-mode-hook)))
235 (setq mml-buffer-list nil)
195 (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc) 236 (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
196 (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc) 237 (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
197 (add-hook 'message-mode-hook 'gnus-configure-posting-styles) 238 (add-hook 'message-mode-hook 'gnus-configure-posting-styles)
198 (unwind-protect 239 (unwind-protect
199 (progn 240 (progn
200 ,@forms) 241 ,@forms)
201 (gnus-inews-add-send-actions ,winconf ,buffer ,article) 242 (gnus-inews-add-send-actions ,winconf ,buffer ,article)
202 (setq gnus-message-buffer (current-buffer)) 243 (setq gnus-message-buffer (current-buffer))
203 (set (make-local-variable 'gnus-message-group-art) 244 (set (make-local-variable 'gnus-message-group-art)
204 (cons ,group ,article)) 245 (cons ,group ,article))
205 (make-local-variable 'gnus-newsgroup-name) 246 (set (make-local-variable 'gnus-newsgroup-name) ,group)
206 (gnus-run-hooks 'gnus-message-setup-hook)) 247 (gnus-run-hooks 'gnus-message-setup-hook)
248 (if (eq major-mode 'message-mode)
249 ;; Make mml-buffer-list local.
250 ;; Restore global mml-buffer-list value as mbl.
251 ;; What a hack! -- Shenghuo
252 (let ((mml-buffer-list mml-buffer-list))
253 (setq mml-buffer-list mbl)
254 (make-local-variable 'mml-buffer-list)
255 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))
256 (mml-destroy-buffers)
257 (setq mml-buffer-list mbl)))
207 (gnus-add-buffer) 258 (gnus-add-buffer)
208 (gnus-configure-windows ,config t) 259 (gnus-configure-windows ,config t)
209 (set-buffer-modified-p nil)))) 260 (set-buffer-modified-p nil))))
261
262 (defun gnus-setup-posting-charset (group)
263 (let ((alist gnus-group-posting-charset-alist)
264 (group (or group ""))
265 elem)
266 (when group
267 (catch 'found
268 (while (setq elem (pop alist))
269 (when (or (and (stringp (car elem))
270 (string-match (car elem) group))
271 (and (gnus-functionp (car elem))
272 (funcall (car elem) group))
273 (and (symbolp (car elem))
274 (symbol-value (car elem))))
275 (throw 'found (cons (cadr elem) (caddr elem)))))))))
210 276
211 (defun gnus-inews-add-send-actions (winconf buffer article) 277 (defun gnus-inews-add-send-actions (winconf buffer article)
212 (make-local-hook 'message-sent-hook) 278 (make-local-hook 'message-sent-hook)
213 (add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t) 279 (add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t)
214 (setq message-post-method 280 (setq message-post-method
228 (put 'gnus-setup-message 'lisp-indent-function 1) 294 (put 'gnus-setup-message 'lisp-indent-function 1)
229 (put 'gnus-setup-message 'edebug-form-spec '(form body)) 295 (put 'gnus-setup-message 'edebug-form-spec '(form body))
230 296
231 ;;; Post news commands of Gnus group mode and summary mode 297 ;;; Post news commands of Gnus group mode and summary mode
232 298
233 (defun gnus-group-mail () 299 (defun gnus-group-mail (&optional arg)
234 "Start composing a mail." 300 "Start composing a mail.
235 (interactive) 301 If ARG, use the group under the point to find a posting style.
236 (gnus-setup-message 'message 302 If ARG is 1, prompt for a group name to find the posting style."
237 (message-mail))) 303 (interactive "P")
304 ;; We can't `let' gnus-newsgroup-name here, since that leads
305 ;; to local variables leaking.
306 (let ((group gnus-newsgroup-name)
307 (buffer (current-buffer)))
308 (unwind-protect
309 (progn
310 (setq gnus-newsgroup-name
311 (if arg
312 (if (= 1 (prefix-numeric-value arg))
313 (completing-read "Use posting style of group: "
314 gnus-active-hashtb nil
315 (gnus-read-active-file-p))
316 (gnus-group-group-name))
317 ""))
318 (gnus-setup-message 'message (message-mail)))
319 (save-excursion
320 (set-buffer buffer)
321 (setq gnus-newsgroup-name group)))))
238 322
239 (defun gnus-group-post-news (&optional arg) 323 (defun gnus-group-post-news (&optional arg)
240 "Start composing a news message. 324 "Start composing a news message.
241 If ARG, post to the group under point. 325 If ARG, post to the group under point.
242 If ARG is 1, prompt for a group name." 326 If ARG is 1, prompt for a group name."
353 ;; make a copy of the article buffer with all text properties removed 437 ;; make a copy of the article buffer with all text properties removed
354 ;; this copy is in the buffer gnus-article-copy. 438 ;; this copy is in the buffer gnus-article-copy.
355 ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used 439 ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
356 ;; this buffer should be passed to all mail/news reply/post routines. 440 ;; this buffer should be passed to all mail/news reply/post routines.
357 (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*")) 441 (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*"))
358 (buffer-disable-undo gnus-article-copy) 442 (save-excursion
443 (set-buffer gnus-article-copy)
444 (mm-enable-multibyte))
359 (let ((article-buffer (or article-buffer gnus-article-buffer)) 445 (let ((article-buffer (or article-buffer gnus-article-buffer))
360 end beg) 446 end beg)
361 (if (not (and (get-buffer article-buffer) 447 (if (not (and (get-buffer article-buffer)
362 (gnus-buffer-exists-p article-buffer))) 448 (gnus-buffer-exists-p article-buffer)))
363 (error "Can't find any article buffer") 449 (error "Can't find any article buffer")
372 (gnus-article-delete-text-of-type 'annotation) 458 (gnus-article-delete-text-of-type 'annotation)
373 (gnus-remove-text-with-property 'gnus-prev) 459 (gnus-remove-text-with-property 'gnus-prev)
374 (gnus-remove-text-with-property 'gnus-next) 460 (gnus-remove-text-with-property 'gnus-next)
375 (insert 461 (insert
376 (prog1 462 (prog1
377 (format "%s" (buffer-string)) 463 (buffer-substring-no-properties (point-min) (point-max))
378 (erase-buffer))) 464 (erase-buffer)))
379 ;; Find the original headers. 465 ;; Find the original headers.
380 (set-buffer gnus-original-article-buffer) 466 (set-buffer gnus-original-article-buffer)
381 (goto-char (point-min)) 467 (goto-char (point-min))
382 (while (looking-at message-unix-mail-delimiter) 468 (while (looking-at message-unix-mail-delimiter)
384 (setq beg (point)) 470 (setq beg (point))
385 (setq end (or (search-forward "\n\n" nil t) (point))) 471 (setq end (or (search-forward "\n\n" nil t) (point)))
386 ;; Delete the headers from the displayed articles. 472 ;; Delete the headers from the displayed articles.
387 (set-buffer gnus-article-copy) 473 (set-buffer gnus-article-copy)
388 (delete-region (goto-char (point-min)) 474 (delete-region (goto-char (point-min))
389 (or (search-forward "\n\n" nil t) (point))) 475 (or (search-forward "\n\n" nil t) (point-max)))
390 ;; Insert the original article headers. 476 ;; Insert the original article headers.
391 (insert-buffer-substring gnus-original-article-buffer beg end) 477 (insert-buffer-substring gnus-original-article-buffer beg end)
392 (gnus-article-decode-rfc1522))) 478 (article-decode-encoded-words)))
393 gnus-article-copy))) 479 gnus-article-copy)))
394 480
395 (defun gnus-post-news (post &optional group header article-buffer yank subject 481 (defun gnus-post-news (post &optional group header article-buffer yank subject
396 force-news) 482 force-news)
397 (when article-buffer 483 (when article-buffer
400 (add-to-list gnus-add-to-list)) 486 (add-to-list gnus-add-to-list))
401 (gnus-setup-message (cond (yank 'reply-yank) 487 (gnus-setup-message (cond (yank 'reply-yank)
402 (article-buffer 'reply) 488 (article-buffer 'reply)
403 (t 'message)) 489 (t 'message))
404 (let* ((group (or group gnus-newsgroup-name)) 490 (let* ((group (or group gnus-newsgroup-name))
491 (charset (gnus-group-name-charset nil group))
405 (pgroup group) 492 (pgroup group)
406 to-address to-group mailing-list to-list 493 to-address to-group mailing-list to-list
407 newsgroup-p) 494 newsgroup-p)
408 (when group 495 (when group
409 (setq to-address (gnus-group-find-parameter group 'to-address) 496 (setq to-address (gnus-group-find-parameter group 'to-address)
410 to-group (gnus-group-find-parameter group 'to-group) 497 to-group (gnus-group-find-parameter group 'to-group)
411 to-list (gnus-group-find-parameter group 'to-list) 498 to-list (gnus-group-find-parameter group 'to-list)
412 newsgroup-p (gnus-group-find-parameter group 'newsgroup) 499 newsgroup-p (gnus-group-find-parameter group 'newsgroup)
413 mailing-list (when gnus-mailing-list-groups 500 mailing-list (when gnus-mailing-list-groups
414 (string-match gnus-mailing-list-groups group)) 501 (string-match gnus-mailing-list-groups group))
415 group (gnus-group-real-name group))) 502 group (gnus-group-name-decode (gnus-group-real-name group)
503 charset)))
416 (if (or (and to-group 504 (if (or (and to-group
417 (gnus-news-group-p to-group)) 505 (gnus-news-group-p to-group))
418 newsgroup-p 506 newsgroup-p
419 force-news 507 force-news
420 (and (gnus-news-group-p 508 (and (gnus-news-group-p
462 (cond 550 (cond
463 ;; If the group-method is nil (which shouldn't happen) we use 551 ;; If the group-method is nil (which shouldn't happen) we use
464 ;; the default method. 552 ;; the default method.
465 ((null group-method) 553 ((null group-method)
466 (or (and (null (eq gnus-post-method 'active)) gnus-post-method) 554 (or (and (null (eq gnus-post-method 'active)) gnus-post-method)
467 gnus-select-method message-post-method)) 555 gnus-select-method message-post-method))
468 ;; We want the inverse of the default 556 ;; We want the inverse of the default
469 ((and arg (not (eq arg 0))) 557 ((and arg (not (eq arg 0)))
470 (if (eq gnus-post-method 'active) 558 (if (eq gnus-post-method 'active)
471 gnus-select-method 559 gnus-select-method
472 group-method)) 560 group-method))
483 (if (listp (car gnus-post-method)) 571 (if (listp (car gnus-post-method))
484 gnus-post-method 572 gnus-post-method
485 (list gnus-post-method))) 573 (list gnus-post-method)))
486 gnus-secondary-select-methods 574 gnus-secondary-select-methods
487 (mapcar 'cdr gnus-server-alist) 575 (mapcar 'cdr gnus-server-alist)
576 (mapcar 'car gnus-opened-servers)
488 (list gnus-select-method) 577 (list gnus-select-method)
489 (list group-method))) 578 (list group-method)))
490 method-alist post-methods method) 579 method-alist post-methods method)
491 ;; Weed out all mail methods. 580 ;; Weed out all mail methods.
492 (while methods 581 (while methods
493 (setq method (gnus-server-get-method "" (pop methods))) 582 (setq method (gnus-server-get-method "" (pop methods)))
494 (when (or (gnus-method-option-p method 'post) 583 (when (and (or (gnus-method-option-p method 'post)
495 (gnus-method-option-p method 'post-mail)) 584 (gnus-method-option-p method 'post-mail))
585 (not (member method post-methods)))
496 (push method post-methods))) 586 (push method post-methods)))
497 ;; Create a name-method alist. 587 ;; Create a name-method alist.
498 (setq method-alist 588 (setq method-alist
499 (mapcar 589 (mapcar
500 (lambda (m) 590 (lambda (m)
513 (cons (or gnus-last-posting-server "") 0)))) 603 (cons (or gnus-last-posting-server "") 0))))
514 method-alist)))) 604 method-alist))))
515 ;; Override normal method. 605 ;; Override normal method.
516 ((and (eq gnus-post-method 'current) 606 ((and (eq gnus-post-method 'current)
517 (not (eq (car group-method) 'nndraft)) 607 (not (eq (car group-method) 'nndraft))
608 (gnus-get-function group-method 'request-post t)
518 (not arg)) 609 (not arg))
519 group-method) 610 group-method)
520 ((and gnus-post-method 611 ((and gnus-post-method
521 (not (eq gnus-post-method 'current))) 612 (not (eq gnus-post-method 'current)))
522 gnus-post-method) 613 gnus-post-method)
523 ;; Use the normal select method. 614 ;; Use the normal select method.
524 (t gnus-select-method)))) 615 (t gnus-select-method))))
525 616
526 617
527 618
528 ;; Dummy to avoid byte-compile warning. 619 ;; Dummies to avoid byte-compile warning.
529 (defvar nnspool-rejected-article-hook) 620 (defvar nnspool-rejected-article-hook)
530 (defvar xemacs-codename) 621 (defvar xemacs-codename)
531 622
532 ;;; Since the X-Newsreader/X-Mailer are ``vanity'' headers, they might
533 ;;; as well include the Emacs version as well.
534 ;;; The following function works with later GNU Emacs, and XEmacs.
535 (defun gnus-extended-version () 623 (defun gnus-extended-version ()
536 "Stringified Gnus version and Emacs version." 624 "Stringified Gnus version and Emacs version."
537 (interactive) 625 (interactive)
538 (concat 626 (concat
539 gnus-version 627 "Gnus/" (prin1-to-string (gnus-continuum-version gnus-version) t)
540 "/" 628 " (" gnus-version ")"
629 " "
541 (cond 630 (cond
542 ((string-match "^\\([0-9]+\\.[0-9]+\\)\\.[.0-9]+$" emacs-version) 631 ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version)
543 (concat "Emacs " (substring emacs-version 632 (concat "Emacs/" (match-string 1 emacs-version)))
544 (match-beginning 1)
545 (match-end 1))))
546 ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?" 633 ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?"
547 emacs-version) 634 emacs-version)
548 (concat (substring emacs-version 635 (concat (match-string 1 emacs-version)
549 (match-beginning 1) 636 (format "/%d.%d" emacs-major-version emacs-minor-version)
550 (match-end 1))
551 (format " %d.%d" emacs-major-version emacs-minor-version)
552 (if (match-beginning 3) 637 (if (match-beginning 3)
553 (substring emacs-version 638 (match-string 3 emacs-version)
554 (match-beginning 3)
555 (match-end 3))
556 "") 639 "")
557 (if (boundp 'xemacs-codename) 640 (if (boundp 'xemacs-codename)
558 (concat " - \"" xemacs-codename "\"")))) 641 (concat " (" xemacs-codename ")")
642 "")))
559 (t emacs-version)))) 643 (t emacs-version))))
560
561 ;; Written by "Mr. Per Persson" <pp@gnu.org>.
562 (defun gnus-inews-insert-mime-headers ()
563 "Insert MIME headers.
564 Assumes ISO-Latin-1 is used iff 8-bit characters are present."
565 (goto-char (point-min))
566 (let ((mail-header-separator
567 (progn
568 (goto-char (point-min))
569 (if (and (search-forward (concat "\n" mail-header-separator "\n")
570 nil t)
571 (not (search-backward "\n\n" nil t)))
572 mail-header-separator
573 ""))))
574 (or (mail-position-on-field "Mime-Version")
575 (insert "1.0")
576 (cond ((save-restriction
577 (widen)
578 (goto-char (point-min))
579 (re-search-forward "[^\000-\177]" nil t))
580 (or (mail-position-on-field "Content-Type")
581 (insert "text/plain; charset=ISO-8859-1"))
582 (or (mail-position-on-field "Content-Transfer-Encoding")
583 (insert "8bit")))
584 (t (or (mail-position-on-field "Content-Type")
585 (insert "text/plain; charset=US-ASCII"))
586 (or (mail-position-on-field "Content-Transfer-Encoding")
587 (insert "7bit")))))))
588
589 (custom-add-option 'message-header-hook 'gnus-inews-insert-mime-headers)
590 644
591 645
592 ;;; 646 ;;;
593 ;;; Gnus Mail Functions 647 ;;; Gnus Mail Functions
594 ;;; 648 ;;;
608 (let ((gnus-article-reply t)) 662 (let ((gnus-article-reply t))
609 (gnus-setup-message (if yank 'reply-yank 'reply) 663 (gnus-setup-message (if yank 'reply-yank 'reply)
610 (gnus-summary-select-article) 664 (gnus-summary-select-article)
611 (set-buffer (gnus-copy-article-buffer)) 665 (set-buffer (gnus-copy-article-buffer))
612 (gnus-msg-treat-broken-reply-to) 666 (gnus-msg-treat-broken-reply-to)
667 (save-restriction
668 (message-narrow-to-head)
669 (goto-char (point-max)))
670 (mml-quote-region (point) (point-max))
613 (message-reply nil wide) 671 (message-reply nil wide)
614 (when yank 672 (when yank
615 (gnus-inews-yank-articles yank))))) 673 (gnus-inews-yank-articles yank)))))
616 674
617 (defun gnus-summary-reply-with-original (n &optional wide) 675 (defun gnus-summary-reply-with-original (n &optional wide)
633 "Start composing a wide reply mail to the current message. 691 "Start composing a wide reply mail to the current message.
634 The original article will be yanked." 692 The original article will be yanked."
635 (interactive "P") 693 (interactive "P")
636 (gnus-summary-reply-with-original n t)) 694 (gnus-summary-reply-with-original n t))
637 695
638 (defun gnus-summary-mail-forward (&optional full-headers post) 696 (defun gnus-summary-mail-forward (&optional arg post)
639 "Forward the current message to another user. 697 "Forward the current message to another user.
640 If FULL-HEADERS (the prefix), include full headers when forwarding." 698 If ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml';
699 if ARG is 1, decode the message and forward directly inline;
700 if ARG is 2, foward message as an rfc822 MIME section;
701 if ARG is 3, decode message and forward as an rfc822 MIME section;
702 if ARG is 4, foward message directly inline;
703 otherwise, use flipped `message-forward-as-mime'.
704 If POST, post instead of mail."
641 (interactive "P") 705 (interactive "P")
642 (gnus-setup-message 'forward 706 (let ((message-forward-as-mime message-forward-as-mime)
643 (gnus-summary-select-article) 707 (message-forward-show-mml message-forward-show-mml))
644 (set-buffer gnus-original-article-buffer) 708 (cond
645 (let ((message-included-forward-headers 709 ((null arg))
646 (if full-headers "" message-included-forward-headers))) 710 ((eq arg 1) (setq message-forward-as-mime nil
647 (message-forward post)))) 711 message-forward-show-mml t))
712 ((eq arg 2) (setq message-forward-as-mime t
713 message-forward-show-mml nil))
714 ((eq arg 3) (setq message-forward-as-mime t
715 message-forward-show-mml t))
716 ((eq arg 4) (setq message-forward-as-mime nil
717 message-forward-show-mml nil))
718 (t (setq message-forward-as-mime (not message-forward-as-mime))))
719 (gnus-setup-message 'forward
720 (gnus-summary-select-article)
721 (let ((mail-parse-charset gnus-newsgroup-charset)
722 (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
723 text)
724 (save-excursion
725 (set-buffer gnus-original-article-buffer)
726 (mm-with-unibyte-current-buffer
727 (setq text (buffer-string))))
728 (set-buffer
729 (gnus-get-buffer-create
730 (generate-new-buffer-name " *Gnus forward*")))
731 (erase-buffer)
732 (mm-disable-multibyte)
733 (insert text)
734 (goto-char (point-min))
735 (when (looking-at "From ")
736 (replace-match "X-From-Line: ") )
737 (when message-forward-show-mml
738 (mm-enable-multibyte)
739 (mime-to-mml))
740 (message-forward post)))))
648 741
649 (defun gnus-summary-resend-message (address n) 742 (defun gnus-summary-resend-message (address n)
650 "Resend the current article to ADDRESS." 743 "Resend the current article to ADDRESS."
651 (interactive "sResend message(s) to: \nP") 744 (interactive "sResend message(s) to: \nP")
652 (let ((articles (gnus-summary-work-articles n)) 745 (let ((articles (gnus-summary-work-articles n))
655 (gnus-summary-select-article nil nil nil article) 748 (gnus-summary-select-article nil nil nil article)
656 (save-excursion 749 (save-excursion
657 (set-buffer gnus-original-article-buffer) 750 (set-buffer gnus-original-article-buffer)
658 (message-resend address))))) 751 (message-resend address)))))
659 752
660 (defun gnus-summary-post-forward (&optional full-headers) 753 (defun gnus-summary-post-forward (&optional arg)
661 "Forward the current article to a newsgroup. 754 "Forward the current article to a newsgroup.
662 If FULL-HEADERS (the prefix), include full headers when forwarding." 755 See `gnus-summary-mail-forward' for ARG."
663 (interactive "P") 756 (interactive "P")
664 (gnus-summary-mail-forward full-headers t)) 757 (gnus-summary-mail-forward arg t))
665 758
666 (defvar gnus-nastygram-message 759 (defvar gnus-nastygram-message
667 "The following article was inappropriately posted to %s.\n\n" 760 "The following article was inappropriately posted to %s.\n\n"
668 "Format string to insert in nastygrams. 761 "Format string to insert in nastygrams.
669 The current group name will be inserted at \"%s\".") 762 The current group name will be inserted at \"%s\".")
692 (let ((group (gnus-group-real-name gnus-newsgroup-name)) 785 (let ((group (gnus-group-real-name gnus-newsgroup-name))
693 newsgroups followup-to) 786 newsgroups followup-to)
694 (gnus-summary-select-article) 787 (gnus-summary-select-article)
695 (set-buffer gnus-original-article-buffer) 788 (set-buffer gnus-original-article-buffer)
696 (if (and (<= (length (message-tokenize-header 789 (if (and (<= (length (message-tokenize-header
697 (setq newsgroups (mail-fetch-field "newsgroups")) 790 (setq newsgroups
791 (mail-fetch-field "newsgroups"))
698 ", ")) 792 ", "))
699 1) 793 1)
700 (or (not (setq followup-to (mail-fetch-field "followup-to"))) 794 (or (not (setq followup-to (mail-fetch-field "followup-to")))
701 (not (member group (message-tokenize-header 795 (not (member group (message-tokenize-header
702 followup-to ", "))))) 796 followup-to ", ")))))
831 (emacs-version) "\n") 925 (emacs-version) "\n")
832 (when (and (boundp 'nntp-server-type) 926 (when (and (boundp 'nntp-server-type)
833 (stringp nntp-server-type)) 927 (stringp nntp-server-type))
834 (insert nntp-server-type)) 928 (insert nntp-server-type))
835 (insert "\n\n\n\n\n") 929 (insert "\n\n\n\n\n")
836 (gnus-debug) 930 (let (text)
931 (save-excursion
932 (set-buffer (gnus-get-buffer-create " *gnus environment info*"))
933 (gnus-debug)
934 (setq text (buffer-string)))
935 (insert "<#part type=application/x-emacs-lisp disposition=inline description=\"User settings\">\n" text "\n<#/part>"))
837 (goto-char (point-min)) 936 (goto-char (point-min))
838 (search-forward "Subject: " nil t) 937 (search-forward "Subject: " nil t)
839 (message ""))) 938 (message "")))
840 939
841 (defun gnus-bug-kill-buffer () 940 (defun gnus-bug-kill-buffer ()
842 (when (get-buffer "*Gnus Help Bug*") 941 (when (get-buffer "*Gnus Help Bug*")
843 (kill-buffer "*Gnus Help Bug*"))) 942 (kill-buffer "*Gnus Help Bug*")))
943
944 (defun gnus-summary-yank-message (buffer n)
945 "Yank the current article into a composed message."
946 (interactive
947 (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t)
948 current-prefix-arg))
949 (gnus-summary-iterate n
950 (let ((gnus-display-mime-function nil)
951 (gnus-inhibit-treatment t))
952 (gnus-summary-select-article))
953 (save-excursion
954 (set-buffer buffer)
955 (message-yank-buffer gnus-article-buffer))))
844 956
845 (defun gnus-debug () 957 (defun gnus-debug ()
846 "Attempts to go through the Gnus source file and report what variables have been changed. 958 "Attempts to go through the Gnus source file and report what variables have been changed.
847 The source file has to be in the Emacs load path." 959 The source file has to be in the Emacs load path."
848 (interactive) 960 (interactive)
855 (gnus-message 4 "Please wait while we snoop your variables...") 967 (gnus-message 4 "Please wait while we snoop your variables...")
856 (sit-for 0) 968 (sit-for 0)
857 ;; Go through all the files looking for non-default values for variables. 969 ;; Go through all the files looking for non-default values for variables.
858 (save-excursion 970 (save-excursion
859 (set-buffer (gnus-get-buffer-create " *gnus bug info*")) 971 (set-buffer (gnus-get-buffer-create " *gnus bug info*"))
860 (buffer-disable-undo (current-buffer))
861 (while files 972 (while files
862 (erase-buffer) 973 (erase-buffer)
863 (when (and (setq file (locate-library (pop files))) 974 (when (and (setq file (locate-library (pop files)))
864 (file-exists-p file)) 975 (file-exists-p file))
865 (insert-file-contents file) 976 (insert-file-contents file)
938 (cur (current-buffer)) 1049 (cur (current-buffer))
939 groups group method) 1050 groups group method)
940 (when gcc 1051 (when gcc
941 (message-remove-header "gcc") 1052 (message-remove-header "gcc")
942 (widen) 1053 (widen)
943 (setq groups (message-tokenize-header gcc " ,")) 1054 (setq groups (message-unquote-tokens
1055 (message-tokenize-header gcc " ,")))
944 ;; Copy the article over to some group(s). 1056 ;; Copy the article over to some group(s).
945 (while (setq group (pop groups)) 1057 (while (setq group (pop groups))
946 (gnus-check-server 1058 (gnus-check-server
947 (setq method 1059 (setq method
948 (cond ((and (null (gnus-get-info group)) 1060 (cond ((and (null (gnus-get-info group))
962 (unless (gnus-request-group group t method) 1074 (unless (gnus-request-group group t method)
963 (gnus-request-create-group group method)) 1075 (gnus-request-create-group group method))
964 (save-excursion 1076 (save-excursion
965 (nnheader-set-temp-buffer " *acc*") 1077 (nnheader-set-temp-buffer " *acc*")
966 (insert-buffer-substring cur) 1078 (insert-buffer-substring cur)
1079 (message-encode-message-body)
1080 (save-restriction
1081 (message-narrow-to-headers)
1082 (let ((mail-parse-charset message-default-charset)
1083 (rfc2047-header-encoding-alist
1084 (cons '("Newsgroups" . default)
1085 rfc2047-header-encoding-alist)))
1086 (mail-encode-encoded-word-buffer)))
967 (goto-char (point-min)) 1087 (goto-char (point-min))
968 (when (re-search-forward 1088 (when (re-search-forward
969 (concat "^" (regexp-quote mail-header-separator) "$") 1089 (concat "^" (regexp-quote mail-header-separator) "$")
970 nil t) 1090 nil t)
971 (replace-match "" t t )) 1091 (replace-match "" t t ))
972 (unless (gnus-request-accept-article group method t) 1092 (unless (gnus-request-accept-article group method t t)
973 (gnus-message 1 "Couldn't store article in group %s: %s" 1093 (gnus-message 1 "Couldn't store article in group %s: %s"
974 group (gnus-status-message method)) 1094 group (gnus-status-message method))
975 (sit-for 2)) 1095 (sit-for 2))
976 (kill-buffer (current-buffer)))))))))) 1096 (kill-buffer (current-buffer))))))))))
977 1097
996 "Insert the Gcc to say where the article is to be archived." 1116 "Insert the Gcc to say where the article is to be archived."
997 (let* ((var gnus-message-archive-group) 1117 (let* ((var gnus-message-archive-group)
998 (group (or group gnus-newsgroup-name "")) 1118 (group (or group gnus-newsgroup-name ""))
999 (gcc-self-val 1119 (gcc-self-val
1000 (and gnus-newsgroup-name 1120 (and gnus-newsgroup-name
1121 (not (equal gnus-newsgroup-name ""))
1001 (gnus-group-find-parameter 1122 (gnus-group-find-parameter
1002 gnus-newsgroup-name 'gcc-self))) 1123 gnus-newsgroup-name 'gcc-self)))
1003 result 1124 result
1004 (groups 1125 (groups
1005 (cond 1126 (cond
1006 ((null gnus-message-archive-method) 1127 ((null gnus-message-archive-method)
1007 ;; Ignore. 1128 ;; Ignore.
1008 nil) 1129 nil)
1066 (insert " "))) 1187 (insert " ")))
1067 (insert "\n"))))))) 1188 (insert "\n")))))))
1068 1189
1069 ;;; Posting styles. 1190 ;;; Posting styles.
1070 1191
1071 (defvar gnus-message-style-insertions nil)
1072
1073 (defun gnus-configure-posting-styles () 1192 (defun gnus-configure-posting-styles ()
1074 "Configure posting styles according to `gnus-posting-styles'." 1193 "Configure posting styles according to `gnus-posting-styles'."
1075 (unless gnus-inhibit-posting-styles 1194 (unless gnus-inhibit-posting-styles
1076 (let ((styles gnus-posting-styles) 1195 (let ((group (or gnus-newsgroup-name ""))
1077 (gnus-newsgroup-name (or gnus-newsgroup-name "")) 1196 (styles gnus-posting-styles)
1078 style match variable attribute value value-value) 1197 style match variable attribute value v results
1079 (make-local-variable 'gnus-message-style-insertions) 1198 filep name address element)
1199 ;; If the group has a posting-style parameter, add it at the end with a
1200 ;; regexp matching everything, to be sure it takes precedence over all
1201 ;; the others.
1202 (when gnus-newsgroup-name
1203 (let ((tmp-style (gnus-group-find-parameter group 'posting-style t)))
1204 (when tmp-style
1205 (setq styles (append styles (list (cons ".*" tmp-style)))))))
1080 ;; Go through all styles and look for matches. 1206 ;; Go through all styles and look for matches.
1081 (while styles 1207 (dolist (style styles)
1082 (setq style (pop styles) 1208 (setq match (pop style))
1083 match (pop style)) 1209 (goto-char (point-min))
1084 (when (cond ((stringp match) 1210 (when (cond
1085 ;; Regexp string match on the group name. 1211 ((stringp match)
1086 (string-match match gnus-newsgroup-name)) 1212 ;; Regexp string match on the group name.
1087 ((or (symbolp match) 1213 (string-match match group))
1088 (gnus-functionp match)) 1214 ((eq match 'header)
1089 (cond ((gnus-functionp match) 1215 (let ((header (message-fetch-field (pop style))))
1090 ;; Function to be called. 1216 (and header
1091 (funcall match)) 1217 (string-match (pop style) header))))
1092 ((boundp match) 1218 ((or (symbolp match)
1093 ;; Variable to be checked. 1219 (gnus-functionp match))
1094 (symbol-value match)))) 1220 (cond
1095 ((listp match) 1221 ((gnus-functionp match)
1096 ;; This is a form to be evaled. 1222 ;; Function to be called.
1097 (eval match))) 1223 (funcall match))
1224 ((boundp match)
1225 ;; Variable to be checked.
1226 (symbol-value match))))
1227 ((listp match)
1228 ;; This is a form to be evaled.
1229 (eval match)))
1098 ;; We have a match, so we set the variables. 1230 ;; We have a match, so we set the variables.
1099 (while style 1231 (dolist (attribute style)
1100 (setq attribute (pop style) 1232 (setq element (pop attribute)
1101 value (cadr attribute) 1233 variable nil
1102 variable nil) 1234 filep nil)
1103 ;; We find the variable that is to be modified. 1235 (setq value
1104 (if (and (not (stringp (car attribute))) 1236 (cond
1105 (not (eq 'body (car attribute))) 1237 ((eq (car attribute) :file)
1106 (not (setq variable 1238 (setq filep t)
1107 (cdr (assq (car attribute) 1239 (cadr attribute))
1108 gnus-posting-style-alist))))) 1240 ((eq (car attribute) :value)
1109 (message "Couldn't find attribute %s" (car attribute)) 1241 (cadr attribute))
1110 ;; We get the value. 1242 (t
1111 (setq value-value 1243 (car attribute))))
1112 (cond ((stringp value) 1244 ;; We get the value.
1113 value) 1245 (setq v
1114 ((or (symbolp value) 1246 (cond
1115 (gnus-functionp value)) 1247 ((stringp value)
1116 (cond ((gnus-functionp value) 1248 value)
1117 (funcall value)) 1249 ((or (symbolp value)
1118 ((boundp value) 1250 (gnus-functionp value))
1119 (symbol-value value)))) 1251 (cond ((gnus-functionp value)
1120 ((listp value) 1252 (funcall value))
1121 (eval value)))) 1253 ((boundp value)
1122 (if variable 1254 (symbol-value value))))
1123 ;; This is an ordinary variable. 1255 ((listp value)
1124 (set (make-local-variable variable) value-value) 1256 (eval value))))
1125 ;; This is either a body or a header to be inserted in the 1257 ;; Translate obsolescent value.
1126 ;; message. 1258 (when (eq element 'signature-file)
1127 (when value-value 1259 (setq element 'signature
1128 (let ((attr (car attribute))) 1260 filep t))
1129 (make-local-variable 'message-setup-hook) 1261 ;; Get the contents of file elems.
1130 (if (eq 'body attr) 1262 (when (and filep v)
1131 (add-hook 'message-setup-hook 1263 (setq v (with-temp-buffer
1132 `(lambda () 1264 (insert-file-contents v)
1133 (save-excursion 1265 (buffer-string))))
1134 (message-goto-body) 1266 (setq results (delq (assoc element results) results))
1135 (insert ,value-value)))) 1267 (push (cons element v) results))))
1136 (add-hook 'message-setup-hook 1268 ;; Now we have all the styles, so we insert them.
1137 'gnus-message-insert-stylings) 1269 (setq name (assq 'name results)
1138 (push (cons (if (stringp attr) attr 1270 address (assq 'address results))
1139 (symbol-name attr)) 1271 (setq results (delq name (delq address results)))
1140 value-value) 1272 (make-local-variable 'message-setup-hook)
1141 gnus-message-style-insertions)))))))))))) 1273 (dolist (result results)
1142 1274 (add-hook 'message-setup-hook
1143 (defun gnus-message-insert-stylings () 1275 (cond
1144 (let (val) 1276 ((eq 'eval (car result))
1145 (save-excursion 1277 'ignore)
1146 (message-goto-eoh) 1278 ((eq 'body (car result))
1147 (while (setq val (pop gnus-message-style-insertions)) 1279 `(lambda ()
1148 (when (cdr val) 1280 (save-excursion
1149 (insert (car val) ": " (cdr val) "\n")) 1281 (message-goto-body)
1150 (gnus-pull (car val) gnus-message-style-insertions))))) 1282 (insert ,(cdr result)))))
1283 ((eq 'signature (car result))
1284 (set (make-local-variable 'message-signature) nil)
1285 (set (make-local-variable 'message-signature-file) nil)
1286 (if (not (cdr result))
1287 'ignore
1288 `(lambda ()
1289 (save-excursion
1290 (let ((message-signature ,(cdr result)))
1291 (when message-signature
1292 (message-insert-signature)))))))
1293 (t
1294 (let ((header
1295 (if (symbolp (car result))
1296 (capitalize (symbol-name (car result)))
1297 (car result))))
1298 `(lambda ()
1299 (save-excursion
1300 (message-remove-header ,header)
1301 (let ((value ,(cdr result)))
1302 (when value
1303 (message-goto-eoh)
1304 (insert ,header ": " value "\n"))))))))))
1305 (when (or name address)
1306 (add-hook 'message-setup-hook
1307 `(lambda ()
1308 (set (make-local-variable 'user-mail-address)
1309 ,(or (cdr address) user-mail-address))
1310 (let ((user-full-name ,(or (cdr name) (user-full-name)))
1311 (user-mail-address
1312 ,(or (cdr address) user-mail-address)))
1313 (save-excursion
1314 (message-remove-header "From")
1315 (message-goto-eoh)
1316 (insert "From: " (message-make-from) "\n")))))))))
1151 1317
1152 ;;; Allow redefinition of functions. 1318 ;;; Allow redefinition of functions.
1153 1319
1154 (gnus-ems-redefine) 1320 (gnus-ems-redefine)
1155 1321