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