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,96,97,98 Free Software Foundation, Inc.
   3
   4 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   5 ;;      Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   7 ;;      Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
   8 ;; Keywords: mail, news, MIME
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;;; Code:
  30
  31 (eval-when-compile (require 'cl))
  32
  33 (require 'gnus)
  34 (require 'gnus-ems)
  35 (require 'message)
  36 (require 'gnus-art)
  37
  38 (defcustom gnus-post-method nil
  39   "*Preferred method for posting USENET news.
  40
  41 If this variable is `current', Gnus will use the \"current\" select
  42 method when posting.  If it is nil (which is the default), Gnus will
  43 use the native posting method of the server.
  44
  45 This method will not be used in mail groups and the like, only in
  46 \"real\" newsgroups.
  47
  48 If not nil nor `native', the value must be a valid method as discussed
  49 in the documentation of `gnus-select-method'. It can also be a list of
  50 methods. If that is the case, the user will be queried for what select
  51 method to use when posting."
  52   :group 'gnus-group-foreign
  53   :type `(choice (const nil)
  54                  (const current)
  55                  (const native)
  56                  (sexp :tag "Methods" ,gnus-select-method)))
  57
  58 (defvar gnus-outgoing-message-group nil
  59   "*All outgoing messages will be put in this group.
  60 If you want to store all your outgoing mail and articles in the group
  61 \"nnml:archive\", you set this variable to that value.  This variable
  62 can also be a list of group names.
  63
  64 If you want to have greater control over what group to put each
  65 message in, you can set this variable to a function that checks the
  66 current newsgroup name and then returns a suitable group name (or list
  67 of names).")
  68
  69 (defvar gnus-mailing-list-groups nil
  70   "*Regexp matching groups that are really mailing lists.
  71 This is useful when you're reading a mailing list that has been
  72 gatewayed to a newsgroup, and you want to followup to an article in
  73 the group.")
  74
  75 (defvar gnus-add-to-list nil
  76   "*If non-nil, add a `to-list' parameter automatically.")
  77
  78 (defvar gnus-crosspost-complaint
  79   "Hi,
  80
  81 You posted the article below with the following Newsgroups header:
  82
  83 Newsgroups: %s
  84
  85 The %s group, at least, was an inappropriate recipient
  86 of this message.  Please trim your Newsgroups header to exclude this
  87 group before posting in the future.
  88
  89 Thank you.
  90
  91 "
  92   "Format string to be inserted when complaining about crossposts.
  93 The first %s will be replaced by the Newsgroups header;
  94 the second with the current group name.")
  95
  96 (defvar gnus-message-setup-hook nil
  97   "Hook run after setting up a message buffer.")
  98
  99 (defvar gnus-bug-create-help-buffer t
 100   "*Should we create the *Gnus Help Bug* buffer?")
 101
 102 (defvar gnus-posting-styles nil
 103   "*Alist of styles to use when posting.")
 104
 105 (defvar gnus-posting-style-alist
 106   '((organization . message-user-organization)
 107     (signature . message-signature)
 108     (signature-file . message-signature-file)
 109     (address . user-mail-address)
 110     (name . user-full-name))
 111   "*Mapping from style parameters to variables.")
 112
 113 ;;; Internal variables.
 114
 115 (defvar gnus-inhibit-posting-styles nil
 116   "Inhibit the use of posting styles.")
 117
 118 (defvar gnus-message-buffer "*Mail Gnus*")
 119 (defvar gnus-article-copy nil)
 120 (defvar gnus-last-posting-server nil)
 121 (defvar gnus-message-group-art nil)
 122
 123 (defconst gnus-bug-message
 124   "Sending a bug report to the Gnus Towers.
 125 ========================================
 126
 127 The buffer below is a mail buffer.  When you press `C-c C-c', it will
 128 be sent to the Gnus Bug Exterminators.
 129
 130 At the bottom of the buffer you'll see lots of variable settings.
 131 Please do not delete those.  They will tell the Bug People what your
 132 environment is, so that it will be easier to locate the bugs.
 133
 134 If you have found a bug that makes Emacs go \"beep\", set
 135 debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET')
 136 and include the backtrace in your bug report.
 137
 138 Please describe the bug in annoying, painstaking detail.
 139
 140 Thank you for your help in stamping out bugs.
 141 ")
 142
 143 (eval-and-compile
 144   (autoload 'gnus-uu-post-news "gnus-uu" nil t)
 145   (autoload 'news-setup "rnewspost")
 146   (autoload 'news-reply-mode "rnewspost")
 147   (autoload 'rmail-dont-reply-to "mail-utils")
 148   (autoload 'rmail-output "rmailout"))
 149
 150 \f
 151 ;;;
 152 ;;; Gnus Posting Functions
 153 ;;;
 154
 155 (gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map)
 156   "p" gnus-summary-post-news
 157   "f" gnus-summary-followup
 158   "F" gnus-summary-followup-with-original
 159   "c" gnus-summary-cancel-article
 160   "s" gnus-summary-supersede-article
 161   "r" gnus-summary-reply
 162   "R" gnus-summary-reply-with-original
 163   "w" gnus-summary-wide-reply
 164   "W" gnus-summary-wide-reply-with-original
 165   "n" gnus-summary-followup-to-mail
 166   "N" gnus-summary-followup-to-mail-with-original
 167   "m" gnus-summary-mail-other-window
 168   "u" gnus-uu-post-news
 169   "\M-c" gnus-summary-mail-crosspost-complaint
 170   "om" gnus-summary-mail-forward
 171   "op" gnus-summary-post-forward
 172   "Om" gnus-summary-mail-digest
 173   "Op" gnus-summary-post-digest)
 174
 175 (gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map)
 176   "b" gnus-summary-resend-bounced-mail
 177   ;; "c" gnus-summary-send-draft
 178   "r" gnus-summary-resend-message)
 179
 180 ;;; Internal functions.
 181
 182 (defvar gnus-article-reply nil)
 183 (defmacro gnus-setup-message (config &rest forms)
 184   (let ((winconf (make-symbol "gnus-setup-message-winconf"))
 185         (buffer (make-symbol "gnus-setup-message-buffer"))
 186         (article (make-symbol "gnus-setup-message-article"))
 187         (group (make-symbol "gnus-setup-message-group")))
 188     `(let ((,winconf (current-window-configuration))
 189            (,buffer (buffer-name (current-buffer)))
 190            (,article (and gnus-article-reply (gnus-summary-article-number)))
 191            (,group gnus-newsgroup-name)
 192            (message-header-setup-hook
 193             (copy-sequence message-header-setup-hook))
 194            (message-mode-hook (copy-sequence message-mode-hook)))
 195        (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
 196        (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
 197        (add-hook 'message-mode-hook 'gnus-configure-posting-styles)
 198        (unwind-protect
 199            (progn
 200              ,@forms)
 201          (gnus-inews-add-send-actions ,winconf ,buffer ,article)
 202          (setq gnus-message-buffer (current-buffer))
 203          (set (make-local-variable 'gnus-message-group-art)
 204               (cons ,group ,article))
 205          (make-local-variable 'gnus-newsgroup-name)
 206          (gnus-run-hooks 'gnus-message-setup-hook))
 207        (gnus-add-buffer)
 208        (gnus-configure-windows ,config t)
 209        (set-buffer-modified-p nil))))
 210
 211 (defun gnus-inews-add-send-actions (winconf buffer article)
 212   (make-local-hook 'message-sent-hook)
 213   (add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t)
 214   (setq message-post-method
 215         `(lambda (arg)
 216            (gnus-post-method arg ,gnus-newsgroup-name)))
 217   (setq message-newsreader (setq message-mailer (gnus-extended-version)))
 218   (message-add-action
 219    `(set-window-configuration ,winconf) 'exit 'postpone 'kill)
 220   (message-add-action
 221    `(when (gnus-buffer-exists-p ,buffer)
 222       (save-excursion
 223         (set-buffer ,buffer)
 224         ,(when article
 225            `(gnus-summary-mark-article-as-replied ,article))))
 226    'send))
 227
 228 (put 'gnus-setup-message 'lisp-indent-function 1)
 229 (put 'gnus-setup-message 'edebug-form-spec '(form body))
 230
 231 ;;; Post news commands of Gnus group mode and summary mode
 232
 233 (defun gnus-group-mail ()
 234   "Start composing a mail."
 235   (interactive)
 236   (gnus-setup-message 'message
 237     (message-mail)))
 238
 239 (defun gnus-group-post-news (&optional arg)
 240   "Start composing a news message.
 241 If ARG, post to the group under point.
 242 If ARG is 1, prompt for a group name."
 243   (interactive "P")
 244   ;; Bind this variable here to make message mode hooks work ok.
 245   (let ((gnus-newsgroup-name
 246          (if arg
 247              (if (= 1 (prefix-numeric-value arg))
 248                  (completing-read "Newsgroup: " gnus-active-hashtb nil
 249                                   (gnus-read-active-file-p))
 250                (gnus-group-group-name))
 251            "")))
 252     (gnus-post-news 'post gnus-newsgroup-name)))
 253
 254 (defun gnus-summary-post-news ()
 255   "Start composing a news message."
 256   (interactive)
 257   (gnus-post-news 'post gnus-newsgroup-name))
 258
 259 (defun gnus-summary-followup (yank &optional force-news)
 260   "Compose a followup to an article.
 261 If prefix argument YANK is non-nil, original article is yanked automatically."
 262   (interactive
 263    (list (and current-prefix-arg
 264               (gnus-summary-work-articles 1))))
 265   (when yank
 266     (gnus-summary-goto-subject (car yank)))
 267   (save-window-excursion
 268     (gnus-summary-select-article))
 269   (let ((headers (gnus-summary-article-header (gnus-summary-article-number)))
 270         (gnus-newsgroup-name gnus-newsgroup-name))
 271     ;; Send a followup.
 272     (gnus-post-news nil gnus-newsgroup-name
 273                     headers gnus-article-buffer
 274                     yank nil force-news)))
 275
 276 (defun gnus-summary-followup-with-original (n &optional force-news)
 277   "Compose a followup to an article and include the original article."
 278   (interactive "P")
 279   (gnus-summary-followup (gnus-summary-work-articles n) force-news))
 280
 281 (defun gnus-summary-followup-to-mail (&optional arg)
 282   "Followup to the current mail message via news."
 283   (interactive
 284    (list (and current-prefix-arg
 285               (gnus-summary-work-articles 1))))
 286   (gnus-summary-followup arg t))
 287
 288 (defun gnus-summary-followup-to-mail-with-original (&optional arg)
 289   "Followup to the current mail message via news."
 290   (interactive "P")
 291   (gnus-summary-followup (gnus-summary-work-articles arg) t))
 292
 293 (defun gnus-inews-yank-articles (articles)
 294   (let (beg article)
 295     (message-goto-body)
 296     (while (setq article (pop articles))
 297       (save-window-excursion
 298         (set-buffer gnus-summary-buffer)
 299         (gnus-summary-select-article nil nil nil article)
 300         (gnus-summary-remove-process-mark article))
 301       (gnus-copy-article-buffer)
 302       (let ((message-reply-buffer gnus-article-copy)
 303             (message-reply-headers gnus-current-headers))
 304         (message-yank-original)
 305         (setq beg (or beg (mark t))))
 306       (when articles
 307         (insert "\n")))
 308     (push-mark)
 309     (goto-char beg)))
 310
 311 (defun gnus-summary-cancel-article (&optional n symp)
 312   "Cancel an article you posted.
 313 Uses the process-prefix convention.  If given the symbolic
 314 prefix `a', cancel using the standard posting method; if not
 315 post using the current select method."
 316   (interactive (gnus-interactive "P\ny"))
 317   (let ((articles (gnus-summary-work-articles n))
 318         (message-post-method
 319          `(lambda (arg)
 320             (gnus-post-method (not (eq symp 'a)) ,gnus-newsgroup-name)))
 321         article)
 322     (while (setq article (pop articles))
 323       (when (gnus-summary-select-article t nil nil article)
 324         (when (gnus-eval-in-buffer-window gnus-article-buffer
 325                 (save-excursion
 326                   (set-buffer gnus-original-article-buffer)
 327                   (message-cancel-news)))
 328           (gnus-summary-mark-as-read article gnus-canceled-mark)
 329           (gnus-cache-remove-article 1))
 330         (gnus-article-hide-headers-if-wanted))
 331       (gnus-summary-remove-process-mark article))))
 332
 333 (defun gnus-summary-supersede-article ()
 334   "Compose an article that will supersede a previous article.
 335 This is done simply by taking the old article and adding a Supersedes
 336 header line with the old Message-ID."
 337   (interactive)
 338   (let ((article (gnus-summary-article-number)))
 339     (gnus-setup-message 'reply-yank
 340       (gnus-summary-select-article t)
 341       (set-buffer gnus-original-article-buffer)
 342       (message-supersede)
 343       (push
 344        `((lambda ()
 345            (when (gnus-buffer-exists-p ,gnus-summary-buffer)
 346              (save-excursion
 347                (set-buffer ,gnus-summary-buffer)
 348                (gnus-cache-possibly-remove-article ,article nil nil nil t)
 349                (gnus-summary-mark-as-read ,article gnus-canceled-mark)))))
 350        message-send-actions))))
 351
 352 \f
 353
 354 (defun gnus-copy-article-buffer (&optional article-buffer)
 355   ;; make a copy of the article buffer with all text properties removed
 356   ;; this copy is in the buffer gnus-article-copy.
 357   ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
 358   ;; this buffer should be passed to all mail/news reply/post routines.
 359   (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*"))
 360   (buffer-disable-undo gnus-article-copy)
 361   (let ((article-buffer (or article-buffer gnus-article-buffer))
 362         end beg)
 363     (if (not (and (get-buffer article-buffer)
 364                   (gnus-buffer-exists-p article-buffer)))
 365         (error "Can't find any article buffer")
 366       (save-excursion
 367         (set-buffer article-buffer)
 368         (save-restriction
 369           ;; Copy over the (displayed) article buffer, delete
 370           ;; hidden text and remove text properties.
 371           (widen)
 372           (copy-to-buffer gnus-article-copy (point-min) (point-max))
 373           (set-buffer gnus-article-copy)
 374           (gnus-article-delete-text-of-type 'annotation)
 375           (gnus-remove-text-with-property 'gnus-prev)
 376           (gnus-remove-text-with-property 'gnus-next)
 377           (insert
 378            (prog1
 379                (format "%s" (buffer-string))
 380              (erase-buffer)))
 381           ;; Find the original headers.
 382           (set-buffer gnus-original-article-buffer)
 383           (goto-char (point-min))
 384           (while (looking-at message-unix-mail-delimiter)
 385             (forward-line 1))
 386           (setq beg (point))
 387           (setq end (or (search-forward "\n\n" nil t) (point)))
 388           ;; Delete the headers from the displayed articles.
 389           (set-buffer gnus-article-copy)
 390           (delete-region (goto-char (point-min))
 391                          (or (search-forward "\n\n" nil t) (point)))
 392           ;; Insert the original article headers.
 393           (insert-buffer-substring gnus-original-article-buffer beg end)
 394           (gnus-article-decode-rfc1522)))
 395       gnus-article-copy)))
 396
 397 (defun gnus-post-news (post &optional group header article-buffer yank subject
 398                             force-news)
 399   (when article-buffer
 400     (gnus-copy-article-buffer))
 401   (let ((gnus-article-reply article-buffer)
 402         (add-to-list gnus-add-to-list))
 403     (gnus-setup-message (cond (yank 'reply-yank)
 404                               (article-buffer 'reply)
 405                               (t 'message))
 406       (let* ((group (or group gnus-newsgroup-name))
 407              (pgroup group)
 408              to-address to-group mailing-list to-list
 409              newsgroup-p)
 410         (when group
 411           (setq to-address (gnus-group-find-parameter group 'to-address)
 412                 to-group (gnus-group-find-parameter group 'to-group)
 413                 to-list (gnus-group-find-parameter group 'to-list)
 414                 newsgroup-p (gnus-group-find-parameter group 'newsgroup)
 415                 mailing-list (when gnus-mailing-list-groups
 416                                (string-match gnus-mailing-list-groups group))
 417                 group (gnus-group-real-name group)))
 418         (if (or (and to-group
 419                      (gnus-news-group-p to-group))
 420                 newsgroup-p
 421                 force-news
 422                 (and (gnus-news-group-p
 423                       (or pgroup gnus-newsgroup-name)
 424                       (if header (mail-header-number header)
 425                         gnus-current-article))
 426                      (not mailing-list)
 427                      (not to-list)
 428                      (not to-address)))
 429             ;; This is news.
 430             (if post
 431                 (message-news (or to-group group))
 432               (set-buffer gnus-article-copy)
 433               (gnus-msg-treat-broken-reply-to)
 434               (message-followup (if (or newsgroup-p force-news) nil to-group)))
 435           ;; The is mail.
 436           (if post
 437               (progn
 438                 (message-mail (or to-address to-list))
 439                 ;; Arrange for mail groups that have no `to-address' to
 440                 ;; get that when the user sends off the mail.
 441                 (when (and (not to-list)
 442                            (not to-address)
 443                            add-to-list)
 444                   (push (list 'gnus-inews-add-to-address pgroup)
 445                         message-send-actions)))
 446             (set-buffer gnus-article-copy)
 447             (gnus-msg-treat-broken-reply-to)
 448             (message-wide-reply to-address)))
 449         (when yank
 450           (gnus-inews-yank-articles yank))))))
 451
 452 (defun gnus-msg-treat-broken-reply-to ()
 453   "Remove the Reply-to header iff broken-reply-to."
 454   (when (gnus-group-find-parameter
 455          gnus-newsgroup-name 'broken-reply-to)
 456     (save-restriction
 457       (message-narrow-to-head)
 458       (message-remove-header "reply-to"))))
 459
 460 (defun gnus-post-method (arg group &optional silent)
 461   "Return the posting method based on GROUP and ARG.
 462 If SILENT, don't prompt the user."
 463   (let ((group-method (gnus-find-method-for-group group)))
 464     (cond
 465      ;; If the group-method is nil (which shouldn't happen) we use
 466      ;; the default method.
 467      ((null group-method)
 468       (or (and (null (eq gnus-post-method 'active)) gnus-post-method)
 469                gnus-select-method message-post-method))
 470      ;; We want the inverse of the default
 471      ((and arg (not (eq arg 0)))
 472       (if (eq gnus-post-method 'active)
 473           gnus-select-method
 474         group-method))
 475      ;; We query the user for a post method.
 476      ((or arg
 477           (and gnus-post-method
 478                (not (eq gnus-post-method 'current))
 479                (listp (car gnus-post-method))))
 480       (let* ((methods
 481               ;; Collect all methods we know about.
 482               (append
 483                (when (and gnus-post-method
 484                           (not (eq gnus-post-method 'current)))
 485                  (if (listp (car gnus-post-method))
 486                      gnus-post-method
 487                    (list gnus-post-method)))
 488                gnus-secondary-select-methods
 489                (mapcar 'cdr gnus-server-alist)
 490                (list gnus-select-method)
 491                (list group-method)))
 492              method-alist post-methods method)
 493         ;; Weed out all mail methods.
 494         (while methods
 495           (setq method (gnus-server-get-method "" (pop methods)))
 496           (when (or (gnus-method-option-p method 'post)
 497                     (gnus-method-option-p method 'post-mail))
 498             (push method post-methods)))
 499         ;; Create a name-method alist.
 500         (setq method-alist
 501               (mapcar
 502                (lambda (m)
 503                  (list (concat (cadr m) " (" (symbol-name (car m)) ")") m))
 504                post-methods))
 505         ;; Query the user.
 506         (cadr
 507          (assoc
 508           (setq gnus-last-posting-server
 509                 (if (and silent
 510                          gnus-last-posting-server)
 511                     ;; Just use the last value.
 512                     gnus-last-posting-server
 513                   (completing-read
 514                    "Posting method: " method-alist nil t
 515                    (cons (or gnus-last-posting-server "") 0))))
 516           method-alist))))
 517      ;; Override normal method.
 518      ((and (eq gnus-post-method 'current)
 519            (not (eq (car group-method) 'nndraft))
 520            (not arg))
 521       group-method)
 522      ((and gnus-post-method
 523            (not (eq gnus-post-method 'current)))
 524       gnus-post-method)
 525      ;; Use the normal select method.
 526      (t gnus-select-method))))
 527
 528 \f
 529
 530 ;; Dummy to avoid byte-compile warning.
 531 (defvar nnspool-rejected-article-hook)
 532 (defvar xemacs-codename)
 533
 534 ;;; Since the X-Newsreader/X-Mailer are ``vanity'' headers, they might
 535 ;;; as well include the Emacs version as well.
 536 ;;; The following function works with later GNU Emacs, and XEmacs.
 537 (defun gnus-extended-version ()
 538   "Stringified gnus version."
 539   (interactive)
 540   gnus-version)
 541
 542 \f
 543 ;;;
 544 ;;; Gnus Mail Functions
 545 ;;;
 546
 547 ;;; Mail reply commands of Gnus summary mode
 548
 549 (defun gnus-summary-reply (&optional yank wide)
 550   "Start composing a reply mail to the current message.
 551 If prefix argument YANK is non-nil, the original article is yanked
 552 automatically."
 553   (interactive
 554    (list (and current-prefix-arg
 555               (gnus-summary-work-articles 1))))
 556   ;; Stripping headers should be specified with mail-yank-ignored-headers.
 557   (when yank
 558     (gnus-summary-goto-subject (car yank)))
 559   (let ((gnus-article-reply t)
 560         (gnus-inhibit-posting-styles t))
 561     (gnus-setup-message (if yank 'reply-yank 'reply)
 562       (gnus-summary-select-article)
 563       (set-buffer (gnus-copy-article-buffer))
 564       (gnus-msg-treat-broken-reply-to)
 565       (message-reply nil wide)
 566       (when yank
 567         (gnus-inews-yank-articles yank)))))
 568
 569 (defun gnus-summary-reply-with-original (n &optional wide)
 570   "Start composing a reply mail to the current message.
 571 The original article will be yanked."
 572   (interactive "P")
 573   (gnus-summary-reply (gnus-summary-work-articles n) wide))
 574
 575 (defun gnus-summary-wide-reply (&optional yank)
 576   "Start composing a wide reply mail to the current message.
 577 If prefix argument YANK is non-nil, the original article is yanked
 578 automatically."
 579   (interactive
 580    (list (and current-prefix-arg
 581               (gnus-summary-work-articles 1))))
 582   (gnus-summary-reply yank t))
 583
 584 (defun gnus-summary-wide-reply-with-original (n)
 585   "Start composing a wide reply mail to the current message.
 586 The original article will be yanked."
 587   (interactive "P")
 588   (gnus-summary-reply-with-original n t))
 589
 590 (defun gnus-summary-mail-forward (&optional full-headers post)
 591   "Forward the current message to another user.
 592 If FULL-HEADERS (the prefix), include full headers when forwarding."
 593   (interactive "P")
 594   (gnus-setup-message 'forward
 595     (gnus-summary-select-article)
 596     (let ((charset default-mime-charset))
 597       (set-buffer gnus-original-article-buffer)
 598       (make-local-variable 'default-mime-charset)
 599       (setq default-mime-charset charset)
 600       )
 601     (let ((message-included-forward-headers
 602            (if full-headers "" message-included-forward-headers)))
 603       (message-forward post))))
 604
 605 (defun gnus-summary-post-forward (&optional full-headers)
 606   "Forward the current article to a newsgroup.
 607 If FULL-HEADERS (the prefix), include full headers when forwarding."
 608   (interactive "P")
 609   (gnus-summary-mail-forward full-headers t))
 610
 611 ;;; XXX: generate Subject and ``Topics''?
 612 (defun gnus-summary-mail-digest (&optional n post)
 613   "Digests and forwards all articles in this series."
 614   (interactive "P")
 615   (let ((subject "Digested Articles")
 616         (articles (gnus-summary-work-articles n))
 617         article)
 618     (gnus-setup-message 'forward
 619       (gnus-summary-select-article)
 620       (if post (message-news nil subject) (message-mail nil subject))
 621       (message-goto-body)
 622       (while (setq article (pop articles))
 623         (save-window-excursion
 624           (set-buffer gnus-summary-buffer)
 625           (gnus-summary-select-article nil nil nil article)
 626           (gnus-summary-remove-process-mark article))
 627         (insert (mime-make-tag "message" "rfc822") "\n")
 628         (insert-buffer-substring gnus-original-article-buffer))
 629       (push-mark)
 630       (message-goto-body)
 631       (mime-edit-enclose-digest-region (point)(mark t)))))
 632
 633 (defun gnus-summary-post-digest (&optional n)
 634   "Digest and forwards all articles in this series to a newsgroup."
 635   (interactive "P")
 636   (gnus-summary-mail-digest n t))
 637
 638 (defun gnus-summary-resend-message (address n)
 639   "Resend the current article to ADDRESS."
 640   (interactive "sResend message(s) to: \nP")
 641   (let ((articles (gnus-summary-work-articles n))
 642         article)
 643     (while (setq article (pop articles))
 644       (gnus-summary-select-article nil nil nil article)
 645       (save-excursion
 646         (set-buffer gnus-original-article-buffer)
 647         (message-resend address)))))
 648
 649 (defvar gnus-nastygram-message
 650   "The following article was inappropriately posted to %s.\n\n"
 651   "Format string to insert in nastygrams.
 652 The current group name will be inserted at \"%s\".")
 653
 654 (defun gnus-summary-mail-nastygram (n)
 655   "Send a nastygram to the author of the current article."
 656   (interactive "P")
 657   (when (or gnus-expert-user
 658             (gnus-y-or-n-p
 659              "Really send a nastygram to the author of the current article? "))
 660     (let ((group gnus-newsgroup-name))
 661       (gnus-summary-reply-with-original n)
 662       (set-buffer gnus-message-buffer)
 663       (message-goto-body)
 664       (insert (format gnus-nastygram-message group))
 665       (message-send-and-exit))))
 666
 667 (defun gnus-summary-mail-crosspost-complaint (n)
 668   "Send a complaint about crossposting to the current article(s)."
 669   (interactive "P")
 670   (let ((articles (gnus-summary-work-articles n))
 671         article)
 672     (while (setq article (pop articles))
 673       (set-buffer gnus-summary-buffer)
 674       (gnus-summary-goto-subject article)
 675       (let ((group (gnus-group-real-name gnus-newsgroup-name))
 676             newsgroups followup-to)
 677         (gnus-summary-select-article)
 678         (set-buffer gnus-original-article-buffer)
 679         (if (and (<= (length (message-tokenize-header
 680                               (setq newsgroups (mail-fetch-field "newsgroups"))
 681                               ", "))
 682                      1)
 683                  (or (not (setq followup-to (mail-fetch-field "followup-to")))
 684                      (not (member group (message-tokenize-header
 685                                          followup-to ", ")))))
 686             (if followup-to
 687                 (gnus-message 1 "Followup-to restricted")
 688               (gnus-message 1 "Not a crossposted article"))
 689           (set-buffer gnus-summary-buffer)
 690           (gnus-summary-reply-with-original 1)
 691           (set-buffer gnus-message-buffer)
 692           (message-goto-body)
 693           (insert (format gnus-crosspost-complaint newsgroups group))
 694           (message-goto-subject)
 695           (re-search-forward " *$")
 696           (replace-match " (crosspost notification)" t t)
 697           (gnus-deactivate-mark)
 698           (when (gnus-y-or-n-p "Send this complaint? ")
 699             (message-send-and-exit)))))))
 700
 701 (defun gnus-summary-mail-other-window ()
 702   "Compose mail in other window."
 703   (interactive)
 704   (gnus-setup-message 'message
 705     (message-mail)))
 706
 707 (defun gnus-mail-parse-comma-list ()
 708   (let (accumulated
 709         beg)
 710     (skip-chars-forward " ")
 711     (while (not (eobp))
 712       (setq beg (point))
 713       (skip-chars-forward "^,")
 714       (while (zerop
 715               (save-excursion
 716                 (save-restriction
 717                   (let ((i 0))
 718                     (narrow-to-region beg (point))
 719                     (goto-char beg)
 720                     (logand (progn
 721                               (while (search-forward "\"" nil t)
 722                                 (incf i))
 723                               (if (zerop i) 2 i))
 724                             2)))))
 725         (skip-chars-forward ",")
 726         (skip-chars-forward "^,"))
 727       (skip-chars-backward " ")
 728       (push (buffer-substring beg (point))
 729             accumulated)
 730       (skip-chars-forward "^,")
 731       (skip-chars-forward ", "))
 732     accumulated))
 733
 734 (defun gnus-inews-add-to-address (group)
 735   (let ((to-address (mail-fetch-field "to")))
 736     (when (and to-address
 737                (gnus-alive-p))
 738       ;; This mail group doesn't have a `to-list', so we add one
 739       ;; here.  Magic!
 740       (when (gnus-y-or-n-p
 741              (format "Do you want to add this as `to-list': %s " to-address))
 742         (gnus-group-add-parameter group (cons 'to-list to-address))))))
 743
 744 (defun gnus-put-message ()
 745   "Put the current message in some group and return to Gnus."
 746   (interactive)
 747   (let ((reply gnus-article-reply)
 748         (winconf gnus-prev-winconf)
 749         (group gnus-newsgroup-name))
 750
 751     (or (and group (not (gnus-group-read-only-p group)))
 752         (setq group (read-string "Put in group: " nil
 753                                  (gnus-writable-groups))))
 754     (when (gnus-gethash group gnus-newsrc-hashtb)
 755       (error "No such group: %s" group))
 756
 757     (save-excursion
 758       (save-restriction
 759         (widen)
 760         (message-narrow-to-headers)
 761         (let (gnus-deletable-headers)
 762           (if (message-news-p)
 763               (message-generate-headers message-required-news-headers)
 764             (message-generate-headers message-required-mail-headers)))
 765         (goto-char (point-max))
 766         (insert "Gcc: " group "\n")
 767         (widen)))
 768
 769     (gnus-inews-do-gcc)
 770
 771     (when (get-buffer gnus-group-buffer)
 772       (when (gnus-buffer-exists-p (car-safe reply))
 773         (set-buffer (car reply))
 774         (and (cdr reply)
 775              (gnus-summary-mark-article-as-replied
 776               (cdr reply))))
 777       (when winconf
 778         (set-window-configuration winconf)))))
 779
 780 (defun gnus-article-mail (yank)
 781   "Send a reply to the address near point.
 782 If YANK is non-nil, include the original article."
 783   (interactive "P")
 784   (let ((address
 785          (buffer-substring
 786           (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point)))
 787           (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point))))))
 788     (when address
 789       (message-reply address)
 790       (when yank
 791         (gnus-inews-yank-articles (list (cdr gnus-article-current)))))))
 792
 793 (defvar nntp-server-type)
 794 (defun gnus-bug ()
 795   "Send a bug report to the Gnus maintainers."
 796   (interactive)
 797   (unless (gnus-alive-p)
 798     (error "Gnus has been shut down"))
 799   (gnus-setup-message 'bug
 800     (delete-other-windows)
 801     (when gnus-bug-create-help-buffer
 802       (switch-to-buffer "*Gnus Help Bug*")
 803       (erase-buffer)
 804       (insert gnus-bug-message)
 805       (goto-char (point-min)))
 806     (message-pop-to-buffer "*Gnus Bug*")
 807     (message-setup `((To . ,gnus-maintainer) (Subject . "")))
 808     (when gnus-bug-create-help-buffer
 809       (push `(gnus-bug-kill-buffer) message-send-actions))
 810     (goto-char (point-min))
 811     (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
 812     (forward-line 1)
 813     (insert (gnus-version) "\n"
 814             (emacs-version) "\n")
 815     (when (and (boundp 'nntp-server-type)
 816                (stringp nntp-server-type))
 817       (insert nntp-server-type))
 818     (insert "\n\n\n\n\n")
 819     (gnus-debug)
 820     (goto-char (point-min))
 821     (search-forward "Subject: " nil t)
 822     (message "")))
 823
 824 (defun gnus-bug-kill-buffer ()
 825   (when (get-buffer "*Gnus Help Bug*")
 826     (kill-buffer "*Gnus Help Bug*")))
 827
 828 (defun gnus-debug ()
 829   "Attempts to go through the Gnus source file and report what variables have been changed.
 830 The source file has to be in the Emacs load path."
 831   (interactive)
 832   (let ((files '("gnus.el" "gnus-sum.el" "gnus-group.el"
 833                  "gnus-art.el" "gnus-start.el" "gnus-async.el"
 834                  "gnus-msg.el" "gnus-score.el" "gnus-win.el" "gnus-topic.el"
 835                  "nnmail.el" "message.el"))
 836         (point (point))
 837         file expr olist sym)
 838     (gnus-message 4 "Please wait while we snoop your variables...")
 839     (sit-for 0)
 840     ;; Go through all the files looking for non-default values for variables.
 841     (save-excursion
 842       (set-buffer (gnus-get-buffer-create " *gnus bug info*"))
 843       (buffer-disable-undo (current-buffer))
 844       (while files
 845         (erase-buffer)
 846         (when (and (setq file (locate-library (pop files)))
 847                    (file-exists-p file))
 848           (insert-file-contents file)
 849           (goto-char (point-min))
 850           (if (not (re-search-forward "^;;* *Internal variables" nil t))
 851               (gnus-message 4 "Malformed sources in file %s" file)
 852             (narrow-to-region (point-min) (point))
 853             (goto-char (point-min))
 854             (while (setq expr (ignore-errors (read (current-buffer))))
 855               (ignore-errors
 856                 (and (or (eq (car expr) 'defvar)
 857                          (eq (car expr) 'defcustom))
 858                      (stringp (nth 3 expr))
 859                      (or (not (boundp (nth 1 expr)))
 860                          (not (equal (eval (nth 2 expr))
 861                                      (symbol-value (nth 1 expr)))))
 862                      (push (nth 1 expr) olist)))))))
 863       (kill-buffer (current-buffer)))
 864     (when (setq olist (nreverse olist))
 865       (insert "------------------ Environment follows ------------------\n\n"))
 866     (while olist
 867       (if (boundp (car olist))
 868           (condition-case ()
 869               (pp `(setq ,(car olist)
 870                          ,(if (or (consp (setq sym (symbol-value (car olist))))
 871                                   (and (symbolp sym)
 872                                        (not (or (eq sym nil)
 873                                                 (eq sym t)))))
 874                               (list 'quote (symbol-value (car olist)))
 875                             (symbol-value (car olist))))
 876                   (current-buffer))
 877             (error
 878              (format "(setq %s 'whatever)\n" (car olist))))
 879         (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))
 880       (setq olist (cdr olist)))
 881     (insert "\n\n")
 882     ;; Remove any control chars - they seem to cause trouble for some
 883     ;; mailers.  (Byte-compiled output from the stuff above.)
 884     (goto-char point)
 885     (while (re-search-forward "[\000-\010\013-\037\200-\237]" nil t)
 886       (replace-match (format "\\%03o" (string-to-char (match-string 0)))
 887                      t t))))
 888
 889 ;;; Treatment of rejected articles.
 890 ;;; Bounced mail.
 891
 892 (defun gnus-summary-resend-bounced-mail (&optional fetch)
 893   "Re-mail the current message.
 894 This only makes sense if the current message is a bounce message than
 895 contains some mail you have written which has been bounced back to
 896 you.
 897 If FETCH, try to fetch the article that this is a reply to, if indeed
 898 this is a reply."
 899   (interactive "P")
 900   (gnus-summary-select-article t)
 901   (set-buffer gnus-original-article-buffer)
 902   (gnus-setup-message 'compose-bounce
 903     (let* ((references (mail-fetch-field "references"))
 904            (parent (and references (gnus-parent-id references))))
 905       (message-bounce)
 906       ;; If there are references, we fetch the article we answered to.
 907       (and fetch parent
 908            (gnus-summary-refer-article parent)
 909            (gnus-summary-show-all-headers)))))
 910
 911 ;;; Gcc handling.
 912
 913 ;; Do Gcc handling, which copied the message over to some group.
 914 (defun gnus-inews-do-gcc (&optional gcc)
 915   (interactive)
 916   (when (gnus-alive-p)
 917     (save-excursion
 918       (save-restriction
 919         (message-narrow-to-headers)
 920         (let ((gcc (or gcc (mail-fetch-field "gcc" nil t)))
 921               (coding-system-for-write 'raw-text)
 922               groups group method)
 923           (when gcc
 924             (message-remove-header "gcc")
 925             (widen)
 926             (setq groups (message-tokenize-header gcc " ,"))
 927             ;; Copy the article over to some group(s).
 928             (while (setq group (pop groups))
 929               (gnus-check-server
 930                (setq method
 931                      (cond ((and (null (gnus-get-info group))
 932                                  (eq (car gnus-message-archive-method)
 933                                      (car
 934                                       (gnus-server-to-method
 935                                        (gnus-group-method group)))))
 936                             ;; If the group doesn't exist, we assume
 937                             ;; it's an archive group...
 938                             gnus-message-archive-method)
 939                            ;; Use the method.
 940                            ((gnus-info-method (gnus-get-info group))
 941                             (gnus-info-method (gnus-get-info group)))
 942                            ;; Find the method.
 943                            (t (gnus-group-method group)))))
 944               (gnus-check-server method)
 945               (unless (gnus-request-group group t method)
 946                 (gnus-request-create-group group method))
 947               (save-excursion
 948                 (nnheader-set-temp-buffer " *acc*")
 949                 (insert-buffer-substring message-encoding-buffer)
 950                 (gnus-run-hooks 'gnus-before-do-gcc-hook)
 951                 (goto-char (point-min))
 952                 (when (re-search-forward
 953                        (concat "^" (regexp-quote mail-header-separator) "$")
 954                        nil t)
 955                   (replace-match "" t t ))
 956                 (unless (gnus-request-accept-article group method t)
 957                   (gnus-message 1 "Couldn't store article in group %s: %s"
 958                                 group (gnus-status-message method))
 959                   (sit-for 2))
 960                 (kill-buffer (current-buffer))))))))))
 961
 962 (defun gnus-inews-insert-gcc ()
 963   "Insert Gcc headers based on `gnus-outgoing-message-group'."
 964   (save-excursion
 965     (save-restriction
 966       (message-narrow-to-headers)
 967       (let* ((group gnus-outgoing-message-group)
 968              (gcc (cond
 969                    ((gnus-functionp group)
 970                     (funcall group))
 971                    ((or (stringp group) (list group))
 972                     group))))
 973         (when gcc
 974           (insert "Gcc: "
 975                   (if (stringp gcc) gcc
 976                     (mapconcat 'identity gcc " "))
 977                   "\n"))))))
 978
 979 (defun gnus-inews-insert-archive-gcc (&optional group)
 980   "Insert the Gcc to say where the article is to be archived."
 981   (let* ((var gnus-message-archive-group)
 982          (group (or group gnus-newsgroup-name ""))
 983          (gcc-self-val
 984           (and gnus-newsgroup-name
 985                (gnus-group-find-parameter
 986                 gnus-newsgroup-name 'gcc-self)))
 987          result
 988          (groups
 989           (cond
 990            ((null gnus-message-archive-method)
 991             ;; Ignore.
 992             nil)
 993            ((stringp var)
 994             ;; Just a single group.
 995             (list var))
 996            ((null var)
 997             ;; We don't want this.
 998             nil)
 999            ((and (listp var) (stringp (car var)))
1000             ;; A list of groups.
1001             var)
1002            ((gnus-functionp var)
1003             ;; A function.
1004             (funcall var group))
1005            (t
1006             ;; An alist of regexps/functions/forms.
1007             (while (and var
1008                         (not
1009                          (setq result
1010                                (cond
1011                                 ((stringp (caar var))
1012                                  ;; Regexp.
1013                                  (when (string-match (caar var) group)
1014                                    (cdar var)))
1015                                 ((gnus-functionp (car var))
1016                                  ;; Function.
1017                                  (funcall (car var) group))
1018                                 (t
1019                                  (eval (car var)))))))
1020               (setq var (cdr var)))
1021             result)))
1022          name)
1023     (when (or groups gcc-self-val)
1024       (when (stringp groups)
1025         (setq groups (list groups)))
1026       (save-excursion
1027         (save-restriction
1028           (message-narrow-to-headers)
1029           (goto-char (point-max))
1030           (insert "Gcc: ")
1031           (if gcc-self-val
1032               ;; Use the `gcc-self' param value instead.
1033               (progn
1034                 (insert
1035                  (if (stringp gcc-self-val)
1036                      gcc-self-val
1037                    group))
1038                 (if (not (eq gcc-self-val 'none))
1039                     (insert "\n")
1040                   (progn
1041                     (beginning-of-line)
1042                     (kill-line))))
1043             ;; Use the list of groups.
1044             (while (setq name (pop groups))
1045               (insert (if (string-match ":" name)
1046                           name
1047                         (gnus-group-prefixed-name
1048                          name gnus-message-archive-method)))
1049               (when groups
1050                 (insert " ")))
1051             (insert "\n")))))))
1052
1053 ;;; Posting styles.
1054
1055 (defvar gnus-message-style-insertions nil)
1056
1057 (defun gnus-configure-posting-styles ()
1058   "Configure posting styles according to `gnus-posting-styles'."
1059   (unless gnus-inhibit-posting-styles
1060     (let ((styles gnus-posting-styles)
1061           (gnus-newsgroup-name (or gnus-newsgroup-name ""))
1062           style match variable attribute value value-value)
1063       (make-local-variable 'gnus-message-style-insertions)
1064       ;; Go through all styles and look for matches.
1065       (while styles
1066         (setq style (pop styles)
1067               match (pop style))
1068         (when (cond ((stringp match)
1069                      ;; Regexp string match on the group name.
1070                      (string-match match gnus-newsgroup-name))
1071                     ((or (symbolp match)
1072                          (gnus-functionp match))
1073                      (cond ((gnus-functionp match)
1074                             ;; Function to be called.
1075                             (funcall match))
1076                            ((boundp match)
1077                             ;; Variable to be checked.
1078                             (symbol-value match))))
1079                     ((listp match)
1080                      ;; This is a form to be evaled.
1081                      (eval match)))
1082           ;; We have a match, so we set the variables.
1083           (while style
1084             (setq attribute (pop style)
1085                   value (cadr attribute)
1086                   variable nil)
1087             ;; We find the variable that is to be modified.
1088             (if (and (not (stringp (car attribute)))
1089                      (not (eq 'body (car attribute)))
1090                      (not (setq variable
1091                                 (cdr (assq (car attribute)
1092                                            gnus-posting-style-alist)))))
1093                 (message "Couldn't find attribute %s" (car attribute))
1094               ;; We get the value.
1095               (setq value-value
1096                     (cond ((stringp value)
1097                            value)
1098                           ((or (symbolp value)
1099                                (gnus-functionp value))
1100                            (cond ((gnus-functionp value)
1101                                   (funcall value))
1102                                  ((boundp value)
1103                                   (symbol-value value))))
1104                           ((listp value)
1105                            (eval value))))
1106               (if variable
1107                   ;; This is an ordinary variable.
1108                   (set (make-local-variable variable) value-value)
1109                 ;; This is either a body or a header to be inserted in the
1110                 ;; message.
1111                 (when value-value
1112                   (let ((attr (car attribute)))
1113                     (make-local-variable 'message-setup-hook)
1114                     (if (eq 'body attr)
1115                         (add-hook 'message-setup-hook
1116                                   `(lambda ()
1117                                      (save-excursion
1118                                        (message-goto-body)
1119                                        (insert ,value-value))))
1120                       (add-hook 'message-setup-hook
1121                                 'gnus-message-insert-stylings)
1122                       (push (cons (if (stringp attr) attr
1123                                     (symbol-name attr))
1124                                   value-value)
1125                             gnus-message-style-insertions))))))))))))
1126
1127 (defun gnus-message-insert-stylings ()
1128   (let (val)
1129     (save-excursion
1130       (message-goto-eoh)
1131       (while (setq val (pop gnus-message-style-insertions))
1132         (when (cdr val)
1133           (insert (car val) ": " (cdr val) "\n"))
1134         (gnus-pull (car val) gnus-message-style-insertions)))))
1135
1136 ;;; Allow redefinition of functions.
1137
1138 (gnus-ems-redefine)
1139
1140 (provide 'gnus-msg)
1141
1142 ;;; gnus-msg.el ends here