lisp/gnus/gnus-msg.el

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