git.chise.org Git - elisp/gnus.git-/blob - lisp/gnus-msg.el

   1 ;;; gnus-msg.el --- mail and post interface for Semi-gnus
   2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   6 ;;      Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   8 ;;      Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
   9 ;;      Katsumi Yamaoka  <yamaoka@jpl.org>
  10 ;;      Kiyokazu SUTO    <suto@merry.xmath.ous.ac.jp>
  11 ;; Keywords: mail, news, MIME
  12
  13 ;; This file is part of GNU Emacs.
  14
  15 ;; GNU Emacs is free software; you can redistribute it and/or modify
  16 ;; it under the terms of the GNU General Public License as published by
  17 ;; the Free Software Foundation; either version 2, or (at your option)
  18 ;; any later version.
  19
  20 ;; GNU Emacs is distributed in the hope that it will be useful,
  21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;; GNU General Public License for more details.
  24
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  27 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  28 ;; Boston, MA 02111-1307, USA.
  29
  30 ;;; Commentary:
  31
  32 ;;; Code:
  33
  34 (eval-when-compile (require 'cl))
  35 (eval-when-compile (require 'static))
  36
  37 (require 'gnus)
  38 (require 'gnus-ems)
  39 (require 'message)
  40 (require 'gnus-art)
  41
  42 (defcustom gnus-post-method 'current
  43   "*Preferred method for posting USENET news.
  44
  45 If this variable is `current' (which is the default), Gnus will use
  46 the \"current\" select method when posting.  If it is `native', Gnus
  47 will use the native select method when posting.
  48
  49 This method will not be used in mail groups and the like, only in
  50 \"real\" newsgroups.
  51
  52 If not `native' nor `current', the value must be a valid method as discussed
  53 in the documentation of `gnus-select-method'.  It can also be a list of
  54 methods.  If that is the case, the user will be queried for what select
  55 method to use when posting."
  56   :group 'gnus-group-foreign
  57   :link '(custom-manual "(gnus)Posting Server")
  58   :type `(choice (const native)
  59                  (const current)
  60                  (sexp :tag "Methods" ,gnus-select-method)))
  61
  62 (defcustom gnus-outgoing-message-group nil
  63   "*All outgoing messages will be put in this group.
  64 If you want to store all your outgoing mail and articles in the group
  65 \"nnml:archive\", you set this variable to that value.  This variable
  66 can also be a list of group names.
  67
  68 If you want to have greater control over what group to put each
  69 message in, you can set this variable to a function that checks the
  70 current newsgroup name and then returns a suitable group name (or list
  71 of names)."
  72   :group 'gnus-message
  73   :type '(choice (string :tag "Group")
  74                  (function)))
  75
  76 (defcustom gnus-mailing-list-groups nil
  77   "*Regexp matching groups that are really mailing lists.
  78 This is useful when you're reading a mailing list that has been
  79 gatewayed to a newsgroup, and you want to followup to an article in
  80 the group."
  81   :group 'gnus-message
  82   :type 'regexp)
  83
  84 (defcustom gnus-add-to-list nil
  85   "*If non-nil, add a `to-list' parameter automatically."
  86   :group 'gnus-message
  87   :type 'boolean)
  88
  89 (defcustom gnus-crosspost-complaint
  90   "Hi,
  91
  92 You posted the article below with the following Newsgroups header:
  93
  94 Newsgroups: %s
  95
  96 The %s group, at least, was an inappropriate recipient
  97 of this message.  Please trim your Newsgroups header to exclude this
  98 group before posting in the future.
  99
 100 Thank you.
 101
 102 "
 103   "Format string to be inserted when complaining about crossposts.
 104 The first %s will be replaced by the Newsgroups header;
 105 the second with the current group name."
 106   :group 'gnus-message
 107   :type 'string)
 108
 109 (defcustom gnus-message-setup-hook '(gnus-maybe-setup-default-charset)
 110   "Hook run after setting up a message buffer."
 111   :group 'gnus-message
 112   :type 'hook)
 113
 114 (defcustom gnus-bug-create-help-buffer t
 115   "*Should we create the *Gnus Help Bug* buffer?"
 116   :group 'gnus-message
 117   :type 'boolean)
 118
 119 (defcustom gnus-posting-styles nil
 120   "*Alist of styles to use when posting.
 121 See Info node `(gnus)Posting Styles'."
 122   :group 'gnus-message
 123   :type '(repeat (cons (choice (regexp)
 124                                (variable)
 125                                (list (const header)
 126                                      (string :tag "Header")
 127                                      (regexp :tag "Regexp"))
 128                                (function)
 129                                (sexp))
 130                        (repeat (list
 131                                 (choice (const signature)
 132                                         (const signature-file)
 133                                         (const organization)
 134                                         (const address)
 135                                         (const name)
 136                                         (const body)
 137                                         (symbol)
 138                                         (string :tag "Header"))
 139                                 (choice (string)
 140                                         (function)
 141                                         (variable)
 142                                         (sexp)))))))
 143
 144 (defcustom gnus-gcc-mark-as-read nil
 145   "If non-nil, automatically mark Gcc articles as read."
 146   :version "21.1"
 147   :group 'gnus-message
 148   :type 'boolean)
 149
 150 (defvar gnus-inews-mark-gcc-as-read nil
 151   "Obsolete variable. Use `gnus-gcc-mark-as-read' instead.")
 152
 153 (make-obsolete-variable 'gnus-inews-mark-gcc-as-read
 154                         'gnus-gcc-mark-as-read)
 155
 156 (defcustom gnus-gcc-externalize-attachments nil
 157   "Should local-file attachments be included as external parts in Gcc copies?
 158 If it is `all', attach files as external parts;
 159 if a regexp and matches the Gcc group name, attach files as external parts;
 160 If nil, attach files as normal parts."
 161   :version "21.1"
 162   :group 'gnus-message
 163   :type '(choice (const nil :tag "None")
 164                  (const all :tag "Any")
 165                  (string :tag "Regexp")))
 166
 167 (defcustom gnus-group-posting-charset-alist
 168   '(("^\\(no\\|fr\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1))
 169     ("^\\(fido7\\|relcom\\)\\.[^,]*\\(,[ \t\n]*\\(fido7\\|relcom\\)\\.[^,]*\\)*$" koi8-r (koi8-r))
 170     (message-this-is-mail nil nil)
 171     (message-this-is-news nil t))
 172   "Alist of regexps and permitted unencoded charsets for posting.
 173 Each element of the alist has the form (TEST HEADER BODY-LIST), where
 174 TEST is either a regular expression matching the newsgroup header or a
 175 variable to query,
 176 HEADER is the charset which may be left unencoded in the header (nil
 177 means encode all charsets),
 178 BODY-LIST is a list of charsets which may be encoded using 8bit
 179 content-transfer encoding in the body, or one of the special values
 180 nil (always encode using quoted-printable) or t (always use 8bit).
 181
 182 Note that any value other than nil for HEADER infringes some RFCs, so
 183 use this option with care."
 184   :type '(repeat (list :tag "Permitted unencoded charsets"
 185                        (choice :tag "Where"
 186                                (regexp :tag "Group")
 187                                (const :tag "Mail message"
 188                                       :value message-this-is-mail)
 189                                (const :tag "News article"
 190                                       :value message-this-is-news))
 191                        (choice :tag "Header"
 192                                (const :tag "None" nil)
 193                                (symbol :tag "Charset"))
 194                        (choice :tag "Body"
 195                                (const :tag "Any" :value t)
 196                                (const :tag "None" :value nil)
 197                                (repeat :tag "Charsets"
 198                                        (symbol :tag "Charset")))))
 199   :group 'gnus-charset)
 200
 201 (defcustom gnus-debug-files
 202   '("gnus.el" "gnus-sum.el" "gnus-group.el"
 203     "gnus-art.el" "gnus-start.el" "gnus-async.el"
 204     "gnus-msg.el" "gnus-score.el" "gnus-win.el" "gnus-topic.el"
 205     "gnus-agent.el" "gnus-cache.el" "gnus-srvr.el"
 206     "mm-util.el" "mm-decode.el" "nnmail.el" "nntp.el" "message.el")
 207   "Files whose variables will be reported in `gnus-bug'."
 208   :version "21.1"
 209   :group 'gnus-message
 210   :type '(repeat (string :tag "File")))
 211
 212 (defcustom gnus-debug-exclude-variables
 213   '(mm-mime-mule-charset-alist
 214     nnmail-split-fancy message-minibuffer-local-map)
 215   "Variables that should not be reported in `gnus-bug'."
 216   :version "21.1"
 217   :group 'gnus-message
 218   :type '(repeat (symbol :tab "Variable")))
 219
 220 ;;; Internal variables.
 221
 222 (defvar gnus-inhibit-posting-styles nil
 223   "Inhibit the use of posting styles.")
 224
 225 (defvar gnus-message-buffer "*Mail Gnus*")
 226 (defvar gnus-article-copy nil)
 227 (defvar gnus-check-before-posting nil)
 228 (defvar gnus-last-posting-server nil)
 229 (defvar gnus-message-group-art nil)
 230
 231 (defvar gnus-msg-force-broken-reply-to nil)
 232
 233 (defconst gnus-bug-message
 234   (format "Sending a bug report to the Gnus Towers.
 235 ========================================
 236
 237 This gnus is the %s%s.
 238 If you think the bug is a Semi-gnus bug, send a bug report to Semi-gnus
 239 Developers. (the addresses below are mailing list addresses)
 240
 241 ========================================
 242
 243 The buffer below is a mail buffer.  When you press `C-c C-c', it will
 244 be sent to the Gnus Bug Exterminators.
 245
 246 The thing near the bottom of the buffer is how the environment
 247 settings will be included in the mail.  Please do not delete that.
 248 They will tell the Bug People what your environment is, so that it
 249 will be easier to locate the bugs.
 250
 251 If you have found a bug that makes Emacs go \"beep\", set
 252 debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET')
 253 and include the backtrace in your bug report.
 254
 255 Please describe the bug in annoying, painstaking detail.
 256
 257 Thank you for your help in stamping out bugs.
 258 "
 259           gnus-product-name
 260           (if (string= gnus-product-name "Semi-gnus")
 261               ""
 262             ", a modified version of Semi-gnus")))
 263
 264 (eval-and-compile
 265   (autoload 'gnus-uu-post-news "gnus-uu" nil t)
 266   (autoload 'news-setup "rnewspost")
 267   (autoload 'news-reply-mode "rnewspost")
 268   (autoload 'rmail-dont-reply-to "mail-utils")
 269   (autoload 'rmail-output "rmailout"))
 270
 271 \f
 272 ;;;
 273 ;;; Gnus Posting Functions
 274 ;;;
 275
 276 (gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map)
 277   "p" gnus-summary-post-news
 278   "i" gnus-summary-news-other-window
 279   "f" gnus-summary-followup
 280   "F" gnus-summary-followup-with-original
 281   "c" gnus-summary-cancel-article
 282   "s" gnus-summary-supersede-article
 283   "r" gnus-summary-reply
 284   "y" gnus-summary-yank-message
 285   "R" gnus-summary-reply-with-original
 286   "w" gnus-summary-wide-reply
 287   "W" gnus-summary-wide-reply-with-original
 288   "v" gnus-summary-very-wide-reply
 289   "V" gnus-summary-very-wide-reply-with-original
 290   "n" gnus-summary-followup-to-mail
 291   "N" gnus-summary-followup-to-mail-with-original
 292   "m" gnus-summary-mail-other-window
 293   "u" gnus-uu-post-news
 294   "\M-c" gnus-summary-mail-crosspost-complaint
 295   "Br" gnus-summary-reply-broken-reply-to
 296   "BR" gnus-summary-reply-broken-reply-to-with-original
 297   "om" gnus-summary-mail-forward
 298   "op" gnus-summary-post-forward
 299   "Om" gnus-summary-digest-mail-forward
 300   "Op" gnus-summary-digest-post-forward)
 301
 302 (gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map)
 303   "b" gnus-summary-resend-bounced-mail
 304   ;; "c" gnus-summary-send-draft
 305   "r" gnus-summary-resend-message)
 306
 307 ;;; Internal functions.
 308
 309 (defvar gnus-article-reply nil)
 310 (defmacro gnus-setup-message (config &rest forms)
 311   (let ((winconf (make-symbol "gnus-setup-message-winconf"))
 312         (buffer (make-symbol "gnus-setup-message-buffer"))
 313         (article (make-symbol "gnus-setup-message-article"))
 314         (group (make-symbol "gnus-setup-message-group")))
 315     `(let ((,winconf (current-window-configuration))
 316            (,buffer (buffer-name (current-buffer)))
 317            (,article gnus-article-reply)
 318            (,group gnus-newsgroup-name)
 319            (message-header-setup-hook
 320             (copy-sequence message-header-setup-hook))
 321            (message-mode-hook (copy-sequence message-mode-hook))
 322            (message-startup-parameter-alist
 323             '((reply-buffer . gnus-copy-article-buffer)
 324               (original-buffer . gnus-original-article-buffer)
 325               (user-agent . Gnus))))
 326        (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
 327        (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
 328        ;; #### FIXME: for a reason that I did not manage to identify yet,
 329        ;; the variable `gnus-newsgroup-name' does not honor a dynamically
 330        ;; scoped or setq'ed value from a caller like `C-u gnus-summary-mail'.
 331        ;; After evaluation of @forms below, it gets the value we actually want
 332        ;; to override, and the posting styles are used. For that reason, I've
 333        ;; added an optional argument to `gnus-configure-posting-styles' to
 334        ;; make sure that the correct value for the group name is used. -- drv
 335        (add-hook 'message-mode-hook
 336                  (lambda ()
 337                    (gnus-configure-posting-styles ,group)))
 338        (unwind-protect
 339            (progn
 340              ,@forms)
 341          (gnus-inews-add-send-actions ,winconf ,buffer ,article ,config)
 342          (gnus-inews-insert-draft-meta-information ,group ,article)
 343          (setq gnus-message-buffer (current-buffer))
 344          (set (make-local-variable 'gnus-message-group-art)
 345               (cons ,group ,article))
 346          (set (make-local-variable 'gnus-newsgroup-name) ,group)
 347          (gnus-run-hooks 'gnus-message-setup-hook))
 348        (gnus-add-buffer)
 349        (gnus-configure-windows ,config t)
 350        (run-hooks 'post-command-hook)
 351        (set-buffer-modified-p nil))))
 352
 353 (defun gnus-inews-insert-draft-meta-information (group article)
 354   (save-excursion
 355     (when (and group
 356                (not (string= group ""))
 357                (not (message-fetch-field gnus-draft-meta-information-header)))
 358       (goto-char (point-min))
 359       (insert gnus-draft-meta-information-header ": (\"" group "\" "
 360               (if article (number-to-string
 361                            (if (listp article)
 362                                (car article)
 363                              article)) "\"\"")
 364               ")\n"))))
 365
 366 ;;;###autoload
 367 (defun gnus-msg-mail (&optional to subject other-headers continue
 368                                 switch-action yank-action send-actions)
 369   "Start editing a mail message to be sent.
 370 Like `message-mail', but with Gnus paraphernalia, particularly the
 371 Gcc: header for archiving purposes."
 372   (interactive)
 373   (let ((buf (current-buffer))
 374         mail-buf)
 375     (gnus-setup-message 'message
 376       (message-mail to subject other-headers continue
 377                     nil yank-action send-actions))
 378     (when switch-action
 379       (setq mail-buf (current-buffer))
 380       (switch-to-buffer buf)
 381       (apply switch-action mail-buf nil)))
 382   ;; COMPOSEFUNC should return t if succeed.  Undocumented ???
 383   t)
 384
 385 (defvar save-selected-window-window)
 386
 387 ;;;###autoload
 388 (defun gnus-button-mailto (address)
 389   "Mail to ADDRESS."
 390   (set-buffer (gnus-copy-article-buffer))
 391   (gnus-setup-message 'message
 392     (message-reply address))
 393   (and (boundp 'save-selected-window-window)
 394        (not (window-live-p save-selected-window-window))
 395        (setq save-selected-window-window (selected-window))))
 396
 397 ;;;###autoload
 398 (defun gnus-button-reply (&optional to-address wide)
 399   "Like `message-reply'."
 400   (interactive)
 401   (gnus-setup-message 'message
 402     (message-reply to-address wide))
 403   (and (boundp 'save-selected-window-window)
 404        (not (window-live-p save-selected-window-window))
 405        (setq save-selected-window-window (selected-window))))
 406
 407 ;;;###autoload
 408 (define-mail-user-agent 'gnus-user-agent
 409   'gnus-msg-mail 'message-send-and-exit
 410   'message-kill-buffer 'message-send-hook)
 411
 412 (defun gnus-setup-posting-charset (group)
 413   (let ((alist gnus-group-posting-charset-alist)
 414         (group (or group ""))
 415         elem)
 416     (when group
 417       (catch 'found
 418         (while (setq elem (pop alist))
 419           (when (or (and (stringp (car elem))
 420                          (string-match (car elem) group))
 421                     (and (gnus-functionp (car elem))
 422                          (funcall (car elem) group))
 423                     (and (symbolp (car elem))
 424                          (symbol-value (car elem))))
 425             (throw 'found (cons (cadr elem) (caddr elem)))))))))
 426
 427 (defun gnus-inews-add-send-actions (winconf buffer article &optional config)
 428   (make-local-hook 'message-sent-hook)
 429   (add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc
 430                                  'gnus-inews-do-gcc) nil t)
 431   (when gnus-agent
 432     (make-local-hook 'message-header-hook)
 433     (add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t))
 434   (setq message-post-method
 435         `(lambda (arg)
 436            (gnus-post-method arg ,gnus-newsgroup-name)))
 437   (setq message-user-agent (gnus-extended-version))
 438   (when (not message-use-multi-frames)
 439     (message-add-action
 440      `(set-window-configuration ,winconf) 'exit 'postpone 'kill))
 441   (message-add-action
 442    `(when (gnus-buffer-exists-p ,buffer)
 443       (save-excursion
 444         (set-buffer ,buffer)
 445         ,(when article
 446            (if (eq config 'forward)
 447                `(gnus-summary-mark-article-as-forwarded ',article)
 448              `(gnus-summary-mark-article-as-replied ',article)))))
 449    'send))
 450
 451 (put 'gnus-setup-message 'lisp-indent-function 1)
 452 (put 'gnus-setup-message 'edebug-form-spec '(form body))
 453
 454 ;;; Post news commands of Gnus group mode and summary mode
 455
 456 (defun gnus-group-mail (&optional arg)
 457   "Start composing a mail.
 458 If ARG, use the group under the point to find a posting style.
 459 If ARG is 1, prompt for a group name to find the posting style."
 460   (interactive "P")
 461   ;; We can't `let' gnus-newsgroup-name here, since that leads
 462   ;; to local variables leaking.
 463   (let ((group gnus-newsgroup-name)
 464         (buffer (current-buffer)))
 465     (unwind-protect
 466         (progn
 467           (setq gnus-newsgroup-name
 468                 (if arg
 469                     (if (= 1 (prefix-numeric-value arg))
 470                         (completing-read "Use posting style of group: "
 471                                          gnus-active-hashtb nil
 472                                          (gnus-read-active-file-p))
 473                       (gnus-group-group-name))
 474                   ""))
 475           ;; #### see comment in gnus-setup-message -- drv
 476           (gnus-setup-message 'message (message-mail)))
 477       (save-excursion
 478         (set-buffer buffer)
 479         (setq gnus-newsgroup-name group)))))
 480
 481 (defun gnus-group-news (&optional arg)
 482   "Start composing a news.
 483 If ARG, post to group under point.
 484 If ARG is 1, prompt for group name to post to.
 485
 486 This function prepares a news even when using mail groups.  This is useful
 487 for posting messages to mail groups without actually sending them over the
 488 network.  The corresponding backend must have a 'request-post method."
 489   (interactive "P")
 490   ;; We can't `let' gnus-newsgroup-name here, since that leads
 491   ;; to local variables leaking.
 492   (let ((group gnus-newsgroup-name)
 493         (buffer (current-buffer)))
 494     (unwind-protect
 495         (progn
 496           (setq gnus-newsgroup-name
 497                 (if arg
 498                     (if (= 1 (prefix-numeric-value arg))
 499                         (completing-read "Use group: "
 500                                          gnus-active-hashtb nil
 501                                          (gnus-read-active-file-p))
 502                       (gnus-group-group-name))
 503                   ""))
 504           ;; #### see comment in gnus-setup-message -- drv
 505           (gnus-setup-message 'message
 506             (message-news (gnus-group-real-name gnus-newsgroup-name))))
 507       (save-excursion
 508         (set-buffer buffer)
 509         (setq gnus-newsgroup-name group)))))
 510
 511 (defun gnus-group-post-news (&optional arg)
 512   "Start composing a message (a news by default).
 513 If ARG, post to group under point.  If ARG is 1, prompt for group name.
 514 Depending on the selected group, the message might be either a mail or
 515 a news."
 516   (interactive "P")
 517   ;; Bind this variable here to make message mode hooks work ok.
 518   (let ((gnus-newsgroup-name
 519          (if arg
 520              (if (= 1 (prefix-numeric-value arg))
 521                  (completing-read "Newsgroup: " gnus-active-hashtb nil
 522                                   (gnus-read-active-file-p))
 523                (gnus-group-group-name))
 524            "")))
 525     (gnus-post-news 'post gnus-newsgroup-name)))
 526
 527 (defun gnus-summary-mail-other-window (&optional arg)
 528   "Start composing a mail in another window.
 529 Use the posting of the current group by default.
 530 If ARG, don't do that.  If ARG is 1, prompt for group name to find the
 531 posting style."
 532   (interactive "P")
 533   ;; We can't `let' gnus-newsgroup-name here, since that leads
 534   ;; to local variables leaking.
 535   (let ((group gnus-newsgroup-name)
 536         (buffer (current-buffer)))
 537     (unwind-protect
 538         (progn
 539           (setq gnus-newsgroup-name
 540                 (if arg
 541                     (if (= 1 (prefix-numeric-value arg))
 542                         (completing-read "Use group: "
 543                                          gnus-active-hashtb nil
 544                                          (gnus-read-active-file-p))
 545                       "")
 546                   gnus-newsgroup-name))
 547           ;; #### see comment in gnus-setup-message -- drv
 548           (gnus-setup-message 'message (message-mail)))
 549       (save-excursion
 550         (set-buffer buffer)
 551         (setq gnus-newsgroup-name group)))))
 552
 553 (defun gnus-summary-news-other-window (&optional arg)
 554   "Start composing a news in another window.
 555 Post to the current group by default.
 556 If ARG, don't do that.  If ARG is 1, prompt for group name to post to.
 557
 558 This function prepares a news even when using mail groups.  This is useful
 559 for posting messages to mail groups without actually sending them over the
 560 network.  The corresponding backend must have a 'request-post method."
 561   (interactive "P")
 562   ;; We can't `let' gnus-newsgroup-name here, since that leads
 563   ;; to local variables leaking.
 564   (let ((group gnus-newsgroup-name)
 565         (buffer (current-buffer)))
 566     (unwind-protect
 567         (progn
 568           (setq gnus-newsgroup-name
 569                 (if arg
 570                     (if (= 1 (prefix-numeric-value arg))
 571                         (completing-read "Use group: "
 572                                          gnus-active-hashtb nil
 573                                          (gnus-read-active-file-p))
 574                       "")
 575                   gnus-newsgroup-name))
 576           ;; #### see comment in gnus-setup-message -- drv
 577           (gnus-setup-message 'message
 578             (message-news (gnus-group-real-name gnus-newsgroup-name))))
 579       (save-excursion
 580         (set-buffer buffer)
 581         (setq gnus-newsgroup-name group)))))
 582
 583 (defun gnus-summary-post-news (&optional arg)
 584   "Start composing a message.  Post to the current group by default.
 585 If ARG, don't do that.  If ARG is 1, prompt for a group name to post to.
 586 Depending on the selected group, the message might be either a mail or
 587 a news."
 588   (interactive "P")
 589   ;; Bind this variable here to make message mode hooks work ok.
 590   (let ((gnus-newsgroup-name
 591          (if arg
 592              (if (= 1 (prefix-numeric-value arg))
 593                  (completing-read "Newsgroup: " gnus-active-hashtb nil
 594                                   (gnus-read-active-file-p))
 595                "")
 596            gnus-newsgroup-name)))
 597     (gnus-post-news 'post gnus-newsgroup-name)))
 598
 599
 600 (defun gnus-summary-followup (yank &optional force-news)
 601   "Compose a followup to an article.
 602 If prefix argument YANK is non-nil, the original article is yanked
 603 automatically.
 604 YANK is a list of elements, where the car of each element is the
 605 article number, and the two following numbers is the region to be
 606 yanked."
 607   (interactive
 608    (list (and current-prefix-arg
 609               (gnus-summary-work-articles 1))))
 610   (when yank
 611     (gnus-summary-goto-subject
 612      (if (listp (car yank))
 613          (caar yank)
 614        (car yank))))
 615   (save-window-excursion
 616     (gnus-summary-select-article))
 617   (let ((headers (gnus-summary-article-header (gnus-summary-article-number)))
 618         (gnus-newsgroup-name gnus-newsgroup-name))
 619     ;; Send a followup.
 620     (gnus-post-news nil gnus-newsgroup-name
 621                     headers gnus-article-buffer
 622                     yank nil force-news)))
 623
 624 (defun gnus-summary-followup-with-original (n &optional force-news)
 625   "Compose a followup to an article and include the original article."
 626   (interactive "P")
 627   (gnus-summary-followup (gnus-summary-work-articles n) force-news))
 628
 629 (defun gnus-summary-followup-to-mail (&optional arg)
 630   "Followup to the current mail message via news."
 631   (interactive
 632    (list (and current-prefix-arg
 633               (gnus-summary-work-articles 1))))
 634   (gnus-summary-followup arg t))
 635
 636 (defun gnus-summary-followup-to-mail-with-original (&optional arg)
 637   "Followup to the current mail message via news."
 638   (interactive "P")
 639   (gnus-summary-followup (gnus-summary-work-articles arg) t))
 640
 641 (defun gnus-inews-yank-articles (articles)
 642   (let (beg article yank-string
 643             (more-than-one (cdr articles))
 644             (cur (current-buffer))
 645             refs window)
 646     (message-goto-body)
 647     (while (setq article (pop articles))
 648       (when (listp article)
 649         (setq yank-string (nth 1 article)
 650               article (nth 0 article)))
 651       (save-window-excursion
 652         (set-buffer gnus-summary-buffer)
 653         (gnus-summary-select-article nil nil nil article)
 654         (gnus-summary-remove-process-mark article))
 655
 656       ;; Gathering references.
 657       (when more-than-one
 658         (setq refs (message-list-references
 659                     refs
 660                     (mail-header-references gnus-current-headers)
 661                     (mail-header-message-id gnus-current-headers)))
 662         (when message-use-multi-frames
 663           (when (setq window (get-buffer-window cur t))
 664             (select-frame (window-frame window)))))
 665
 666       (gnus-copy-article-buffer nil yank-string)
 667       (let ((message-reply-buffer gnus-article-copy)
 668             (message-reply-headers
 669              ;; The headers are decoded.
 670              (with-current-buffer gnus-article-copy
 671                (nnheader-parse-head t))))
 672         (message-yank-original)
 673         (setq beg (or beg (mark t))))
 674       (when articles
 675         (insert "\n")))
 676     (push-mark)
 677
 678     ;; Replace with the gathered references.
 679     (when refs
 680       (push-mark beg)
 681       (save-restriction
 682         (message-narrow-to-headers)
 683         (let ((case-fold-search t))
 684           (if (re-search-forward "^References:\\([\t ]+.+\n\\)+" nil t)
 685               (replace-match "")
 686             (goto-char (point-max))))
 687         (mail-header-format
 688          (list (or (assq 'References message-header-format-alist)
 689                    '(References . message-shorten-references)))
 690          (list (cons 'References
 691                      (mapconcat 'identity (nreverse refs) " "))))
 692         (backward-delete-char 1))
 693       (setq beg (mark t))
 694       (pop-mark))
 695
 696     (goto-char beg)))
 697
 698 (defun gnus-summary-cancel-article (&optional n symp)
 699   "Cancel an article you posted.
 700 Uses the process-prefix convention.  If given the symbolic
 701 prefix `a', cancel using the standard posting method; if not
 702 post using the current select method."
 703   (interactive (gnus-interactive "P\ny"))
 704   (let ((articles (gnus-summary-work-articles n))
 705         (message-post-method
 706          `(lambda (arg)
 707             (gnus-post-method (not (eq symp 'a)) ,gnus-newsgroup-name)))
 708         article)
 709     (while (setq article (pop articles))
 710       (when (gnus-summary-select-article t nil nil article)
 711         (when (gnus-eval-in-buffer-window gnus-article-buffer
 712                 (save-excursion
 713                   (set-buffer gnus-original-article-buffer)
 714                   (message-cancel-news)))
 715           (gnus-summary-mark-as-read article gnus-canceled-mark)
 716           (gnus-cache-remove-article 1))
 717         (gnus-article-hide-headers-if-wanted))
 718       (gnus-summary-remove-process-mark article))))
 719
 720 (defun gnus-summary-supersede-article ()
 721   "Compose an article that will supersede a previous article.
 722 This is done simply by taking the old article and adding a Supersedes
 723 header line with the old Message-ID."
 724   (interactive)
 725   (let ((article (gnus-summary-article-number))
 726         (gnus-message-setup-hook '(gnus-maybe-setup-default-charset)))
 727     (gnus-setup-message 'reply-yank
 728       (gnus-summary-select-article t)
 729       (set-buffer gnus-original-article-buffer)
 730       (message-supersede)
 731       (push
 732        `((lambda ()
 733            (when (gnus-buffer-exists-p ,gnus-summary-buffer)
 734              (save-excursion
 735                (set-buffer ,gnus-summary-buffer)
 736                (gnus-cache-possibly-remove-article ,article nil nil nil t)
 737                (gnus-summary-mark-as-read ,article gnus-canceled-mark)))))
 738        message-send-actions))))
 739
 740 \f
 741
 742 (defun gnus-copy-article-buffer (&optional article-buffer yank-string)
 743   ;; make a copy of the article buffer with all text properties removed
 744   ;; this copy is in the buffer gnus-article-copy.
 745   ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
 746   ;; this buffer should be passed to all mail/news reply/post routines.
 747   (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*"))
 748   (let ((article-buffer (or article-buffer gnus-article-buffer))
 749         end beg)
 750     (if (not (and (get-buffer article-buffer)
 751                   (gnus-buffer-exists-p article-buffer)))
 752         (error "Can't find any article buffer")
 753       (save-excursion
 754         (set-buffer article-buffer)
 755         (let ((gnus-newsgroup-charset (or gnus-article-charset
 756                                           gnus-newsgroup-charset))
 757               (gnus-newsgroup-ignored-charsets
 758                (or gnus-article-ignored-charsets
 759                    gnus-newsgroup-ignored-charsets)))
 760           (save-restriction
 761             ;; Copy over the (displayed) article buffer, delete
 762             ;; hidden text and remove text properties.
 763             (widen)
 764             (let ((inhibit-read-only t))
 765               (copy-to-buffer gnus-article-copy (point-min) (point-max))
 766               (set-buffer gnus-article-copy)
 767               (when yank-string
 768                 (message-goto-body)
 769                 (delete-region (point) (point-max))
 770                 (insert yank-string))
 771               ;; Encode bitmap smileys to ordinary text.
 772               ;; Possibly, the original text might be restored.
 773               (static-unless (featurep 'xemacs)
 774                 (when (featurep 'smiley-mule)
 775                   (smiley-encode-buffer)))
 776               (gnus-article-delete-text-of-type 'annotation)
 777               (gnus-remove-text-with-property 'gnus-prev)
 778               (gnus-remove-text-with-property 'gnus-next)
 779               (gnus-remove-text-with-property 'x-face-mule-bitmap-image)
 780               (insert
 781                (prog1
 782                    (static-if (featurep 'xemacs)
 783                        ;; Revome smiley extents for (possibly) XEmacs 21.1.
 784                        (format "%s"
 785                                (buffer-substring-no-properties (point-min)
 786                                                                (point-max)))
 787                      (buffer-substring-no-properties (point-min) (point-max)))
 788                  (erase-buffer))))
 789             ;; Find the original headers.
 790             (set-buffer gnus-original-article-buffer)
 791             (goto-char (point-min))
 792             (while (looking-at message-unix-mail-delimiter)
 793               (forward-line 1))
 794             (setq beg (point)
 795                   end (or (message-goto-body) beg))
 796             ;; Delete the headers from the displayed articles.
 797             (set-buffer gnus-article-copy)
 798             (delete-region (goto-char (point-min))
 799                            (or (message-goto-body) (point-max)))
 800             ;; Insert the original article headers.
 801             (insert-buffer-substring gnus-original-article-buffer beg end)
 802             ;; Decode charsets.
 803             (let ((gnus-article-decode-hook
 804                    (delq 'article-decode-charset
 805                          (copy-sequence gnus-article-decode-hook))))
 806               ;; Needed for T-gnus.
 807               (add-hook 'gnus-article-decode-hook
 808                         'article-decode-encoded-words)
 809               (run-hooks 'gnus-article-decode-hook)))))
 810       gnus-article-copy)))
 811
 812 (defun gnus-post-news (post &optional group header article-buffer yank subject
 813                             force-news)
 814   (when article-buffer
 815     (gnus-copy-article-buffer))
 816   (let ((gnus-article-reply (and article-buffer (gnus-summary-article-number)))
 817         (add-to-list gnus-add-to-list))
 818     (gnus-setup-message (cond (yank 'reply-yank)
 819                               (article-buffer 'reply)
 820                               (t 'message))
 821       (let* ((group (or group gnus-newsgroup-name))
 822              (charset (gnus-group-name-charset nil group))
 823              (pgroup group)
 824              to-address to-group mailing-list to-list
 825              newsgroup-p)
 826         (when group
 827           (setq to-address (gnus-parameter-to-address group)
 828                 to-group (gnus-group-find-parameter group 'to-group)
 829                 to-list (gnus-parameter-to-list group)
 830                 newsgroup-p (gnus-group-find-parameter group 'newsgroup)
 831                 mailing-list (when gnus-mailing-list-groups
 832                                (string-match gnus-mailing-list-groups group))
 833                 group (gnus-group-name-decode (gnus-group-real-name group)
 834                                               charset)))
 835         (if (or (and to-group
 836                      (gnus-news-group-p to-group))
 837                 newsgroup-p
 838                 force-news
 839                 (and (gnus-news-group-p
 840                       (or pgroup gnus-newsgroup-name)
 841                       (or header gnus-current-article))
 842                      (not mailing-list)
 843                      (not to-list)
 844                      (not to-address)))
 845             ;; This is news.
 846             (if post
 847                 (message-news (or to-group group))
 848               (set-buffer gnus-article-copy)
 849               (gnus-msg-treat-broken-reply-to)
 850               (message-followup (if (or newsgroup-p force-news)
 851                                     (if (save-restriction
 852                                           (article-narrow-to-head)
 853                                           (message-fetch-field "newsgroups"))
 854                                         nil
 855                                       "")
 856                                   to-group)))
 857           ;; The is mail.
 858           (if post
 859               (progn
 860                 (message-mail (or to-address to-list))
 861                 ;; Arrange for mail groups that have no `to-address' to
 862                 ;; get that when the user sends off the mail.
 863                 (when (and (not to-list)
 864                            (not to-address)
 865                            add-to-list)
 866                   (push (list 'gnus-inews-add-to-address pgroup)
 867                         message-send-actions)))
 868             (set-buffer gnus-article-copy)
 869             (gnus-msg-treat-broken-reply-to)
 870             (message-wide-reply to-address)))
 871         (when yank
 872           (gnus-inews-yank-articles yank))))))
 873
 874 (defun gnus-msg-treat-broken-reply-to (&optional force)
 875   "Remove the Reply-to header iff broken-reply-to."
 876   (when (or force
 877             (gnus-group-find-parameter
 878              gnus-newsgroup-name 'broken-reply-to))
 879     (save-restriction
 880       (message-narrow-to-head)
 881       (message-remove-header "reply-to"))))
 882
 883 (defun gnus-post-method (arg group &optional silent)
 884   "Return the posting method based on GROUP and ARG.
 885 If SILENT, don't prompt the user."
 886   (let ((gnus-post-method (or (gnus-parameter-post-method group)
 887                               gnus-post-method))
 888         (group-method (gnus-find-method-for-group group)))
 889     (cond
 890      ;; If the group-method is nil (which shouldn't happen) we use
 891      ;; the default method.
 892      ((null group-method)
 893       (or (and (listp gnus-post-method) ;If not current/native/nil
 894                (not (listp (car gnus-post-method))) ; and not a list of methods
 895                gnus-post-method)        ;then use it.
 896           gnus-select-method
 897           message-post-method))
 898      ;; We want the inverse of the default
 899      ((and arg (not (eq arg 0)))
 900       (if (eq gnus-post-method 'current)
 901           gnus-select-method
 902         group-method))
 903      ;; We query the user for a post method.
 904      ((or arg
 905           (and (listp gnus-post-method)
 906                (listp (car gnus-post-method))))
 907       (let* ((methods
 908               ;; Collect all methods we know about.
 909               (append
 910                (when (listp gnus-post-method)
 911                  (if (listp (car gnus-post-method))
 912                      gnus-post-method
 913                    (list gnus-post-method)))
 914                gnus-secondary-select-methods
 915                (mapcar 'cdr gnus-server-alist)
 916                (mapcar 'car gnus-opened-servers)
 917                (list gnus-select-method)
 918                (list group-method)))
 919              method-alist post-methods method)
 920         ;; Weed out all mail methods.
 921         (while methods
 922           (setq method (gnus-server-get-method "" (pop methods)))
 923           (when (and (or (gnus-method-option-p method 'post)
 924                          (gnus-method-option-p method 'post-mail))
 925                      (not (member method post-methods)))
 926             (push method post-methods)))
 927         ;; Create a name-method alist.
 928         (setq method-alist
 929               (mapcar
 930                (lambda (m)
 931                  (if (equal (cadr m) "")
 932                      (list (symbol-name (car m)) m)
 933                    (list (concat (cadr m) " (" (symbol-name (car m)) ")") m)))
 934                post-methods))
 935         ;; Query the user.
 936         (cadr
 937          (assoc
 938           (setq gnus-last-posting-server
 939                 (if (and silent
 940                          gnus-last-posting-server)
 941                     ;; Just use the last value.
 942                     gnus-last-posting-server
 943                   (completing-read
 944                    "Posting method: " method-alist nil t
 945                    (cons (or gnus-last-posting-server "") 0))))
 946           method-alist))))
 947      ;; Override normal method.
 948      ((and (eq gnus-post-method 'current)
 949            (not (eq (car group-method) 'nndraft))
 950            (gnus-get-function group-method 'request-post t))
 951       (assert (not arg))
 952       group-method)
 953      ;; Use gnus-post-method.
 954      ((listp gnus-post-method)          ;A method...
 955       (assert (not (listp (car gnus-post-method)))) ;... not a list of methods.
 956       gnus-post-method)
 957      ;; Use the normal select method (nil or native).
 958      (t gnus-select-method))))
 959
 960 \f
 961 (defun gnus-message-make-user-agent (&optional include-mime-info max-column
 962                                                  newline-product)
 963   "Return a user-agent info.  If INCLUDE-MIME-INFO is non-nil and the
 964 variable `mime-edit-user-agent-value' is bound, the value will be
 965 included in the return value.  If MAX-COLUMN is specified, the return
 966 value will be folded up as it were filled.  NEWLINE-PRODUCT specifies
 967 whether a newline should be inserted in front of each product-token.
 968 If the value is t or `hard', it works strictly.  Otherwise, if it is
 969 non-nil (e.g. `soft'), it works semi-strictly.
 970
 971 Here is an example of how to use this function:
 972
 973 \(add-hook 'gnus-message-setup-hook
 974           (lambda nil
 975             (setq message-user-agent nil)
 976             (save-excursion
 977               (save-restriction
 978                 (message-narrow-to-headers)
 979                 (goto-char (point-max))
 980                 (insert \"User-Agent: \"
 981                         (gnus-message-make-user-agent t 76 'soft)
 982                         \"\\n\")))))
 983 "
 984   (let ((user-agent (if (and include-mime-info
 985                              (boundp 'mime-edit-user-agent-value))
 986                         (concat (gnus-extended-version)
 987                                 " "
 988                                 mime-edit-user-agent-value)
 989                       (gnus-extended-version))))
 990     (when max-column
 991       (unless (natnump max-column)
 992         (setq max-column 76))
 993       (with-temp-buffer
 994         (set-buffer-multibyte t)
 995         (insert (mapconcat 'identity (split-string user-agent) " "))
 996         (goto-char (point-min))
 997         (let ((bol t)
 998               start agent agents width element swidth)
 999           (while (re-search-forward "\\([^ ]+\\) ?" nil t)
1000             (setq start (match-beginning 0))
1001             (if (eq (char-after start) ?\()
1002                 (progn
1003                   (goto-char start)
1004                   (forward-list)
1005                   (push (buffer-substring start (point)) agent))
1006               (when agent
1007                 (push (nreverse agent) agents))
1008               (setq agent (list (match-string 1)))))
1009           (when agent
1010             (push (nreverse agent) agents))
1011           (setq agents (nreverse agents))
1012           (if (> (+ 12 (string-width (caar agents))) max-column)
1013               (setq user-agent "\n"
1014                     width 0)
1015             (setq user-agent ""
1016                   width 11))
1017           (while agents
1018             (setq agent (car agents)
1019                   agents (cdr agents))
1020             (when (and (not bol)
1021                        (or (memq newline-product '(t hard))
1022                            (and newline-product
1023                                 (> (+ width 1
1024                                       (string-width (mapconcat 'identity
1025                                                                agent " ")))
1026                                    max-column))))
1027               (setq user-agent (concat user-agent "\n")
1028                     width 0
1029                     bol t))
1030             (while agent
1031               (setq element (car agent)
1032                     swidth (string-width element)
1033                     agent (cdr agent))
1034               (if bol
1035                   (setq user-agent (if (member user-agent '("" "\n"))
1036                                        (concat user-agent element)
1037                                      (concat user-agent " " element))
1038                         width (+ width 1 swidth)
1039                         bol nil)
1040                 (if (> (+ width 1 swidth) max-column)
1041                     (setq user-agent (concat user-agent "\n " element)
1042                           width (1+ swidth))
1043                   (setq user-agent (concat user-agent " " element)
1044                         width (+ width 1 swidth)))))))))
1045     user-agent))
1046
1047 \f
1048 ;;;
1049 ;;; Gnus Mail Functions
1050 ;;;
1051
1052 ;;; Mail reply commands of Gnus summary mode
1053
1054 (defun gnus-summary-reply (&optional yank wide very-wide)
1055   "Start composing a mail reply to the current message.
1056 If prefix argument YANK is non-nil, the original article is yanked
1057 automatically.
1058 If WIDE, make a wide reply.
1059 If VERY-WIDE, make a very wide reply."
1060   (interactive
1061    (list (and current-prefix-arg
1062               (gnus-summary-work-articles 1))))
1063   (let* ((article
1064           (if (listp (car yank))
1065               (caar yank)
1066             (car yank)))
1067          (gnus-article-reply (or article (gnus-summary-article-number)))
1068          (headers ""))
1069     ;; Stripping headers should be specified with mail-yank-ignored-headers.
1070     (when yank
1071       (gnus-summary-goto-subject article))
1072     (gnus-setup-message (if yank 'reply-yank 'reply)
1073       (if (not very-wide)
1074           (gnus-summary-select-article)
1075         (dolist (article very-wide)
1076           (gnus-summary-select-article nil nil nil article)
1077           (save-excursion
1078             (set-buffer (gnus-copy-article-buffer))
1079             (gnus-msg-treat-broken-reply-to)
1080             (save-restriction
1081               (message-narrow-to-head)
1082               (setq headers (concat headers (buffer-string)))))))
1083       (set-buffer (gnus-copy-article-buffer))
1084       (gnus-msg-treat-broken-reply-to gnus-msg-force-broken-reply-to)
1085       (save-restriction
1086         (message-narrow-to-head)
1087         (when very-wide
1088           (erase-buffer)
1089           (insert headers))
1090         (goto-char (point-max)))
1091       (message-reply nil wide)
1092       (when yank
1093         (gnus-inews-yank-articles yank)))))
1094
1095 (defun gnus-summary-reply-with-original (n &optional wide)
1096   "Start composing a reply mail to the current message.
1097 The original article will be yanked."
1098   (interactive "P")
1099   (gnus-summary-reply (gnus-summary-work-articles n) wide))
1100
1101 (defun gnus-summary-reply-broken-reply-to (&optional yank wide very-wide)
1102   "Like `gnus-summary-reply' except removing reply-to field.
1103 If prefix argument YANK is non-nil, the original article is yanked
1104 automatically.
1105 If WIDE, make a wide reply.
1106 If VERY-WIDE, make a very wide reply."
1107   (interactive
1108    (list (and current-prefix-arg
1109               (gnus-summary-work-articles 1))))
1110   (let ((gnus-msg-force-broken-reply-to t))
1111     (gnus-summary-reply yank wide very-wide)))
1112
1113 (defun gnus-summary-reply-broken-reply-to-with-original (n &optional wide)
1114   "Like `gnus-summary-reply-with-original' except removing reply-to field.
1115 The original article will be yanked."
1116   (interactive "P")
1117   (gnus-summary-reply-broken-reply-to (gnus-summary-work-articles n) wide))
1118
1119 (defun gnus-summary-wide-reply (&optional yank)
1120   "Start composing a wide reply mail to the current message.
1121 If prefix argument YANK is non-nil, the original article is yanked
1122 automatically."
1123   (interactive
1124    (list (and current-prefix-arg
1125               (gnus-summary-work-articles 1))))
1126   (gnus-summary-reply yank t))
1127
1128 (defun gnus-summary-wide-reply-with-original (n)
1129   "Start composing a wide reply mail to the current message.
1130 The original article will be yanked."
1131   (interactive "P")
1132   (gnus-summary-reply-with-original n t))
1133
1134 (defun gnus-summary-very-wide-reply (&optional yank)
1135   "Start composing a very wide reply mail to the current message.
1136 If prefix argument YANK is non-nil, the original article is yanked
1137 automatically."
1138   (interactive
1139    (list (and current-prefix-arg
1140               (gnus-summary-work-articles 1))))
1141   (gnus-summary-reply yank t (gnus-summary-work-articles yank)))
1142
1143 (defun gnus-summary-very-wide-reply-with-original (n)
1144   "Start composing a very wide reply mail to the current message.
1145 The original article will be yanked."
1146   (interactive "P")
1147   (gnus-summary-reply
1148    (gnus-summary-work-articles n) t (gnus-summary-work-articles n)))
1149
1150 (defun gnus-summary-mail-forward (&optional full-headers post)
1151   "Forward the current message(s) to another user.
1152 If process marks exist, forward all marked messages;
1153 If FULL-HEADERS (the prefix), include full headers when forwarding."
1154   (interactive "P")
1155   (if (null (cdr (gnus-summary-work-articles nil)))
1156       (gnus-setup-message 'forward
1157         (gnus-summary-select-article)
1158         (let ((charset default-mime-charset))
1159           (set-buffer gnus-original-article-buffer)
1160           (make-local-variable 'default-mime-charset)
1161           (setq default-mime-charset charset))
1162         (let ((message-included-forward-headers
1163                (if full-headers "" message-included-forward-headers)))
1164           (message-forward post)))
1165     (gnus-summary-digest-mail-forward nil post)))
1166
1167 (defun gnus-summary-digest-mail-forward (&optional n post)
1168   "Digests and forwards all articles in this series.
1169 If N is a positive number, forward the N next articles.
1170 If N is a negative number, forward the N previous articles.
1171 If N is nil and any articles have been marked with the process mark,
1172 forward those articles instead.
1173 Optional POST will use news to forward instead of mail."
1174   (interactive "P")
1175   (let ((articles (gnus-summary-work-articles n))
1176         (topics "Topics:\n")
1177         subject article frame)
1178     (when (car articles)
1179       (gnus-setup-message 'forward
1180         (gnus-summary-select-article)
1181         (if (cdr articles)
1182             (setq articles (sort articles '<)
1183                   subject "Digested Articles")
1184           (with-current-buffer gnus-original-article-buffer
1185             (setq subject (message-make-forward-subject))))
1186         (if post
1187             (message-news nil subject)
1188           (message-mail nil subject))
1189         (when (and message-use-multi-frames (cdr articles))
1190           (setq frame (window-frame (get-buffer-window (current-buffer)))))
1191         (message-goto-body)
1192         (while (setq article (pop articles))
1193           (save-window-excursion
1194             (set-buffer gnus-summary-buffer)
1195             (gnus-summary-select-article nil nil nil article)
1196             (setq topics (concat topics "    "
1197                                  (mail-header-subject gnus-current-headers)
1198                                  "\n"))
1199             (gnus-summary-remove-process-mark article))
1200           (when frame
1201             (select-frame frame))
1202           (insert (mime-make-tag "message" "rfc822") "\n")
1203           (narrow-to-region (point) (point))
1204           (insert-buffer-substring gnus-original-article-buffer)
1205           (save-restriction
1206             (article-narrow-to-head)
1207             (message-remove-header message-included-forward-headers t nil t))
1208           (goto-char (point-max))
1209           (widen))
1210         (push-mark)
1211         (message-goto-body)
1212         (insert topics)
1213         (message-goto-body)
1214         (mime-edit-enclose-digest-region (point)(mark t))))))
1215
1216 (defun gnus-summary-digest-post-forward (&optional n)
1217   "Digest and forwards all articles in this series to a newsgroup.
1218 If N is a positive number, forward the N next articles.
1219 If N is a negative number, forward the N previous articles.
1220 If N is nil and any articles have been marked with the process mark,
1221 forward those articles instead."
1222   (interactive "P")
1223   (gnus-summary-digest-mail-forward n t))
1224
1225 (defun gnus-summary-resend-message (address n)
1226   "Resend the current article to ADDRESS."
1227   (interactive
1228    (list (message-read-from-minibuffer
1229           "Resend message(s) to: "
1230           (when (gnus-buffer-live-p gnus-original-article-buffer)
1231             ;; If some other article is currently selected, the
1232             ;; initial-contents is wrong. Whatever, it is just the
1233             ;; initial-contents.
1234             (with-current-buffer gnus-original-article-buffer
1235               (nnmail-fetch-field "to"))))
1236          current-prefix-arg))
1237   (let ((articles (gnus-summary-work-articles n))
1238         article)
1239     (while (setq article (pop articles))
1240       (gnus-summary-select-article nil nil nil article)
1241       (save-excursion
1242         (set-buffer gnus-original-article-buffer)
1243         (message-resend address))
1244       (gnus-summary-mark-article-as-forwarded article))))
1245
1246 (defun gnus-summary-post-forward (&optional full-headers)
1247   "Forward the current article to a newsgroup.
1248 If FULL-HEADERS (the prefix), include full headers when forwarding."
1249   (interactive "P")
1250   (gnus-summary-mail-forward full-headers t))
1251
1252 (defvar gnus-nastygram-message
1253   "The following article was inappropriately posted to %s.\n\n"
1254   "Format string to insert in nastygrams.
1255 The current group name will be inserted at \"%s\".")
1256
1257 (defun gnus-summary-mail-nastygram (n)
1258   "Send a nastygram to the author of the current article."
1259   (interactive "P")
1260   (when (or gnus-expert-user
1261             (gnus-y-or-n-p
1262              "Really send a nastygram to the author of the current article? "))
1263     (let ((group gnus-newsgroup-name))
1264       (gnus-summary-reply-with-original n)
1265       (set-buffer gnus-message-buffer)
1266       (message-goto-body)
1267       (insert (format gnus-nastygram-message group))
1268       (message-send-and-exit))))
1269
1270 (defun gnus-summary-mail-crosspost-complaint (n)
1271   "Send a complaint about crossposting to the current article(s)."
1272   (interactive "P")
1273   (let ((articles (gnus-summary-work-articles n))
1274         article)
1275     (while (setq article (pop articles))
1276       (set-buffer gnus-summary-buffer)
1277       (gnus-summary-goto-subject article)
1278       (let ((group (gnus-group-real-name gnus-newsgroup-name))
1279             newsgroups followup-to)
1280         (gnus-summary-select-article)
1281         (set-buffer gnus-original-article-buffer)
1282         (if (and (<= (length (message-tokenize-header
1283                               (setq newsgroups
1284                                     (mail-fetch-field "newsgroups"))
1285                               ", "))
1286                      1)
1287                  (or (not (setq followup-to (mail-fetch-field "followup-to")))
1288                      (not (member group (message-tokenize-header
1289                                          followup-to ", ")))))
1290             (if followup-to
1291                 (gnus-message 1 "Followup-to restricted")
1292               (gnus-message 1 "Not a crossposted article"))
1293           (set-buffer gnus-summary-buffer)
1294           (gnus-summary-reply-with-original 1)
1295           (set-buffer gnus-message-buffer)
1296           (message-goto-body)
1297           (insert (format gnus-crosspost-complaint newsgroups group))
1298           (message-goto-subject)
1299           (re-search-forward " *$")
1300           (replace-match " (crosspost notification)" t t)
1301           (gnus-deactivate-mark)
1302           (when (gnus-y-or-n-p "Send this complaint? ")
1303             (message-send-and-exit)))))))
1304
1305 (defun gnus-mail-parse-comma-list ()
1306   (let (accumulated
1307         beg)
1308     (skip-chars-forward " ")
1309     (while (not (eobp))
1310       (setq beg (point))
1311       (skip-chars-forward "^,")
1312       (while (zerop
1313               (save-excursion
1314                 (save-restriction
1315                   (let ((i 0))
1316                     (narrow-to-region beg (point))
1317                     (goto-char beg)
1318                     (logand (progn
1319                               (while (search-forward "\"" nil t)
1320                                 (incf i))
1321                               (if (zerop i) 2 i))
1322                             2)))))
1323         (skip-chars-forward ",")
1324         (skip-chars-forward "^,"))
1325       (skip-chars-backward " ")
1326       (push (buffer-substring beg (point))
1327             accumulated)
1328       (skip-chars-forward "^,")
1329       (skip-chars-forward ", "))
1330     accumulated))
1331
1332 (defun gnus-inews-add-to-address (group)
1333   (let ((to-address (mail-fetch-field "to")))
1334     (when (and to-address
1335                (gnus-alive-p))
1336       ;; This mail group doesn't have a `to-list', so we add one
1337       ;; here.  Magic!
1338       (when (gnus-y-or-n-p
1339              (format "Do you want to add this as `to-list': %s " to-address))
1340         (gnus-group-add-parameter group (cons 'to-list to-address))))))
1341
1342 (defun gnus-put-message ()
1343   "Put the current message in some group and return to Gnus."
1344   (interactive)
1345   (let ((reply gnus-article-reply)
1346         (winconf gnus-prev-winconf)
1347         (group gnus-newsgroup-name))
1348     (unless (and group
1349                  (not (gnus-group-read-only-p group)))
1350       (setq group (read-string "Put in group: " nil (gnus-writable-groups))))
1351
1352     (when (gnus-gethash group gnus-newsrc-hashtb)
1353       (error "No such group: %s" group))
1354     (save-excursion
1355       (save-restriction
1356         (widen)
1357         (message-narrow-to-headers)
1358         (let ((gnus-deletable-headers nil))
1359           (message-generate-headers
1360            (if (message-news-p)
1361                message-required-news-headers
1362              message-required-mail-headers)))
1363         (goto-char (point-max))
1364         (insert "Gcc: " group "\n")
1365         (widen)))
1366     (gnus-inews-do-gcc)
1367     (when (and (get-buffer gnus-group-buffer)
1368                (gnus-buffer-exists-p (car-safe reply))
1369                (cdr reply))
1370       (set-buffer (car reply))
1371       (gnus-summary-mark-article-as-replied (cdr reply)))
1372     (when winconf
1373       (set-window-configuration winconf))))
1374
1375 (defun gnus-article-mail (yank)
1376   "Send a reply to the address near point.
1377 If YANK is non-nil, include the original article."
1378   (interactive "P")
1379   (let ((address
1380          (buffer-substring
1381           (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point)))
1382           (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point))))))
1383     (when address
1384       (message-reply address)
1385       (when yank
1386         (gnus-inews-yank-articles (list (cdr gnus-article-current)))))))
1387
1388 (defvar nntp-server-type)
1389 (defun gnus-bug ()
1390   "Send a bug report to the Gnus maintainers."
1391   (interactive)
1392   (unless (gnus-alive-p)
1393     (error "Gnus has been shut down"))
1394   (gnus-setup-message (if (message-mail-user-agent) 'message 'bug)
1395     (unless (message-mail-user-agent)
1396       (message-pop-to-buffer "*Gnus Bug*")
1397       (delete-other-windows)
1398       (when gnus-bug-create-help-buffer
1399         (switch-to-buffer "*Gnus Help Bug*")
1400         (erase-buffer)
1401         (insert gnus-bug-message)
1402         (goto-char (point-min))
1403         (sit-for 0)
1404         (set-buffer "*Gnus Bug*")))
1405     (let ((message-this-is-mail t))
1406       (message-setup `((To . ,gnus-maintainer) (Subject . ""))))
1407     (when gnus-bug-create-help-buffer
1408       (push `(gnus-bug-kill-buffer) message-send-actions))
1409     (goto-char (point-min))
1410     (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
1411     (forward-line 1)
1412     (insert gnus-product-name " " gnus-version-number
1413             " (r" gnus-revision-number ") "
1414             "based on " gnus-original-product-name " v"
1415             gnus-original-version-number "\n"
1416             (emacs-version) "\n")
1417     (when (and (boundp 'nntp-server-type)
1418                (stringp nntp-server-type))
1419       (insert nntp-server-type))
1420     (insert "\n\n\n\n\n")
1421     (let (mime-content-types)
1422       (mime-edit-insert-tag
1423        "application" "emacs-lisp"
1424        "\nContent-Disposition: inline\nContent-Description: User settings"))
1425     (insert (with-temp-buffer
1426               (gnus-debug)
1427               (buffer-string)))
1428     (let (mime-content-types)
1429       (mime-edit-insert-tag "text" "plain"))
1430     (goto-char (point-min))
1431     (search-forward "Subject: " nil t)
1432     (message "")))
1433
1434 (defun gnus-bug-kill-buffer ()
1435   (when (get-buffer "*Gnus Help Bug*")
1436     (kill-buffer "*Gnus Help Bug*")))
1437
1438 (defun gnus-summary-yank-message (buffer n)
1439   "Yank the current article into a composed message."
1440   (interactive
1441    (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t)
1442          current-prefix-arg))
1443   (when (gnus-buffer-live-p buffer)
1444     (let ((summary-frame (selected-frame))
1445           (message-frame (when (static-if (featurep 'xemacs)
1446                                    (device-on-window-system-p)
1447                                  window-system)
1448                            (let ((window (get-buffer-window buffer t)))
1449                              (when window
1450                                (window-frame window)))))
1451           (separator (concat "^" (regexp-quote mail-header-separator)
1452                              "\n")))
1453       (gnus-summary-iterate n
1454         (gnus-summary-select-article)
1455         (gnus-copy-article-buffer)
1456         (when (frame-live-p message-frame)
1457           (raise-frame message-frame)
1458           (select-frame message-frame))
1459         (with-current-buffer buffer
1460           (when (save-excursion
1461                   (beginning-of-line)
1462                   (let (case-fold-search)
1463                     (and (not (re-search-backward separator nil t))
1464                          (re-search-forward separator nil t))))
1465             (goto-char (match-end 0)))
1466           (message-yank-buffer gnus-article-copy))
1467         (select-frame summary-frame))
1468       (when (frame-live-p message-frame)
1469         (select-frame message-frame)))))
1470
1471 (defun gnus-debug ()
1472   "Attempts to go through the Gnus source file and report what variables have been changed.
1473 The source file has to be in the Emacs load path."
1474   (interactive)
1475   (let ((files gnus-debug-files)
1476         (point (point))
1477         file expr olist sym)
1478     (gnus-message 4 "Please wait while we snoop your variables...")
1479     ;; Go through all the files looking for non-default values for variables.
1480     (save-excursion
1481       (sit-for 0)
1482       (set-buffer (gnus-get-buffer-create " *gnus bug info*"))
1483       (while files
1484         (erase-buffer)
1485         (when (and (setq file (locate-library (pop files)))
1486                    (file-exists-p file))
1487           (insert-file-contents file)
1488           (goto-char (point-min))
1489           (if (not (re-search-forward "^;;* *Internal variables" nil t))
1490               (gnus-message 4 "Malformed sources in file %s" file)
1491             (narrow-to-region (point-min) (point))
1492             (goto-char (point-min))
1493             (while (setq expr (ignore-errors (read (current-buffer))))
1494               (ignore-errors
1495                 (and (memq (car expr) '(defvar defcustom defvoo))
1496                      (stringp (nth 3 expr))
1497                      (not (memq (nth 1 expr) gnus-debug-exclude-variables))
1498                      (or (not (boundp (nth 1 expr)))
1499                          (not (equal (eval (nth 2 expr))
1500                                      (symbol-value (nth 1 expr)))))
1501                      (push (nth 1 expr) olist)))))))
1502       (kill-buffer (current-buffer)))
1503     (when (setq olist (nreverse olist))
1504       (insert ";----------------- Environment follows ------------------\n\n"))
1505     (while olist
1506       (if (boundp (car olist))
1507           (condition-case ()
1508               (pp `(setq ,(car olist)
1509                          ,(if (or (consp (setq sym (symbol-value (car olist))))
1510                                   (and (symbolp sym)
1511                                        (not (or (eq sym nil)
1512                                                 (eq sym t)))))
1513                               (list 'quote (symbol-value (car olist)))
1514                             (symbol-value (car olist))))
1515                   (current-buffer))
1516             (error
1517              (format "(setq %s 'whatever)\n" (car olist))))
1518         (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))
1519       (setq olist (cdr olist)))
1520     ;; Remove any control chars - they seem to cause trouble for some
1521     ;; mailers.  (Byte-compiled output from the stuff above.)
1522     (goto-char point)
1523     (while (re-search-forward "[\000-\010\013-\037\200-\237]" nil t)
1524       (replace-match (format "\\%03o" (string-to-char (match-string 0)))
1525                      t t))
1526     ;; Break MIME tags purposely.
1527     (goto-char point)
1528     (while (re-search-forward mime-edit-tag-regexp nil t)
1529       (goto-char (1+ (match-beginning 0)))
1530       (insert "X"))))
1531
1532 ;;; Treatment of rejected articles.
1533 ;;; Bounced mail.
1534
1535 (defun gnus-summary-resend-bounced-mail (&optional fetch)
1536   "Re-mail the current message.
1537 This only makes sense if the current message is a bounce message than
1538 contains some mail you have written which has been bounced back to
1539 you.
1540 If FETCH, try to fetch the article that this is a reply to, if indeed
1541 this is a reply."
1542   (interactive "P")
1543   (gnus-summary-select-article t)
1544   (set-buffer gnus-original-article-buffer)
1545   (let ((gnus-message-setup-hook '(gnus-maybe-setup-default-charset)))
1546     (gnus-setup-message 'compose-bounce
1547       (let* ((references (mail-fetch-field "references"))
1548              (parent (and references (gnus-parent-id references))))
1549         (message-bounce)
1550         ;; If there are references, we fetch the article we answered to.
1551         (and fetch parent
1552              (gnus-summary-refer-article parent)
1553              (gnus-summary-show-all-headers))))))
1554
1555 ;;; Gcc handling.
1556
1557 (defun gnus-inews-group-method (group)
1558   (cond
1559    ;; If the group doesn't exist, we assume
1560    ;; it's an archive group...
1561    ((and (null (gnus-get-info group))
1562          (eq (car (gnus-server-to-method gnus-message-archive-method))
1563              (car (gnus-server-to-method (gnus-group-method group)))))
1564     gnus-message-archive-method)
1565    ;; Use the method.
1566    ((gnus-info-method (gnus-get-info group))
1567     (gnus-info-method (gnus-get-info group)))
1568    ;; Find the method.
1569    (t (gnus-server-to-method (gnus-group-method group)))))
1570
1571 ;; Do Gcc handling, which copied the message over to some group.
1572 (defun gnus-inews-do-gcc (&optional gcc)
1573   (interactive)
1574   (save-excursion
1575     (save-restriction
1576       (message-narrow-to-headers)
1577       (let ((gcc (or gcc (mail-fetch-field "gcc" nil t)))
1578             (coding-system-for-write 'raw-text)
1579             (output-coding-system 'raw-text)
1580             groups group method group-art
1581             mml-externalize-attachments)
1582         (when gcc
1583           (message-remove-header "gcc")
1584           (widen)
1585           (setq groups (message-unquote-tokens
1586                         (message-tokenize-header gcc " ,")))
1587           ;; Copy the article over to some group(s).
1588           (while (setq group (pop groups))
1589             (unless (gnus-check-server
1590                      (setq method (gnus-inews-group-method group)))
1591               (error "Can't open server %s" (if (stringp method) method
1592                                               (car method))))
1593             (unless (gnus-request-group group nil method)
1594               (gnus-request-create-group group method))
1595             (setq mml-externalize-attachments
1596                   (if (stringp gnus-gcc-externalize-attachments)
1597                       (string-match gnus-gcc-externalize-attachments group)
1598                     gnus-gcc-externalize-attachments))
1599             (save-excursion
1600               (nnheader-set-temp-buffer " *acc*")
1601               (insert-buffer-substring message-encoding-buffer)
1602               (gnus-run-hooks 'gnus-before-do-gcc-hook)
1603               (goto-char (point-min))
1604               (when (re-search-forward
1605                      (concat "^" (regexp-quote mail-header-separator) "$")
1606                      nil t)
1607                 (replace-match "" t t ))
1608               (unless (setq group-art
1609                             (gnus-request-accept-article group method t t))
1610                 (gnus-message 1 "Couldn't store article in group %s: %s"
1611                               group (gnus-status-message method))
1612                 (sit-for 2))
1613               (when (and group-art
1614                          (or gnus-gcc-mark-as-read
1615                              gnus-inews-mark-gcc-as-read))
1616                 (gnus-group-mark-article-read group (cdr group-art)))
1617               (kill-buffer (current-buffer)))))))))
1618
1619 (defun gnus-inews-insert-gcc ()
1620   "Insert Gcc headers based on `gnus-outgoing-message-group'."
1621   (save-excursion
1622     (save-restriction
1623       (message-narrow-to-headers)
1624       (let* ((group gnus-outgoing-message-group)
1625              (gcc (cond
1626                    ((gnus-functionp group)
1627                     (funcall group))
1628                    ((or (stringp group) (list group))
1629                     group))))
1630         (when gcc
1631           (insert "Gcc: "
1632                   (if (stringp gcc) gcc
1633                     (mapconcat 'identity gcc " "))
1634                   "\n"))))))
1635
1636 (defun gnus-inews-insert-archive-gcc (&optional group)
1637   "Insert the Gcc to say where the article is to be archived."
1638   (let* ((var gnus-message-archive-group)
1639          (group (or group gnus-newsgroup-name ""))
1640          (gcc-self-val
1641           (and gnus-newsgroup-name
1642                (not (equal gnus-newsgroup-name ""))
1643                (gnus-group-find-parameter
1644                 gnus-newsgroup-name 'gcc-self)))
1645          result
1646          (groups
1647           (cond
1648            ((null gnus-message-archive-method)
1649             ;; Ignore.
1650             nil)
1651            ((stringp var)
1652             ;; Just a single group.
1653             (list var))
1654            ((null var)
1655             ;; We don't want this.
1656             nil)
1657            ((and (listp var) (stringp (car var)))
1658             ;; A list of groups.
1659             var)
1660            ((gnus-functionp var)
1661             ;; A function.
1662             (funcall var group))
1663            (t
1664             ;; An alist of regexps/functions/forms.
1665             (while (and var
1666                         (not
1667                          (setq result
1668                                (cond
1669                                 ((stringp (caar var))
1670                                  ;; Regexp.
1671                                  (when (string-match (caar var) group)
1672                                    (cdar var)))
1673                                 ((gnus-functionp (car var))
1674                                  ;; Function.
1675                                  (funcall (car var) group))
1676                                 (t
1677                                  (eval (car var)))))))
1678               (setq var (cdr var)))
1679             result)))
1680          name)
1681     (when (or groups gcc-self-val)
1682       (when (stringp groups)
1683         (setq groups (list groups)))
1684       (save-excursion
1685         (save-restriction
1686           (message-narrow-to-headers)
1687           (goto-char (point-max))
1688           (insert "Gcc: ")
1689           (if gcc-self-val
1690               ;; Use the `gcc-self' param value instead.
1691               (progn
1692                 (insert
1693                  (if (stringp gcc-self-val)
1694                      gcc-self-val
1695                    group))
1696                 (if (not (eq gcc-self-val 'none))
1697                     (insert "\n")
1698                   (progn
1699                     (beginning-of-line)
1700                     (kill-line))))
1701             ;; Use the list of groups.
1702             (while (setq name (pop groups))
1703               (insert (if (string-match ":" name)
1704                           name
1705                         (gnus-group-prefixed-name
1706                          name gnus-message-archive-method)))
1707               (when groups
1708                 (insert " ")))
1709             (insert "\n")))))))
1710
1711 ;;; Posting styles.
1712
1713 (defun gnus-configure-posting-styles (&optional group-name)
1714   "Configure posting styles according to `gnus-posting-styles'."
1715   (unless gnus-inhibit-posting-styles
1716     (let ((group (or group-name gnus-newsgroup-name ""))
1717           (styles gnus-posting-styles)
1718           style match variable attribute value v results
1719           filep name address element)
1720       ;; If the group has a posting-style parameter, add it at the end with a
1721       ;; regexp matching everything, to be sure it takes precedence over all
1722       ;; the others.
1723       (when gnus-newsgroup-name
1724         (let ((tmp-style (gnus-group-find-parameter group 'posting-style t)))
1725           (when tmp-style
1726             (setq styles (append styles (list (cons ".*" tmp-style)))))))
1727       ;; Go through all styles and look for matches.
1728       (dolist (style styles)
1729         (setq match (pop style))
1730         (goto-char (point-min))
1731         (when (cond
1732                ((stringp match)
1733                 ;; Regexp string match on the group name.
1734                 (string-match match group))
1735                ((eq match 'header)
1736                 ;; Obsolete format of header match.
1737                 (and (gnus-buffer-live-p gnus-article-copy)
1738                      (with-current-buffer gnus-article-copy
1739                        (let ((header (message-fetch-field (pop style))))
1740                          (and header
1741                               (string-match (pop style) header))))))
1742                ((or (symbolp match)
1743                     (gnus-functionp match))
1744                 (cond
1745                  ((gnus-functionp match)
1746                   ;; Function to be called.
1747                   (funcall match))
1748                  ((boundp match)
1749                   ;; Variable to be checked.
1750                   (symbol-value match))))
1751                ((listp match)
1752                 (cond
1753                  ((eq (car match) 'header)
1754                   ;; New format of header match.
1755                   (and (gnus-buffer-live-p gnus-article-copy)
1756                        (with-current-buffer gnus-article-copy
1757                          (let ((header (message-fetch-field (nth 1 match))))
1758                            (and header
1759                                 (string-match (nth 2 match) header))))))
1760                  (t
1761                   ;; This is a form to be evaled.
1762                   (eval match)))))
1763           ;; We have a match, so we set the variables.
1764           (dolist (attribute style)
1765             (setq element (pop attribute)
1766                   variable nil
1767                   filep nil)
1768             (setq value
1769                   (cond
1770                    ((eq (car attribute) ':file)
1771                     (setq filep t)
1772                     (cadr attribute))
1773                    ((eq (car attribute) :value)
1774                     (cadr attribute))
1775                    (t
1776                     (car attribute))))
1777             ;; We get the value.
1778             (setq v
1779                   (cond
1780                    ((stringp value)
1781                     value)
1782                    ((or (symbolp value)
1783                         (gnus-functionp value))
1784                     (cond ((gnus-functionp value)
1785                            (funcall value))
1786                           ((boundp value)
1787                            (symbol-value value))))
1788                    ((listp value)
1789                     (eval value))))
1790             ;; Translate obsolescent value.
1791             (when (eq element 'signature-file)
1792               (setq element 'signature
1793                     filep t))
1794             ;; Get the contents of file elems.
1795             (when (and filep v)
1796               (setq v (with-temp-buffer
1797                         (insert-file-contents v)
1798                         (buffer-string))))
1799             (setq results (delq (assoc element results) results))
1800             (push (cons element v) results))))
1801       ;; Now we have all the styles, so we insert them.
1802       (setq name (assq 'name results)
1803             address (assq 'address results))
1804       (setq results (delq name (delq address results)))
1805       ;; make-local-hook is not obsolete in Emacs 20 or XEmacs.
1806       (make-local-hook 'message-setup-hook)
1807       (dolist (result results)
1808         (add-hook 'message-setup-hook
1809                   (cond
1810                    ((eq 'eval (car result))
1811                     'ignore)
1812                    ((eq 'body (car result))
1813                     `(lambda ()
1814                        (save-excursion
1815                          (message-goto-body)
1816                          (insert ,(cdr result)))))
1817                    ((eq 'signature (car result))
1818                     (set (make-local-variable 'message-signature) nil)
1819                     (set (make-local-variable 'message-signature-file) nil)
1820                     (if (not (cdr result))
1821                         'ignore
1822                       `(lambda ()
1823                          (save-excursion
1824                            (let ((message-signature ,(cdr result)))
1825                              (when message-signature
1826                                (message-insert-signature)))))))
1827                    (t
1828                     (let ((header
1829                            (if (symbolp (car result))
1830                                (capitalize (symbol-name (car result)))
1831                              (car result))))
1832                       `(lambda ()
1833                          (save-excursion
1834                            (message-remove-header ,header)
1835                            (let ((value ,(cdr result)))
1836                              (when value
1837                                (message-goto-eoh)
1838                                (insert ,header ": " value "\n"))))))))
1839                   nil 'local))
1840       (when (or name address)
1841         (add-hook 'message-setup-hook
1842                   `(lambda ()
1843                      (set (make-local-variable 'user-mail-address)
1844                           ,(or (cdr address) user-mail-address))
1845                      (let ((user-full-name ,(or (cdr name) (user-full-name)))
1846                            (user-mail-address
1847                             ,(or (cdr address) user-mail-address)))
1848                        (save-excursion
1849                          (message-remove-header "From")
1850                          (message-goto-eoh)
1851                          (insert "From: " (message-make-from) "\n"))))
1852                   nil 'local)))))
1853
1854
1855 ;;; @ for MIME Edit mode
1856 ;;;
1857
1858 (defun gnus-maybe-setup-default-charset ()
1859   (let ((charset
1860          (and (boundp 'gnus-summary-buffer)
1861               (buffer-live-p gnus-summary-buffer)
1862               (save-excursion
1863                 (set-buffer gnus-summary-buffer)
1864                 default-mime-charset))))
1865     (if charset
1866         (progn
1867           (make-local-variable 'default-mime-charset)
1868           (setq default-mime-charset charset)
1869           ))))
1870
1871
1872 ;;; @ for MIME view mode
1873 ;;;
1874
1875 (defun gnus-following-method (buf)
1876   (gnus-setup-message 'reply-yank
1877     (set-buffer buf)
1878     (if (message-news-p)
1879         (message-followup)
1880       (message-reply nil 'wide))
1881     (let ((message-reply-buffer buf))
1882       (message-yank-original))
1883     (message-goto-body))
1884   (kill-buffer buf))
1885
1886
1887 ;;; Allow redefinition of functions.
1888
1889 (gnus-ems-redefine)
1890
1891 (provide 'gnus-msg)
1892
1893 ;;; gnus-msg.el ends here