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

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