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