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

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