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

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