cgit.sxemacs.org Git - gnus/blob - lisp/gnus-msg.el

   1 ;;; gnus-msg.el --- mail and post interface for Gnus
   2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   6 ;;      Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (eval-when-compile (require 'cl))
  31
  32 (require 'gnus)
  33 (require 'gnus-ems)
  34 (require 'message)
  35 (require 'gnus-art)
  36
  37 (defcustom gnus-post-method 'current
  38   "*Preferred method for posting USENET news.
  39
  40 If this variable is `current', Gnus will use the \"current\" select
  41 method when posting.  If it is nil (which is the default), Gnus will
  42 use the native select method when posting.
  43
  44 This method will not be used in mail groups and the like, only in
  45 \"real\" newsgroups.
  46
  47 If not nil nor `native', the value must be a valid method as discussed
  48 in the documentation of `gnus-select-method'.  It can also be a list of
  49 methods.  If that is the case, the user will be queried for what select
  50 method to use when posting."
  51   :group 'gnus-group-foreign
  52   :type `(choice (const nil)
  53                  (const current)
  54                  (const native)
  55                  (sexp :tag "Methods" ,gnus-select-method)))
  56
  57 (defvar gnus-outgoing-message-group nil
  58   "*All outgoing messages will be put in this group.
  59 If you want to store all your outgoing mail and articles in the group
  60 \"nnml:archive\", you set this variable to that value.  This variable
  61 can also be a list of group names.
  62
  63 If you want to have greater control over what group to put each
  64 message in, you can set this variable to a function that checks the
  65 current newsgroup name and then returns a suitable group name (or list
  66 of names).")
  67
  68 (defvar gnus-mailing-list-groups nil
  69   "*Regexp matching groups that are really mailing lists.
  70 This is useful when you're reading a mailing list that has been
  71 gatewayed to a newsgroup, and you want to followup to an article in
  72 the group.")
  73
  74 (defvar gnus-add-to-list nil
  75   "*If non-nil, add a `to-list' parameter automatically.")
  76
  77 (defvar gnus-crosspost-complaint
  78   "Hi,
  79
  80 You posted the article below with the following Newsgroups header:
  81
  82 Newsgroups: %s
  83
  84 The %s group, at least, was an inappropriate recipient
  85 of this message.  Please trim your Newsgroups header to exclude this
  86 group before posting in the future.
  87
  88 Thank you.
  89
  90 "
  91   "Format string to be inserted when complaining about crossposts.
  92 The first %s will be replaced by the Newsgroups header;
  93 the second with the current group name.")
  94
  95 (defvar gnus-message-setup-hook nil
  96   "Hook run after setting up a message buffer.")
  97
  98 (defvar gnus-bug-create-help-buffer t
  99   "*Should we create the *Gnus Help Bug* buffer?")
 100
 101 (defvar gnus-posting-styles nil
 102   "*Alist of styles to use when posting.")
 103
 104 (defvar gnus-inews-mark-gcc-as-read nil
 105   "If non-nil, automatically mark Gcc articles as read.")
 106
 107 (defcustom gnus-group-posting-charset-alist
 108   '(("^\\(no\\|fr\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1))
 109     ("^\\(fido7\\|relcom\\)\\.[^,]*\\(,[ \t\n]*\\(fido7\\|relcom\\)\\.[^,]*\\)*$" koi8-r (koi8-r))
 110     (message-this-is-mail nil nil)
 111     (message-this-is-news nil t))
 112   "Alist of regexps and permitted unencoded charsets for posting.
 113 Each element of the alist has the form (TEST HEADER BODY-LIST), where
 114 TEST is either a regular expression matching the newsgroup header or a
 115 variable to query,
 116 HEADER is the charset which may be left unencoded in the header (nil
 117 means encode all charsets),
 118 BODY-LIST is a list of charsets which may be encoded using 8bit
 119 content-transfer encoding in the body, or one of the special values
 120 nil (always encode using quoted-printable) or t (always use 8bit).
 121
 122 Note that any value other than nil for HEADER infringes some RFCs, so
 123 use this option with care."
 124   :type '(repeat (list :tag "Permitted unencoded charsets"
 125                   (choice :tag "Where"
 126                    (regexp :tag "Group")
 127                    (const :tag "Mail message" :value message-this-is-mail)
 128                    (const :tag "News article" :value message-this-is-news))
 129                   (choice :tag "Header"
 130                    (const :tag "None" nil)
 131                    (symbol :tag "Charset"))
 132                   (choice :tag "Body"
 133                           (const :tag "Any" :value t)
 134                           (const :tag "None" :value nil)
 135                           (repeat :tag "Charsets"
 136                                   (symbol :tag "Charset")))))
 137   :group 'gnus-charset)
 138
 139 ;;; Internal variables.
 140
 141 (defvar gnus-inhibit-posting-styles nil
 142   "Inhibit the use of posting styles.")
 143
 144 (defvar gnus-message-buffer "*Mail Gnus*")
 145 (defvar gnus-article-copy nil)
 146 (defvar gnus-last-posting-server nil)
 147 (defvar gnus-message-group-art nil)
 148
 149 (defconst gnus-bug-message
 150   "Sending a bug report to the Gnus Towers.
 151 ========================================
 152
 153 The buffer below is a mail buffer.  When you press `C-c C-c', it will
 154 be sent to the Gnus Bug Exterminators.
 155
 156 The thing near the bottom of the buffer is how the environment
 157 settings will be included in the mail.  Please do not delete that.
 158 They will tell the Bug People what your environment is, so that it
 159 will be easier to locate the bugs.
 160
 161 If you have found a bug that makes Emacs go \"beep\", set
 162 debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET')
 163 and include the backtrace in your bug report.
 164
 165 Please describe the bug in annoying, painstaking detail.
 166
 167 Thank you for your help in stamping out bugs.
 168 ")
 169
 170 (eval-and-compile
 171   (autoload 'gnus-uu-post-news "gnus-uu" nil t)
 172   (autoload 'news-setup "rnewspost")
 173   (autoload 'news-reply-mode "rnewspost")
 174   (autoload 'rmail-dont-reply-to "mail-utils")
 175   (autoload 'rmail-output "rmailout"))
 176
 177 \f
 178 ;;;
 179 ;;; Gnus Posting Functions
 180 ;;;
 181
 182 (gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map)
 183   "p" gnus-summary-post-news
 184   "f" gnus-summary-followup
 185   "F" gnus-summary-followup-with-original
 186   "c" gnus-summary-cancel-article
 187   "s" gnus-summary-supersede-article
 188   "r" gnus-summary-reply
 189   "y" gnus-summary-yank-message
 190   "R" gnus-summary-reply-with-original
 191   "w" gnus-summary-wide-reply
 192   "W" gnus-summary-wide-reply-with-original
 193   "n" gnus-summary-followup-to-mail
 194   "N" gnus-summary-followup-to-mail-with-original
 195   "m" gnus-summary-mail-other-window
 196   "u" gnus-uu-post-news
 197   "\M-c" gnus-summary-mail-crosspost-complaint
 198   "om" gnus-summary-mail-forward
 199   "op" gnus-summary-post-forward
 200   "Om" gnus-uu-digest-mail-forward
 201   "Op" gnus-uu-digest-post-forward)
 202
 203 (gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map)
 204   "b" gnus-summary-resend-bounced-mail
 205   ;; "c" gnus-summary-send-draft
 206   "r" gnus-summary-resend-message)
 207
 208 ;;; Internal functions.
 209
 210 (defvar gnus-article-reply nil)
 211 (defmacro gnus-setup-message (config &rest forms)
 212   (let ((winconf (make-symbol "gnus-setup-message-winconf"))
 213         (buffer (make-symbol "gnus-setup-message-buffer"))
 214         (article (make-symbol "gnus-setup-message-article"))
 215         (group (make-symbol "gnus-setup-message-group")))
 216     `(let ((,winconf (current-window-configuration))
 217            (,buffer (buffer-name (current-buffer)))
 218            (,article (and gnus-article-reply (gnus-summary-article-number)))
 219            (,group gnus-newsgroup-name)
 220            (message-header-setup-hook
 221             (copy-sequence message-header-setup-hook))
 222            (mbl mml-buffer-list)
 223            (message-mode-hook (copy-sequence message-mode-hook)))
 224        (setq mml-buffer-list nil)
 225        (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
 226        (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
 227        (add-hook 'message-mode-hook 'gnus-configure-posting-styles)
 228        (unwind-protect
 229            (progn
 230              ,@forms)
 231          (gnus-inews-add-send-actions ,winconf ,buffer ,article)
 232          (setq gnus-message-buffer (current-buffer))
 233          (set (make-local-variable 'gnus-message-group-art)
 234               (cons ,group ,article))
 235          (set (make-local-variable 'gnus-newsgroup-name) ,group)
 236          (gnus-run-hooks 'gnus-message-setup-hook)
 237          (if (eq major-mode 'message-mode)
 238              (let ((mbl1 mml-buffer-list))
 239                (setq mml-buffer-list mbl)  ;; Global value
 240                (set (make-local-variable 'mml-buffer-list) mbl1);; Local value
 241                (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))
 242            (mml-destroy-buffers)
 243            (setq mml-buffer-list mbl)))
 244        (gnus-add-buffer)
 245        (gnus-configure-windows ,config t)
 246        (set-buffer-modified-p nil))))
 247
 248 ;;;###autoload
 249 (defun gnus-msg-mail (&rest args)
 250   "Start editing a mail message to be sent.
 251 Like `message-mail', but with Gnus paraphernalia, particularly the
 252 Gcc: header for archiving purposes."
 253   (interactive)
 254   (gnus-setup-message 'message
 255     (apply 'message-mail args))
 256   ;; COMPOSEFUNC should return t if succeed.  Undocumented ???
 257   t)
 258
 259 ;;;###autoload
 260 (define-mail-user-agent 'gnus-user-agent
 261       'gnus-msg-mail 'message-send-and-exit
 262       'message-kill-buffer 'message-send-hook)
 263
 264 (defun gnus-setup-posting-charset (group)
 265   (let ((alist gnus-group-posting-charset-alist)
 266         (group (or group ""))
 267         elem)
 268     (when group
 269       (catch 'found
 270         (while (setq elem (pop alist))
 271           (when (or (and (stringp (car elem))
 272                          (string-match (car elem) group))
 273                     (and (gnus-functionp (car elem))
 274                          (funcall (car elem) group))
 275                     (and (symbolp (car elem))
 276                          (symbol-value (car elem))))
 277             (throw 'found (cons (cadr elem) (caddr elem)))))))))
 278
 279 (defun gnus-inews-add-send-actions (winconf buffer article)
 280   (make-local-hook 'message-sent-hook)
 281   (add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc
 282                                  'gnus-inews-do-gcc) nil t)
 283   (when gnus-agent
 284     (make-local-hook 'message-header-hook)
 285     (add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t))
 286   (setq message-post-method
 287         `(lambda (arg)
 288            (gnus-post-method arg ,gnus-newsgroup-name)))
 289   (setq message-newsreader (setq message-mailer (gnus-extended-version)))
 290   (message-add-action
 291    `(set-window-configuration ,winconf) 'exit 'postpone 'kill)
 292   (message-add-action
 293    `(when (gnus-buffer-exists-p ,buffer)
 294       (save-excursion
 295         (set-buffer ,buffer)
 296         ,(when article
 297            `(gnus-summary-mark-article-as-replied ,article))))
 298    'send))
 299
 300 (put 'gnus-setup-message 'lisp-indent-function 1)
 301 (put 'gnus-setup-message 'edebug-form-spec '(form body))
 302
 303 ;;; Post news commands of Gnus group mode and summary mode
 304
 305 (defun gnus-group-mail (&optional arg)
 306   "Start composing a mail.
 307 If ARG, use the group under the point to find a posting style.
 308 If ARG is 1, prompt for a group name to find the posting style."
 309   (interactive "P")
 310   ;; We can't `let' gnus-newsgroup-name here, since that leads
 311   ;; to local variables leaking.
 312   (let ((group gnus-newsgroup-name)
 313         (buffer (current-buffer)))
 314     (unwind-protect
 315         (progn
 316           (setq gnus-newsgroup-name
 317                 (if arg
 318                     (if (= 1 (prefix-numeric-value arg))
 319                         (completing-read "Use posting style of group: "
 320                                          gnus-active-hashtb nil
 321                                          (gnus-read-active-file-p))
 322                       (gnus-group-group-name))
 323                   ""))
 324           (gnus-setup-message 'message (message-mail)))
 325       (save-excursion
 326         (set-buffer buffer)
 327         (setq gnus-newsgroup-name group)))))
 328
 329 (defun gnus-group-post-news (&optional arg)
 330   "Start composing a news message.
 331 If ARG, post to the group under point.
 332 If ARG is 1, prompt for a group name."
 333   (interactive "P")
 334   ;; Bind this variable here to make message mode hooks work ok.
 335   (let ((gnus-newsgroup-name
 336          (if arg
 337              (if (= 1 (prefix-numeric-value arg))
 338                  (completing-read "Newsgroup: " gnus-active-hashtb nil
 339                                   (gnus-read-active-file-p))
 340                (gnus-group-group-name))
 341            "")))
 342     (gnus-post-news 'post gnus-newsgroup-name)))
 343
 344 (defun gnus-summary-post-news ()
 345   "Start composing a news message."
 346   (interactive)
 347   (gnus-post-news 'post gnus-newsgroup-name))
 348
 349 (defun gnus-summary-followup (yank &optional force-news)
 350   "Compose a followup to an article.
 351 If prefix argument YANK is non-nil, original article is yanked automatically."
 352   (interactive
 353    (list (and current-prefix-arg
 354               (gnus-summary-work-articles 1))))
 355   (when yank
 356     (gnus-summary-goto-subject (car yank)))
 357   (save-window-excursion
 358     (gnus-summary-select-article))
 359   (let ((headers (gnus-summary-article-header (gnus-summary-article-number)))
 360         (gnus-newsgroup-name gnus-newsgroup-name))
 361     ;; Send a followup.
 362     (gnus-post-news nil gnus-newsgroup-name
 363                     headers gnus-article-buffer
 364                     yank nil force-news)))
 365
 366 (defun gnus-summary-followup-with-original (n &optional force-news)
 367   "Compose a followup to an article and include the original article."
 368   (interactive "P")
 369   (gnus-summary-followup (gnus-summary-work-articles n) force-news))
 370
 371 (defun gnus-summary-followup-to-mail (&optional arg)
 372   "Followup to the current mail message via news."
 373   (interactive
 374    (list (and current-prefix-arg
 375               (gnus-summary-work-articles 1))))
 376   (gnus-summary-followup arg t))
 377
 378 (defun gnus-summary-followup-to-mail-with-original (&optional arg)
 379   "Followup to the current mail message via news."
 380   (interactive "P")
 381   (gnus-summary-followup (gnus-summary-work-articles arg) t))
 382
 383 (defun gnus-inews-yank-articles (articles)
 384   (let (beg article)
 385     (message-goto-body)
 386     (while (setq article (pop articles))
 387       (save-window-excursion
 388         (set-buffer gnus-summary-buffer)
 389         (gnus-summary-select-article nil nil nil article)
 390         (gnus-summary-remove-process-mark article))
 391       (gnus-copy-article-buffer)
 392       (let ((message-reply-buffer gnus-article-copy)
 393             (message-reply-headers gnus-current-headers))
 394         (message-yank-original)
 395         (setq beg (or beg (mark t))))
 396       (when articles
 397         (insert "\n")))
 398     (push-mark)
 399     (goto-char beg)))
 400
 401 (defun gnus-summary-cancel-article (&optional n symp)
 402   "Cancel an article you posted.
 403 Uses the process-prefix convention.  If given the symbolic
 404 prefix `a', cancel using the standard posting method; if not
 405 post using the current select method."
 406   (interactive (gnus-interactive "P\ny"))
 407   (let ((articles (gnus-summary-work-articles n))
 408         (message-post-method
 409          `(lambda (arg)
 410             (gnus-post-method (not (eq symp 'a)) ,gnus-newsgroup-name)))
 411         article)
 412     (while (setq article (pop articles))
 413       (when (gnus-summary-select-article t nil nil article)
 414         (when (gnus-eval-in-buffer-window gnus-original-article-buffer
 415                 (message-cancel-news))
 416           (gnus-summary-mark-as-read article gnus-canceled-mark)
 417           (gnus-cache-remove-article 1))
 418         (gnus-article-hide-headers-if-wanted))
 419       (gnus-summary-remove-process-mark article))))
 420
 421 (defun gnus-summary-supersede-article ()
 422   "Compose an article that will supersede a previous article.
 423 This is done simply by taking the old article and adding a Supersedes
 424 header line with the old Message-ID."
 425   (interactive)
 426   (let ((article (gnus-summary-article-number)))
 427     (gnus-setup-message 'reply-yank
 428       (gnus-summary-select-article t)
 429       (set-buffer gnus-original-article-buffer)
 430       (message-supersede)
 431       (push
 432        `((lambda ()
 433            (when (gnus-buffer-exists-p ,gnus-summary-buffer)
 434              (save-excursion
 435                (set-buffer ,gnus-summary-buffer)
 436                (gnus-cache-possibly-remove-article ,article nil nil nil t)
 437                (gnus-summary-mark-as-read ,article gnus-canceled-mark)))))
 438        message-send-actions))))
 439
 440 \f
 441
 442 (defun gnus-copy-article-buffer (&optional article-buffer)
 443   ;; make a copy of the article buffer with all text properties removed
 444   ;; this copy is in the buffer gnus-article-copy.
 445   ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
 446   ;; this buffer should be passed to all mail/news reply/post routines.
 447   (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*"))
 448   (save-excursion
 449     (set-buffer gnus-article-copy)
 450     (mm-enable-multibyte))
 451   (let ((article-buffer (or article-buffer gnus-article-buffer))
 452         end beg)
 453     (if (not (and (get-buffer article-buffer)
 454                   (gnus-buffer-exists-p article-buffer)))
 455         (error "Can't find any article buffer")
 456       (save-excursion
 457         (set-buffer article-buffer)
 458         (let ((gnus-newsgroup-charset (or gnus-article-charset
 459                                           gnus-newsgroup-charset))
 460               (gnus-newsgroup-ignored-charsets
 461                (or gnus-article-ignored-charsets
 462                    gnus-newsgroup-ignored-charsets)))
 463           (save-restriction
 464             ;; Copy over the (displayed) article buffer, delete
 465             ;; hidden text and remove text properties.
 466             (widen)
 467             (copy-to-buffer gnus-article-copy (point-min) (point-max))
 468             (set-buffer gnus-article-copy)
 469             (gnus-article-delete-text-of-type 'annotation)
 470             (gnus-remove-text-with-property 'gnus-prev)
 471             (gnus-remove-text-with-property 'gnus-next)
 472             (insert
 473              (prog1
 474                  (buffer-substring-no-properties (point-min) (point-max))
 475                (erase-buffer)))
 476             ;; Find the original headers.
 477             (set-buffer gnus-original-article-buffer)
 478             (goto-char (point-min))
 479             (while (looking-at message-unix-mail-delimiter)
 480               (forward-line 1))
 481             (setq beg (point))
 482             (setq end (or (search-forward "\n\n" nil t) (point)))
 483             ;; Delete the headers from the displayed articles.
 484             (set-buffer gnus-article-copy)
 485             (delete-region (goto-char (point-min))
 486                            (or (search-forward "\n\n" nil t) (point-max)))
 487             ;; Insert the original article headers.
 488             (insert-buffer-substring gnus-original-article-buffer beg end)
 489             (article-decode-encoded-words))))
 490       gnus-article-copy)))
 491
 492 (defun gnus-post-news (post &optional group header article-buffer yank subject
 493                             force-news)
 494   (when article-buffer
 495     (gnus-copy-article-buffer))
 496   (let ((gnus-article-reply article-buffer)
 497         (add-to-list gnus-add-to-list))
 498     (gnus-setup-message (cond (yank 'reply-yank)
 499                               (article-buffer 'reply)
 500                               (t 'message))
 501       (let* ((group (or group gnus-newsgroup-name))
 502              (charset (gnus-group-name-charset nil group))
 503              (pgroup group)
 504              to-address to-group mailing-list to-list
 505              newsgroup-p)
 506         (when group
 507           (setq to-address (gnus-group-find-parameter group 'to-address)
 508                 to-group (gnus-group-find-parameter group 'to-group)
 509                 to-list (gnus-group-find-parameter group 'to-list)
 510                 newsgroup-p (gnus-group-find-parameter group 'newsgroup)
 511                 mailing-list (when gnus-mailing-list-groups
 512                                (string-match gnus-mailing-list-groups group))
 513                 group (gnus-group-name-decode (gnus-group-real-name group)
 514                                               charset)))
 515         (if (or (and to-group
 516                      (gnus-news-group-p to-group))
 517                 newsgroup-p
 518                 force-news
 519                 (and (gnus-news-group-p
 520                       (or pgroup gnus-newsgroup-name)
 521                       (if header (mail-header-number header)
 522                         gnus-current-article))
 523                      (not mailing-list)
 524                      (not to-list)
 525                      (not to-address)))
 526             ;; This is news.
 527             (if post
 528                 (message-news (or to-group group))
 529               (set-buffer gnus-article-copy)
 530               (gnus-msg-treat-broken-reply-to)
 531               (message-followup (if (or newsgroup-p force-news) nil to-group)))
 532           ;; The is mail.
 533           (if post
 534               (progn
 535                 (message-mail (or to-address to-list))
 536                 ;; Arrange for mail groups that have no `to-address' to
 537                 ;; get that when the user sends off the mail.
 538                 (when (and (not to-list)
 539                            (not to-address)
 540                            add-to-list)
 541                   (push (list 'gnus-inews-add-to-address pgroup)
 542                         message-send-actions)))
 543             (set-buffer gnus-article-copy)
 544             (gnus-msg-treat-broken-reply-to)
 545             (message-wide-reply to-address)))
 546         (when yank
 547           (gnus-inews-yank-articles yank))))))
 548
 549 (defun gnus-msg-treat-broken-reply-to ()
 550   "Remove the Reply-to header iff broken-reply-to."
 551   (when (gnus-group-find-parameter
 552          gnus-newsgroup-name 'broken-reply-to)
 553     (save-restriction
 554       (message-narrow-to-head)
 555       (message-remove-header "reply-to"))))
 556
 557 (defun gnus-post-method (arg group &optional silent)
 558   "Return the posting method based on GROUP and ARG.
 559 If SILENT, don't prompt the user."
 560   (let ((group-method (gnus-find-method-for-group group)))
 561     (cond
 562      ;; If the group-method is nil (which shouldn't happen) we use
 563      ;; the default method.
 564      ((null group-method)
 565       (or (and (null (eq gnus-post-method 'active)) gnus-post-method)
 566           gnus-select-method message-post-method))
 567      ;; We want the inverse of the default
 568      ((and arg (not (eq arg 0)))
 569       (if (eq gnus-post-method 'active)
 570           gnus-select-method
 571         group-method))
 572      ;; We query the user for a post method.
 573      ((or arg
 574           (and gnus-post-method
 575                (not (eq gnus-post-method 'current))
 576                (listp (car gnus-post-method))))
 577       (let* ((methods
 578               ;; Collect all methods we know about.
 579               (append
 580                (when (and gnus-post-method
 581                           (not (eq gnus-post-method 'current)))
 582                  (if (listp (car gnus-post-method))
 583                      gnus-post-method
 584                    (list gnus-post-method)))
 585                gnus-secondary-select-methods
 586                (mapcar 'cdr gnus-server-alist)
 587                (mapcar 'car gnus-opened-servers)
 588                (list gnus-select-method)
 589                (list group-method)))
 590              method-alist post-methods method)
 591         ;; Weed out all mail methods.
 592         (while methods
 593           (setq method (gnus-server-get-method "" (pop methods)))
 594           (when (and (or (gnus-method-option-p method 'post)
 595                          (gnus-method-option-p method 'post-mail))
 596                      (not (member method post-methods)))
 597             (push method post-methods)))
 598         ;; Create a name-method alist.
 599         (setq method-alist
 600               (mapcar
 601                (lambda (m)
 602                  (list (concat (cadr m) " (" (symbol-name (car m)) ")") m))
 603                post-methods))
 604         ;; Query the user.
 605         (cadr
 606          (assoc
 607           (setq gnus-last-posting-server
 608                 (if (and silent
 609                          gnus-last-posting-server)
 610                     ;; Just use the last value.
 611                     gnus-last-posting-server
 612                   (completing-read
 613                    "Posting method: " method-alist nil t
 614                    (cons (or gnus-last-posting-server "") 0))))
 615           method-alist))))
 616      ;; Override normal method.
 617      ((and (eq gnus-post-method 'current)
 618            (not (eq (car group-method) 'nndraft))
 619            (gnus-get-function group-method 'request-post t)
 620            (not arg))
 621       group-method)
 622      ((and gnus-post-method
 623            (not (eq gnus-post-method 'current)))
 624       gnus-post-method)
 625      ;; Use the normal select method.
 626      (t gnus-select-method))))
 627
 628 \f
 629
 630 ;; Dummies to avoid byte-compile warning.
 631 (defvar nnspool-rejected-article-hook)
 632 (defvar xemacs-codename)
 633
 634 (defun gnus-extended-version ()
 635   "Stringified Gnus version and Emacs version."
 636   (interactive)
 637   (concat
 638    "Gnus/" (prin1-to-string (gnus-continuum-version gnus-version) t)
 639    " (" gnus-version ")"
 640    " "
 641    (cond
 642     ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version)
 643      (concat "Emacs/" (match-string 1 emacs-version)))
 644     ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?"
 645                    emacs-version)
 646      (concat (match-string 1 emacs-version)
 647              (format "/%d.%d" emacs-major-version emacs-minor-version)
 648              (if (match-beginning 3)
 649                  (match-string 3 emacs-version)
 650                "")
 651              (if (boundp 'xemacs-codename)
 652                  (concat " (" xemacs-codename ")")
 653                "")))
 654     (t emacs-version))))
 655
 656 \f
 657 ;;;
 658 ;;; Gnus Mail Functions
 659 ;;;
 660
 661 ;;; Mail reply commands of Gnus summary mode
 662
 663 (defun gnus-summary-reply (&optional yank wide)
 664   "Start composing a reply mail to the current message.
 665 If prefix argument YANK is non-nil, the original article is yanked
 666 automatically."
 667   (interactive
 668    (list (and current-prefix-arg
 669               (gnus-summary-work-articles 1))))
 670   ;; Stripping headers should be specified with mail-yank-ignored-headers.
 671   (when yank
 672     (gnus-summary-goto-subject (car yank)))
 673   (let ((gnus-article-reply t))
 674     (gnus-setup-message (if yank 'reply-yank 'reply)
 675       (gnus-summary-select-article)
 676       (set-buffer (gnus-copy-article-buffer))
 677       (gnus-msg-treat-broken-reply-to)
 678       (save-restriction
 679         (message-narrow-to-head)
 680         (goto-char (point-max)))
 681       (mml-quote-region (point) (point-max))
 682       (message-reply nil wide)
 683       (when yank
 684         (gnus-inews-yank-articles yank)))))
 685
 686 (defun gnus-summary-reply-with-original (n &optional wide)
 687   "Start composing a reply mail to the current message.
 688 The original article will be yanked."
 689   (interactive "P")
 690   (gnus-summary-reply (gnus-summary-work-articles n) wide))
 691
 692 (defun gnus-summary-wide-reply (&optional yank)
 693   "Start composing a wide reply mail to the current message.
 694 If prefix argument YANK is non-nil, the original article is yanked
 695 automatically."
 696   (interactive
 697    (list (and current-prefix-arg
 698               (gnus-summary-work-articles 1))))
 699   (gnus-summary-reply yank t))
 700
 701 (defun gnus-summary-wide-reply-with-original (n)
 702   "Start composing a wide reply mail to the current message.
 703 The original article will be yanked."
 704   (interactive "P")
 705   (gnus-summary-reply-with-original n t))
 706
 707 (defun gnus-summary-mail-forward (&optional arg post)
 708   "Forward the current message to another user.
 709 If ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml';
 710 if ARG is 1, decode the message and forward directly inline;
 711 if ARG is 2, forward message as an rfc822 MIME section;
 712 if ARG is 3, decode message and forward as an rfc822 MIME section;
 713 if ARG is 4, forward message directly inline;
 714 otherwise, use flipped `message-forward-as-mime'.
 715 If POST, post instead of mail."
 716   (interactive "P")
 717   (let ((message-forward-as-mime message-forward-as-mime)
 718         (message-forward-show-mml message-forward-show-mml))
 719     (cond
 720      ((null arg))
 721      ((eq arg 1) (setq message-forward-as-mime nil
 722                        message-forward-show-mml t))
 723      ((eq arg 2) (setq message-forward-as-mime t
 724                        message-forward-show-mml nil))
 725      ((eq arg 3) (setq message-forward-as-mime t
 726                        message-forward-show-mml t))
 727      ((eq arg 4) (setq message-forward-as-mime nil
 728                        message-forward-show-mml nil))
 729      (t (setq message-forward-as-mime (not message-forward-as-mime))))
 730     (gnus-setup-message 'forward
 731       (gnus-summary-select-article)
 732       (let ((mail-parse-charset gnus-newsgroup-charset)
 733             (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
 734             text)
 735         (save-excursion
 736           (set-buffer gnus-original-article-buffer)
 737           (setq text (buffer-string)))
 738         (set-buffer
 739          (gnus-get-buffer-create
 740           (generate-new-buffer-name " *Gnus forward*")))
 741         (erase-buffer)
 742         (unless message-forward-show-mml
 743           (mm-disable-multibyte))
 744         (insert text)
 745         (goto-char (point-min))
 746         (when (looking-at "From ")
 747           (replace-match "X-From-Line: ") )
 748         (when message-forward-show-mml
 749           (mime-to-mml))
 750         (message-forward post)))))
 751
 752 (defun gnus-summary-resend-message (address n)
 753   "Resend the current article to ADDRESS."
 754   (interactive "sResend message(s) to: \nP")
 755   (let ((articles (gnus-summary-work-articles n))
 756         article)
 757     (while (setq article (pop articles))
 758       (gnus-summary-select-article nil nil nil article)
 759       (save-excursion
 760         (set-buffer gnus-original-article-buffer)
 761         (message-resend address)))))
 762
 763 (defun gnus-summary-post-forward (&optional arg)
 764   "Forward the current article to a newsgroup.
 765 See `gnus-summary-mail-forward' for ARG."
 766   (interactive "P")
 767   (gnus-summary-mail-forward arg t))
 768
 769 (defvar gnus-nastygram-message
 770   "The following article was inappropriately posted to %s.\n\n"
 771   "Format string to insert in nastygrams.
 772 The current group name will be inserted at \"%s\".")
 773
 774 (defun gnus-summary-mail-nastygram (n)
 775   "Send a nastygram to the author of the current article."
 776   (interactive "P")
 777   (when (or gnus-expert-user
 778             (gnus-y-or-n-p
 779              "Really send a nastygram to the author of the current article? "))
 780     (let ((group gnus-newsgroup-name))
 781       (gnus-summary-reply-with-original n)
 782       (set-buffer gnus-message-buffer)
 783       (message-goto-body)
 784       (insert (format gnus-nastygram-message group))
 785       (message-send-and-exit))))
 786
 787 (defun gnus-summary-mail-crosspost-complaint (n)
 788   "Send a complaint about crossposting to the current article(s)."
 789   (interactive "P")
 790   (let ((articles (gnus-summary-work-articles n))
 791         article)
 792     (while (setq article (pop articles))
 793       (set-buffer gnus-summary-buffer)
 794       (gnus-summary-goto-subject article)
 795       (let ((group (gnus-group-real-name gnus-newsgroup-name))
 796             newsgroups followup-to)
 797         (gnus-summary-select-article)
 798         (set-buffer gnus-original-article-buffer)
 799         (if (and (<= (length (message-tokenize-header
 800                               (setq newsgroups
 801                                     (mail-fetch-field "newsgroups"))
 802                               ", "))
 803                      1)
 804                  (or (not (setq followup-to (mail-fetch-field "followup-to")))
 805                      (not (member group (message-tokenize-header
 806                                          followup-to ", ")))))
 807             (if followup-to
 808                 (gnus-message 1 "Followup-to restricted")
 809               (gnus-message 1 "Not a crossposted article"))
 810           (set-buffer gnus-summary-buffer)
 811           (gnus-summary-reply-with-original 1)
 812           (set-buffer gnus-message-buffer)
 813           (message-goto-body)
 814           (insert (format gnus-crosspost-complaint newsgroups group))
 815           (message-goto-subject)
 816           (re-search-forward " *$")
 817           (replace-match " (crosspost notification)" t t)
 818           (gnus-deactivate-mark)
 819           (when (gnus-y-or-n-p "Send this complaint? ")
 820             (message-send-and-exit)))))))
 821
 822 (defun gnus-summary-mail-other-window ()
 823   "Compose mail in other window."
 824   (interactive)
 825   (gnus-setup-message 'message
 826     (message-mail)))
 827
 828 (defun gnus-mail-parse-comma-list ()
 829   (let (accumulated
 830         beg)
 831     (skip-chars-forward " ")
 832     (while (not (eobp))
 833       (setq beg (point))
 834       (skip-chars-forward "^,")
 835       (while (zerop
 836               (save-excursion
 837                 (save-restriction
 838                   (let ((i 0))
 839                     (narrow-to-region beg (point))
 840                     (goto-char beg)
 841                     (logand (progn
 842                               (while (search-forward "\"" nil t)
 843                                 (incf i))
 844                               (if (zerop i) 2 i))
 845                             2)))))
 846         (skip-chars-forward ",")
 847         (skip-chars-forward "^,"))
 848       (skip-chars-backward " ")
 849       (push (buffer-substring beg (point))
 850             accumulated)
 851       (skip-chars-forward "^,")
 852       (skip-chars-forward ", "))
 853     accumulated))
 854
 855 (defun gnus-inews-add-to-address (group)
 856   (let ((to-address (mail-fetch-field "to")))
 857     (when (and to-address
 858                (gnus-alive-p))
 859       ;; This mail group doesn't have a `to-list', so we add one
 860       ;; here.  Magic!
 861       (when (gnus-y-or-n-p
 862              (format "Do you want to add this as `to-list': %s " to-address))
 863         (gnus-group-add-parameter group (cons 'to-list to-address))))))
 864
 865 (defun gnus-put-message ()
 866   "Put the current message in some group and return to Gnus."
 867   (interactive)
 868   (let ((reply gnus-article-reply)
 869         (winconf gnus-prev-winconf)
 870         (group gnus-newsgroup-name))
 871
 872     (or (and group (not (gnus-group-read-only-p group)))
 873         (setq group (read-string "Put in group: " nil
 874                                  (gnus-writable-groups))))
 875     (when (gnus-gethash group gnus-newsrc-hashtb)
 876       (error "No such group: %s" group))
 877
 878     (save-excursion
 879       (save-restriction
 880         (widen)
 881         (message-narrow-to-headers)
 882         (let (gnus-deletable-headers)
 883           (if (message-news-p)
 884               (message-generate-headers message-required-news-headers)
 885             (message-generate-headers message-required-mail-headers)))
 886         (goto-char (point-max))
 887         (insert "Gcc: " group "\n")
 888         (widen)))
 889
 890     (gnus-inews-do-gcc)
 891
 892     (when (get-buffer gnus-group-buffer)
 893       (when (gnus-buffer-exists-p (car-safe reply))
 894         (set-buffer (car reply))
 895         (and (cdr reply)
 896              (gnus-summary-mark-article-as-replied
 897               (cdr reply))))
 898       (when winconf
 899         (set-window-configuration winconf)))))
 900
 901 (defun gnus-article-mail (yank)
 902   "Send a reply to the address near point.
 903 If YANK is non-nil, include the original article."
 904   (interactive "P")
 905   (let ((address
 906          (buffer-substring
 907           (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point)))
 908           (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point))))))
 909     (when address
 910       (message-reply address)
 911       (when yank
 912         (gnus-inews-yank-articles (list (cdr gnus-article-current)))))))
 913
 914 (defvar nntp-server-type)
 915 (defun gnus-bug ()
 916   "Send a bug report to the Gnus maintainers."
 917   (interactive)
 918   (unless (gnus-alive-p)
 919     (error "Gnus has been shut down"))
 920   (gnus-setup-message 'bug
 921     (delete-other-windows)
 922     (when gnus-bug-create-help-buffer
 923       (switch-to-buffer "*Gnus Help Bug*")
 924       (erase-buffer)
 925       (insert gnus-bug-message)
 926       (goto-char (point-min)))
 927     (message-pop-to-buffer "*Gnus Bug*")
 928     (message-setup `((To . ,gnus-maintainer) (Subject . "")))
 929     (when gnus-bug-create-help-buffer
 930       (push `(gnus-bug-kill-buffer) message-send-actions))
 931     (goto-char (point-min))
 932     (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
 933     (forward-line 1)
 934     (insert (gnus-version) "\n"
 935             (emacs-version) "\n")
 936     (when (and (boundp 'nntp-server-type)
 937                (stringp nntp-server-type))
 938       (insert nntp-server-type))
 939     (insert "\n\n\n\n\n")
 940     (let (text)
 941       (save-excursion
 942         (set-buffer (gnus-get-buffer-create " *gnus environment info*"))
 943         (gnus-debug)
 944         (setq text (buffer-string)))
 945       (insert "<#part type=application/x-emacs-lisp disposition=inline description=\"User settings\">\n" text "\n<#/part>"))
 946     (goto-char (point-min))
 947     (search-forward "Subject: " nil t)
 948     (message "")))
 949
 950 (defun gnus-bug-kill-buffer ()
 951   (when (get-buffer "*Gnus Help Bug*")
 952     (kill-buffer "*Gnus Help Bug*")))
 953
 954 (defun gnus-summary-yank-message (buffer n)
 955   "Yank the current article into a composed message."
 956   (interactive
 957    (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t)
 958          current-prefix-arg))
 959   (gnus-summary-iterate n
 960     (let ((gnus-display-mime-function nil)
 961           (gnus-inhibit-treatment t))
 962       (gnus-summary-select-article))
 963     (save-excursion
 964       (set-buffer buffer)
 965       (message-yank-buffer gnus-article-buffer))))
 966
 967 (defun gnus-debug ()
 968   "Attempts to go through the Gnus source file and report what variables have been changed.
 969 The source file has to be in the Emacs load path."
 970   (interactive)
 971   (let ((files '("gnus.el" "gnus-sum.el" "gnus-group.el"
 972                  "gnus-art.el" "gnus-start.el" "gnus-async.el"
 973                  "gnus-msg.el" "gnus-score.el" "gnus-win.el" "gnus-topic.el"
 974                  "nnmail.el" "message.el"))
 975         (point (point))
 976         file expr olist sym)
 977     (gnus-message 4 "Please wait while we snoop your variables...")
 978     (sit-for 0)
 979     ;; Go through all the files looking for non-default values for variables.
 980     (save-excursion
 981       (set-buffer (gnus-get-buffer-create " *gnus bug info*"))
 982       (while files
 983         (erase-buffer)
 984         (when (and (setq file (locate-library (pop files)))
 985                    (file-exists-p file))
 986           (insert-file-contents file)
 987           (goto-char (point-min))
 988           (if (not (re-search-forward "^;;* *Internal variables" nil t))
 989               (gnus-message 4 "Malformed sources in file %s" file)
 990             (narrow-to-region (point-min) (point))
 991             (goto-char (point-min))
 992             (while (setq expr (ignore-errors (read (current-buffer))))
 993               (ignore-errors
 994                 (and (or (eq (car expr) 'defvar)
 995                          (eq (car expr) 'defcustom))
 996                      (stringp (nth 3 expr))
 997                      (or (not (boundp (nth 1 expr)))
 998                          (not (equal (eval (nth 2 expr))
 999                                      (symbol-value (nth 1 expr)))))
1000                      (push (nth 1 expr) olist)))))))
1001       (kill-buffer (current-buffer)))
1002     (when (setq olist (nreverse olist))
1003       (insert "------------------ Environment follows ------------------\n\n"))
1004     (while olist
1005       (if (boundp (car olist))
1006           (condition-case ()
1007               (pp `(setq ,(car olist)
1008                          ,(if (or (consp (setq sym (symbol-value (car olist))))
1009                                   (and (symbolp sym)
1010                                        (not (or (eq sym nil)
1011                                                 (eq sym t)))))
1012                               (list 'quote (symbol-value (car olist)))
1013                             (symbol-value (car olist))))
1014                   (current-buffer))
1015             (error
1016              (format "(setq %s 'whatever)\n" (car olist))))
1017         (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))
1018       (setq olist (cdr olist)))
1019     (insert "\n\n")
1020     ;; Remove any control chars - they seem to cause trouble for some
1021     ;; mailers.  (Byte-compiled output from the stuff above.)
1022     (goto-char point)
1023     (while (re-search-forward "[\000-\010\013-\037\200-\237]" nil t)
1024       (replace-match (format "\\%03o" (string-to-char (match-string 0)))
1025                      t t))))
1026
1027 ;;; Treatment of rejected articles.
1028 ;;; Bounced mail.
1029
1030 (defun gnus-summary-resend-bounced-mail (&optional fetch)
1031   "Re-mail the current message.
1032 This only makes sense if the current message is a bounce message than
1033 contains some mail you have written which has been bounced back to
1034 you.
1035 If FETCH, try to fetch the article that this is a reply to, if indeed
1036 this is a reply."
1037   (interactive "P")
1038   (gnus-summary-select-article t)
1039   (set-buffer gnus-original-article-buffer)
1040   (gnus-setup-message 'compose-bounce
1041     (let* ((references (mail-fetch-field "references"))
1042            (parent (and references (gnus-parent-id references))))
1043       (message-bounce)
1044       ;; If there are references, we fetch the article we answered to.
1045       (and fetch parent
1046            (gnus-summary-refer-article parent)
1047            (gnus-summary-show-all-headers)))))
1048
1049 ;;; Gcc handling.
1050
1051 (defun gnus-inews-group-method (group)
1052   (cond ((and (null (gnus-get-info group))
1053               (eq (car gnus-message-archive-method)
1054                   (car
1055                    (gnus-server-to-method
1056                     (gnus-group-method group)))))
1057          ;; If the group doesn't exist, we assume
1058          ;; it's an archive group...
1059          gnus-message-archive-method)
1060         ;; Use the method.
1061         ((gnus-info-method (gnus-get-info group))
1062          (gnus-info-method (gnus-get-info group)))
1063         ;; Find the method.
1064         (t (gnus-group-method group))))
1065
1066 ;; Do Gcc handling, which copied the message over to some group.
1067 (defun gnus-inews-do-gcc (&optional gcc)
1068   (interactive)
1069   (when (gnus-alive-p)
1070     (save-excursion
1071       (save-restriction
1072         (message-narrow-to-headers)
1073         (let ((gcc (or gcc (mail-fetch-field "gcc" nil t)))
1074               (cur (current-buffer))
1075               groups group method group-art)
1076           (when gcc
1077             (message-remove-header "gcc")
1078             (widen)
1079             (setq groups (message-unquote-tokens
1080                           (message-tokenize-header gcc " ,")))
1081             ;; Copy the article over to some group(s).
1082             (while (setq group (pop groups))
1083               (gnus-check-server
1084                (setq method (gnus-inews-group-method group)))
1085               (unless (gnus-request-group group t method)
1086                 (gnus-request-create-group group method))
1087               (save-excursion
1088                 (nnheader-set-temp-buffer " *acc*")
1089                 (insert-buffer-substring cur)
1090                 (message-encode-message-body)
1091                 (save-restriction
1092                   (message-narrow-to-headers)
1093                   (let ((mail-parse-charset message-default-charset)
1094                         (rfc2047-header-encoding-alist
1095                          (cons '("Newsgroups" . default)
1096                                rfc2047-header-encoding-alist)))
1097                     (mail-encode-encoded-word-buffer)))
1098                 (goto-char (point-min))
1099                 (when (re-search-forward
1100                        (concat "^" (regexp-quote mail-header-separator) "$")
1101                        nil t)
1102                   (replace-match "" t t ))
1103                 (unless (setq group-art
1104                               (gnus-request-accept-article group method t t))
1105                   (gnus-message 1 "Couldn't store article in group %s: %s"
1106                                 group (gnus-status-message method))
1107                   (sit-for 2))
1108                 (when (and group-art gnus-inews-mark-gcc-as-read)
1109                   (let ((active (gnus-active group)))
1110                     (if active
1111                         (if (< (cdr active) (cdr group-art))
1112                             (gnus-set-active group (cons (car active)
1113                                                          (cdr group-art))))
1114                       (gnus-activate-group group)))
1115                   (let ((buffer (concat "*Summary " group "*"))
1116                         (mark gnus-read-mark)
1117                         (article (cdr group-art)))
1118                     (unless
1119                         (and
1120                          (get-buffer buffer)
1121                          (with-current-buffer buffer
1122                            (when gnus-newsgroup-prepared
1123                              (when (and gnus-newsgroup-auto-expire
1124                                         (memq mark gnus-auto-expirable-marks))
1125                                (setq mark gnus-expirable-mark))
1126                              (setq mark (gnus-request-update-mark
1127                                          group article mark))
1128                              (gnus-mark-article-as-read article mark)
1129                              (setq gnus-newsgroup-active (gnus-active group))
1130                              t)))
1131                       (gnus-group-make-articles-read group
1132                                                      (list article))
1133                       (when (gnus-group-auto-expirable-p group)
1134                         (gnus-add-marked-articles
1135                          group 'expire (list article))))))
1136                 (kill-buffer (current-buffer))))))))))
1137
1138 (defun gnus-inews-insert-gcc ()
1139   "Insert Gcc headers based on `gnus-outgoing-message-group'."
1140   (save-excursion
1141     (save-restriction
1142       (message-narrow-to-headers)
1143       (let* ((group gnus-outgoing-message-group)
1144              (gcc (cond
1145                    ((gnus-functionp group)
1146                     (funcall group))
1147                    ((or (stringp group) (list group))
1148                     group))))
1149         (when gcc
1150           (insert "Gcc: "
1151                   (if (stringp gcc) gcc
1152                     (mapconcat 'identity gcc " "))
1153                   "\n"))))))
1154
1155 (defun gnus-inews-insert-archive-gcc (&optional group)
1156   "Insert the Gcc to say where the article is to be archived."
1157   (let* ((var gnus-message-archive-group)
1158          (group (or group gnus-newsgroup-name ""))
1159          (gcc-self-val
1160           (and gnus-newsgroup-name
1161                (not (equal gnus-newsgroup-name ""))
1162                (gnus-group-find-parameter
1163                 gnus-newsgroup-name 'gcc-self)))
1164          result
1165          (groups
1166           (cond
1167            ((null gnus-message-archive-method)
1168             ;; Ignore.
1169             nil)
1170            ((stringp var)
1171             ;; Just a single group.
1172             (list var))
1173            ((null var)
1174             ;; We don't want this.
1175             nil)
1176            ((and (listp var) (stringp (car var)))
1177             ;; A list of groups.
1178             var)
1179            ((gnus-functionp var)
1180             ;; A function.
1181             (funcall var group))
1182            (t
1183             ;; An alist of regexps/functions/forms.
1184             (while (and var
1185                         (not
1186                          (setq result
1187                                (cond
1188                                 ((stringp (caar var))
1189                                  ;; Regexp.
1190                                  (when (string-match (caar var) group)
1191                                    (cdar var)))
1192                                 ((gnus-functionp (car var))
1193                                  ;; Function.
1194                                  (funcall (car var) group))
1195                                 (t
1196                                  (eval (car var)))))))
1197               (setq var (cdr var)))
1198             result)))
1199          name)
1200     (when (or groups gcc-self-val)
1201       (when (stringp groups)
1202         (setq groups (list groups)))
1203       (save-excursion
1204         (save-restriction
1205           (message-narrow-to-headers)
1206           (goto-char (point-max))
1207           (insert "Gcc: ")
1208           (if gcc-self-val
1209               ;; Use the `gcc-self' param value instead.
1210               (progn
1211                 (insert
1212                  (if (stringp gcc-self-val)
1213                      gcc-self-val
1214                    group))
1215                 (if (not (eq gcc-self-val 'none))
1216                     (insert "\n")
1217                   (progn
1218                     (beginning-of-line)
1219                     (kill-line))))
1220             ;; Use the list of groups.
1221             (while (setq name (pop groups))
1222               (insert (if (string-match ":" name)
1223                           name
1224                         (gnus-group-prefixed-name
1225                          name gnus-message-archive-method)))
1226               (when groups
1227                 (insert " ")))
1228             (insert "\n")))))))
1229
1230 ;;; Posting styles.
1231
1232 (defun gnus-configure-posting-styles ()
1233   "Configure posting styles according to `gnus-posting-styles'."
1234   (unless gnus-inhibit-posting-styles
1235     (let ((group (or gnus-newsgroup-name ""))
1236           (styles gnus-posting-styles)
1237           style match variable attribute value v results
1238           filep name address element)
1239       ;; If the group has a posting-style parameter, add it at the end with a
1240       ;; regexp matching everything, to be sure it takes precedence over all
1241       ;; the others.
1242       (when gnus-newsgroup-name
1243         (let ((tmp-style (gnus-group-find-parameter group 'posting-style t)))
1244           (when tmp-style
1245             (setq styles (append styles (list (cons ".*" tmp-style)))))))
1246       ;; Go through all styles and look for matches.
1247       (dolist (style styles)
1248         (setq match (pop style))
1249         (goto-char (point-min))
1250         (when (cond
1251                ((stringp match)
1252                 ;; Regexp string match on the group name.
1253                 (string-match match group))
1254                ((eq match 'header)
1255                 (let ((header (message-fetch-field (pop style))))
1256                   (and header
1257                        (string-match (pop style) header))))
1258                ((or (symbolp match)
1259                     (gnus-functionp match))
1260                 (cond
1261                  ((gnus-functionp match)
1262                   ;; Function to be called.
1263                   (funcall match))
1264                  ((boundp match)
1265                   ;; Variable to be checked.
1266                   (symbol-value match))))
1267                ((listp match)
1268                 ;; This is a form to be evaled.
1269                 (eval match)))
1270           ;; We have a match, so we set the variables.
1271           (dolist (attribute style)
1272             (setq element (pop attribute)
1273                   variable nil
1274                   filep nil)
1275             (setq value
1276                   (cond
1277                    ((eq (car attribute) :file)
1278                     (setq filep t)
1279                     (cadr attribute))
1280                    ((eq (car attribute) :value)
1281                     (cadr attribute))
1282                    (t
1283                     (car attribute))))
1284             ;; We get the value.
1285             (setq v
1286                   (cond
1287                    ((stringp value)
1288                     value)
1289                    ((or (symbolp value)
1290                         (gnus-functionp value))
1291                     (cond ((gnus-functionp value)
1292                            (funcall value))
1293                           ((boundp value)
1294                            (symbol-value value))))
1295                    ((listp value)
1296                     (eval value))))
1297             ;; Translate obsolescent value.
1298             (when (eq element 'signature-file)
1299               (setq element 'signature
1300                     filep t))
1301             ;; Get the contents of file elems.
1302             (when (and filep v)
1303               (setq v (with-temp-buffer
1304                         (insert-file-contents v)
1305                         (buffer-string))))
1306             (setq results (delq (assoc element results) results))
1307             (push (cons element v) results))))
1308       ;; Now we have all the styles, so we insert them.
1309       (setq name (assq 'name results)
1310             address (assq 'address results))
1311       (setq results (delq name (delq address results)))
1312       (make-local-variable 'message-setup-hook)
1313       (dolist (result results)
1314         (add-hook 'message-setup-hook
1315                   (cond
1316                    ((eq 'eval (car result))
1317                     'ignore)
1318                    ((eq 'body (car result))
1319                     `(lambda ()
1320                        (save-excursion
1321                          (message-goto-body)
1322                          (insert ,(cdr result)))))
1323                    ((eq 'signature (car result))
1324                     (set (make-local-variable 'message-signature) nil)
1325                     (set (make-local-variable 'message-signature-file) nil)
1326                     (if (not (cdr result))
1327                         'ignore
1328                       `(lambda ()
1329                          (save-excursion
1330                            (let ((message-signature ,(cdr result)))
1331                              (when message-signature
1332                                (message-insert-signature)))))))
1333                    (t
1334                     (let ((header
1335                            (if (symbolp (car result))
1336                                (capitalize (symbol-name (car result)))
1337                              (car result))))
1338                       `(lambda ()
1339                          (save-excursion
1340                            (message-remove-header ,header)
1341                            (let ((value ,(cdr result)))
1342                              (when value
1343                                (message-goto-eoh)
1344                                (insert ,header ": " value "\n"))))))))))
1345       (when (or name address)
1346         (add-hook 'message-setup-hook
1347                   `(lambda ()
1348                      (set (make-local-variable 'user-mail-address)
1349                           ,(or (cdr address) user-mail-address))
1350                      (let ((user-full-name ,(or (cdr name) (user-full-name)))
1351                            (user-mail-address
1352                             ,(or (cdr address) user-mail-address)))
1353                        (save-excursion
1354                          (message-remove-header "From")
1355                          (message-goto-eoh)
1356                          (insert "From: " (message-make-from) "\n")))))))))
1357
1358 ;;; Allow redefinition of functions.
1359
1360 (gnus-ems-redefine)
1361
1362 (provide 'gnus-msg)
1363
1364 ;;; gnus-msg.el ends here