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

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