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