lisp/gnus/gnus-msg.el

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