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