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

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