cgit.sxemacs.org Git - gnus/blob - lisp/gnus-msg.el

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