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

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