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