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.1" ;; 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.1" ;; 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         (with-current-buffer ,buffer
 556           ,(when to-be-marked
 557              (if (eq config 'forward)
 558                  `(gnus-summary-mark-article-as-forwarded ',to-be-marked)
 559                `(gnus-summary-mark-article-as-replied ',to-be-marked)))))
 560      'send)))
 561
 562 (put 'gnus-setup-message 'lisp-indent-function 1)
 563 (put 'gnus-setup-message 'edebug-form-spec '(form body))
 564
 565 ;;; Post news commands of Gnus group mode and summary mode
 566
 567 (defun gnus-group-mail (&optional arg)
 568   "Start composing a mail.
 569 If ARG, use the group under the point to find a posting style.
 570 If ARG is 1, prompt for a group name to find the posting style."
 571   (interactive "P")
 572   ;; We can't `let' gnus-newsgroup-name here, since that leads
 573   ;; to local variables leaking.
 574   (let ((group gnus-newsgroup-name)
 575         ;; make sure last viewed article doesn't affect posting styles:
 576         (gnus-article-copy)
 577         (buffer (current-buffer)))
 578     (unwind-protect
 579         (progn
 580           (setq gnus-newsgroup-name
 581                 (if arg
 582                     (if (= 1 (prefix-numeric-value arg))
 583                         (gnus-group-completing-read
 584                          "Use posting style of group: "
 585                          nil nil (gnus-read-active-file-p))
 586                       (gnus-group-group-name))
 587                   ""))
 588           ;; #### see comment in gnus-setup-message -- drv
 589           (gnus-setup-message 'message (message-mail)))
 590       (with-current-buffer buffer
 591         (setq gnus-newsgroup-name group)))))
 592
 593 (defun gnus-group-news (&optional arg)
 594   "Start composing a news.
 595 If ARG, post to group under point.
 596 If ARG is 1, prompt for group name to post to.
 597
 598 This function prepares a news even when using mail groups.  This is useful
 599 for posting messages to mail groups without actually sending them over the
 600 network.  The corresponding back end must have a 'request-post method."
 601   (interactive "P")
 602   ;; We can't `let' gnus-newsgroup-name here, since that leads
 603   ;; to local variables leaking.
 604   (let ((group gnus-newsgroup-name)
 605         ;; make sure last viewed article doesn't affect posting styles:
 606         (gnus-article-copy)
 607         (buffer (current-buffer)))
 608     (unwind-protect
 609         (progn
 610           (setq gnus-newsgroup-name
 611                 (if arg
 612                     (if (= 1 (prefix-numeric-value arg))
 613                         (gnus-group-completing-read "Use group: "
 614                                                     nil nil
 615                                                     (gnus-read-active-file-p))
 616                       (gnus-group-group-name))
 617                   ""))
 618           ;; #### see comment in gnus-setup-message -- drv
 619           (gnus-setup-message 'message
 620             (message-news (gnus-group-real-name gnus-newsgroup-name))))
 621       (with-current-buffer buffer
 622         (setq gnus-newsgroup-name group)))))
 623
 624 (defun gnus-group-post-news (&optional arg)
 625   "Start composing a message (a news by default).
 626 If ARG, post to group under point.  If ARG is 1, prompt for group name.
 627 Depending on the selected group, the message might be either a mail or
 628 a news."
 629   (interactive "P")
 630   ;; Bind this variable here to make message mode hooks work ok.
 631   (let ((gnus-newsgroup-name
 632          (if arg
 633              (if (= 1 (prefix-numeric-value arg))
 634                  (gnus-group-completing-read "Newsgroup: " nil nil
 635                                              (gnus-read-active-file-p))
 636                (gnus-group-group-name))
 637            ""))
 638         ;; make sure last viewed article doesn't affect posting styles:
 639         (gnus-article-copy))
 640     (gnus-post-news 'post gnus-newsgroup-name nil nil nil nil
 641                     (string= gnus-newsgroup-name ""))))
 642
 643 (defun gnus-summary-mail-other-window (&optional arg)
 644   "Start composing a mail in another window.
 645 Use the posting of the current group by default.
 646 If ARG, don't do that.  If ARG is 1, prompt for group name to find the
 647 posting style."
 648   (interactive "P")
 649   ;; We can't `let' gnus-newsgroup-name here, since that leads
 650   ;; to local variables leaking.
 651   (let ((group gnus-newsgroup-name)
 652         ;; make sure last viewed article doesn't affect posting styles:
 653         (gnus-article-copy)
 654         (buffer (current-buffer)))
 655     (unwind-protect
 656         (progn
 657           (setq gnus-newsgroup-name
 658                 (if arg
 659                     (if (= 1 (prefix-numeric-value arg))
 660                         (gnus-group-completing-read "Use group: "
 661                                                     nil nil
 662                                                     (gnus-read-active-file-p))
 663                       "")
 664                   gnus-newsgroup-name))
 665           ;; #### see comment in gnus-setup-message -- drv
 666           (gnus-setup-message 'message (message-mail)))
 667       (with-current-buffer buffer
 668         (setq gnus-newsgroup-name group)))))
 669
 670 (defun gnus-summary-news-other-window (&optional arg)
 671   "Start composing a news in another window.
 672 Post to the current group by default.
 673 If ARG, don't do that.  If ARG is 1, prompt for group name to post to.
 674
 675 This function prepares a news even when using mail groups.  This is useful
 676 for posting messages to mail groups without actually sending them over the
 677 network.  The corresponding back end must have a 'request-post method."
 678   (interactive "P")
 679   ;; We can't `let' gnus-newsgroup-name here, since that leads
 680   ;; to local variables leaking.
 681   (let ((group gnus-newsgroup-name)
 682         ;; make sure last viewed article doesn't affect posting styles:
 683         (gnus-article-copy)
 684         (buffer (current-buffer)))
 685     (unwind-protect
 686         (progn
 687           (setq gnus-newsgroup-name
 688                 (if arg
 689                     (if (= 1 (prefix-numeric-value arg))
 690                         (gnus-group-completing-read "Use group: "
 691                                                     nil nil
 692                                                     (gnus-read-active-file-p))
 693                       "")
 694                   gnus-newsgroup-name))
 695           ;; #### see comment in gnus-setup-message -- drv
 696           (gnus-setup-message 'message
 697             (progn
 698               (message-news (gnus-group-real-name gnus-newsgroup-name))
 699               (set (make-local-variable 'gnus-discouraged-post-methods)
 700                    (remove
 701                     (car (gnus-find-method-for-group gnus-newsgroup-name))
 702                     gnus-discouraged-post-methods)))))
 703       (with-current-buffer buffer
 704         (setq gnus-newsgroup-name group)))))
 705
 706 (defun gnus-summary-post-news (&optional arg)
 707   "Start composing a message.  Post to the current group by default.
 708 If ARG, don't do that.  If ARG is 1, prompt for a group name to post to.
 709 Depending on the selected group, the message might be either a mail or
 710 a news."
 711   (interactive "P")
 712   ;; Bind this variable here to make message mode hooks work ok.
 713   (let ((gnus-newsgroup-name
 714          (if arg
 715              (if (= 1 (prefix-numeric-value arg))
 716                  (gnus-group-completing-read "Newsgroup: " nil nil
 717                                              (gnus-read-active-file-p))
 718                "")
 719            gnus-newsgroup-name))
 720         ;; make sure last viewed article doesn't affect posting styles:
 721         (gnus-article-copy))
 722     (gnus-post-news 'post gnus-newsgroup-name)))
 723
 724
 725 (defun gnus-summary-followup (yank &optional force-news)
 726   "Compose a followup to an article.
 727 If prefix argument YANK is non-nil, the original article is yanked
 728 automatically.
 729 YANK is a list of elements, where the car of each element is the
 730 article number, and the cdr is the string to be yanked."
 731   (interactive
 732    (list (and current-prefix-arg
 733               (gnus-summary-work-articles 1))))
 734   (when yank
 735     (gnus-summary-goto-subject
 736      (if (listp (car yank))
 737          (caar yank)
 738        (car yank))))
 739   (save-window-excursion
 740     (gnus-summary-select-article))
 741   (let ((headers (gnus-summary-article-header (gnus-summary-article-number)))
 742         (gnus-newsgroup-name gnus-newsgroup-name))
 743     ;; Send a followup.
 744     (gnus-post-news nil gnus-newsgroup-name
 745                     headers gnus-article-buffer
 746                     yank nil force-news)
 747     (gnus-summary-handle-replysign)))
 748
 749 (defun gnus-summary-followup-with-original (n &optional force-news)
 750   "Compose a followup to an article and include the original article.
 751 The text in the region will be yanked.  If the region isn't
 752 active, the entire article will be yanked."
 753   (interactive "P")
 754   (gnus-summary-followup (gnus-summary-work-articles n) force-news))
 755
 756 (defun gnus-summary-followup-to-mail (&optional arg)
 757   "Followup to the current mail message via news."
 758   (interactive
 759    (list (and current-prefix-arg
 760               (gnus-summary-work-articles 1))))
 761   (gnus-summary-followup arg t))
 762
 763 (defun gnus-summary-followup-to-mail-with-original (&optional arg)
 764   "Followup to the current mail message via news."
 765   (interactive "P")
 766   (gnus-summary-followup (gnus-summary-work-articles arg) t))
 767
 768 (defun gnus-inews-yank-articles (articles)
 769   (let (beg article yank-string)
 770     (message-goto-body)
 771     (while (setq article (pop articles))
 772       (when (listp article)
 773         (setq yank-string (nth 1 article)
 774               article (nth 0 article)))
 775       (save-window-excursion
 776         (set-buffer gnus-summary-buffer)
 777         (gnus-summary-select-article nil nil nil article)
 778         (gnus-summary-remove-process-mark article))
 779       (gnus-copy-article-buffer nil yank-string)
 780       (let ((message-reply-buffer gnus-article-copy)
 781             (message-reply-headers
 782              ;; The headers are decoded.
 783              (with-current-buffer gnus-article-copy
 784                (save-restriction
 785                  (nnheader-narrow-to-headers)
 786                  (nnheader-parse-naked-head)))))
 787         (message-yank-original)
 788         (message-exchange-point-and-mark)
 789         (setq beg (or beg (mark t))))
 790       (when articles
 791         (insert "\n")))
 792     (push-mark)
 793     (goto-char beg)))
 794
 795 (defun gnus-summary-cancel-article (&optional n symp)
 796   "Cancel an article you posted.
 797 Uses the process-prefix convention.  If given the symbolic
 798 prefix `a', cancel using the standard posting method; if not
 799 post using the current select method."
 800   (interactive (gnus-interactive "P\ny"))
 801   (let ((message-post-method
 802          `(lambda (arg)
 803             (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name))))
 804     (dolist (article (gnus-summary-work-articles n))
 805       (when (gnus-summary-select-article t nil nil article)
 806         (when (gnus-eval-in-buffer-window gnus-original-article-buffer
 807                 (message-cancel-news))
 808           (gnus-summary-mark-as-read article gnus-canceled-mark)
 809           (gnus-cache-remove-article 1))
 810         (gnus-article-hide-headers-if-wanted))
 811       (gnus-summary-remove-process-mark article))))
 812
 813 (defun gnus-summary-supersede-article ()
 814   "Compose an article that will supersede a previous article.
 815 This is done simply by taking the old article and adding a Supersedes
 816 header line with the old Message-ID."
 817   (interactive)
 818   (let ((article (gnus-summary-article-number)))
 819     (gnus-setup-message 'reply-yank
 820       (gnus-summary-select-article t)
 821       (set-buffer gnus-original-article-buffer)
 822       (message-supersede)
 823       (push
 824        `((lambda ()
 825            (when (gnus-buffer-exists-p ,gnus-summary-buffer)
 826              (with-current-buffer ,gnus-summary-buffer
 827                (gnus-cache-possibly-remove-article ,article nil nil nil t)
 828                (gnus-summary-mark-as-read ,article gnus-canceled-mark)))))
 829        message-send-actions)
 830       ;; Add Gcc header.
 831       (gnus-inews-insert-archive-gcc)
 832       (gnus-inews-insert-gcc))))
 833
 834 \f
 835
 836 (defun gnus-copy-article-buffer (&optional article-buffer yank-string)
 837   ;; make a copy of the article buffer with all text properties removed
 838   ;; this copy is in the buffer gnus-article-copy.
 839   ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
 840   ;; this buffer should be passed to all mail/news reply/post routines.
 841   (setq gnus-article-copy (gnus-get-buffer-create " *gnus article copy*"))
 842   (with-current-buffer gnus-article-copy
 843     (mm-enable-multibyte))
 844   (let ((article-buffer (or article-buffer gnus-article-buffer))
 845         end beg)
 846     (if (not (and (get-buffer article-buffer)
 847                   (gnus-buffer-exists-p article-buffer)))
 848         (error "Can't find any article buffer")
 849       (with-current-buffer article-buffer
 850         (let ((gnus-newsgroup-charset (or gnus-article-charset
 851                                           gnus-newsgroup-charset))
 852               (gnus-newsgroup-ignored-charsets
 853                (or gnus-article-ignored-charsets
 854                    gnus-newsgroup-ignored-charsets)))
 855           (save-restriction
 856             ;; Copy over the (displayed) article buffer, delete
 857             ;; hidden text and remove text properties.
 858             (widen)
 859             (copy-to-buffer gnus-article-copy (point-min) (point-max))
 860             (set-buffer gnus-article-copy)
 861             (when yank-string
 862               (message-goto-body)
 863               (delete-region (point) (point-max))
 864               (insert yank-string))
 865             (gnus-article-delete-text-of-type 'annotation)
 866             (gnus-article-delete-text-of-type 'multipart)
 867             (gnus-remove-text-with-property 'gnus-prev)
 868             (gnus-remove-text-with-property 'gnus-next)
 869             (gnus-remove-text-with-property 'gnus-decoration)
 870             (insert
 871              (prog1
 872                  (buffer-substring-no-properties (point-min) (point-max))
 873                (erase-buffer)))
 874             ;; Find the original headers.
 875             (set-buffer gnus-original-article-buffer)
 876             (goto-char (point-min))
 877             (while (looking-at message-unix-mail-delimiter)
 878               (forward-line 1))
 879             (let ((mail-header-separator ""))
 880               (setq beg (point)
 881                     end (or (message-goto-body)
 882                             ;; There may be just a header.
 883                             (point-max))))
 884             ;; Delete the headers from the displayed articles.
 885             (set-buffer gnus-article-copy)
 886             (let ((mail-header-separator ""))
 887               (delete-region (goto-char (point-min))
 888                              (or (message-goto-body) (point-max))))
 889             ;; Insert the original article headers.
 890             (insert-buffer-substring gnus-original-article-buffer beg end)
 891             ;; Decode charsets.
 892             (let ((gnus-article-decode-hook
 893                    (delq 'article-decode-charset
 894                          (copy-sequence gnus-article-decode-hook)))
 895                   (rfc2047-quote-decoded-words-containing-tspecials t))
 896               (run-hooks 'gnus-article-decode-hook)))))
 897       gnus-article-copy)))
 898
 899 (defun gnus-post-news (post &optional group header article-buffer yank subject
 900                             force-news)
 901   (when article-buffer
 902     (gnus-copy-article-buffer))
 903   (let ((gnus-article-reply (and article-buffer (gnus-summary-article-number)))
 904         (gnus-article-yanked-articles yank)
 905         (add-to-list gnus-add-to-list))
 906     (gnus-setup-message (cond (yank 'reply-yank)
 907                               (article-buffer 'reply)
 908                               (t 'message))
 909       (let* ((group (or group gnus-newsgroup-name))
 910              (charset (gnus-group-name-charset nil group))
 911              (pgroup group)
 912              to-address to-group mailing-list to-list
 913              newsgroup-p)
 914         (when group
 915           (setq to-address (gnus-parameter-to-address group)
 916                 to-group (gnus-group-find-parameter group 'to-group)
 917                 to-list (gnus-parameter-to-list group)
 918                 newsgroup-p (gnus-group-find-parameter group 'newsgroup)
 919                 mailing-list (when gnus-mailing-list-groups
 920                                (string-match gnus-mailing-list-groups group))
 921                 group (gnus-group-name-decode (gnus-group-real-name group)
 922                                               charset)))
 923         (if (or (and to-group
 924                      (gnus-news-group-p to-group))
 925                 newsgroup-p
 926                 force-news
 927                 (and (gnus-news-group-p
 928                       (or pgroup gnus-newsgroup-name)
 929                       (or header gnus-current-article))
 930                      (not mailing-list)
 931                      (not to-list)
 932                      (not to-address)))
 933             ;; This is news.
 934             (if post
 935                 (message-news
 936                  (or to-group
 937                      (and (not (gnus-virtual-group-p pgroup)) group)))
 938               (set-buffer gnus-article-copy)
 939               (gnus-msg-treat-broken-reply-to)
 940               (message-followup (if (or newsgroup-p force-news)
 941                                     (if (save-restriction
 942                                           (article-narrow-to-head)
 943                                           (message-fetch-field "newsgroups"))
 944                                         nil
 945                                       "")
 946                                   to-group)))
 947           ;; The is mail.
 948           (if post
 949               (progn
 950                 (message-mail (or to-address to-list))
 951                 ;; Arrange for mail groups that have no `to-address' to
 952                 ;; get that when the user sends off the mail.
 953                 (when (and (not to-list)
 954                            (not to-address)
 955                            add-to-list)
 956                   (push (list 'gnus-inews-add-to-address pgroup)
 957                         message-send-actions)))
 958             (set-buffer gnus-article-copy)
 959             (gnus-msg-treat-broken-reply-to)
 960             (message-wide-reply to-address)))
 961         (when yank
 962           (gnus-inews-yank-articles yank))))))
 963
 964 (defun gnus-msg-treat-broken-reply-to (&optional force)
 965   "Remove the Reply-to header if broken-reply-to."
 966   (when (or force
 967             (gnus-group-find-parameter
 968              gnus-newsgroup-name 'broken-reply-to))
 969     (save-restriction
 970       (message-narrow-to-head)
 971       (message-remove-header "reply-to"))))
 972
 973 (defun gnus-post-method (arg group &optional silent)
 974   "Return the posting method based on GROUP and ARG.
 975 If SILENT, don't prompt the user."
 976   (let ((gnus-post-method (or (gnus-parameter-post-method group)
 977                               gnus-post-method))
 978         (group-method (gnus-find-method-for-group group)))
 979     (cond
 980      ;; If the group-method is nil (which shouldn't happen) we use
 981      ;; the default method.
 982      ((null group-method)
 983       (or (and (listp gnus-post-method) ;If not current/native/nil
 984                (not (listp (car gnus-post-method))) ; and not a list of methods
 985                gnus-post-method)        ;then use it.
 986           gnus-select-method
 987           message-post-method))
 988      ;; We want the inverse of the default
 989      ((and arg (not (eq arg 0)))
 990       (if (eq gnus-post-method 'current)
 991           gnus-select-method
 992         group-method))
 993      ;; We query the user for a post method.
 994      ((or arg
 995           (and (listp gnus-post-method)
 996                (listp (car gnus-post-method))))
 997       (let* ((methods
 998               ;; Collect all methods we know about.
 999               (append
1000                (when (listp gnus-post-method)
1001                  (if (listp (car gnus-post-method))
1002                      gnus-post-method
1003                    (list gnus-post-method)))
1004                gnus-secondary-select-methods
1005                (mapcar 'cdr gnus-server-alist)
1006                (mapcar 'car gnus-opened-servers)
1007                (list gnus-select-method)
1008                (list group-method)))
1009              method-alist post-methods method)
1010         ;; Weed out all mail methods.
1011         (while methods
1012           (setq method (gnus-server-get-method "" (pop methods)))
1013           (when (and (or (gnus-method-option-p method 'post)
1014                          (gnus-method-option-p method 'post-mail))
1015                      (not (member method post-methods)))
1016             (push method post-methods)))
1017         ;; Create a name-method alist.
1018         (setq method-alist
1019               (mapcar
1020                (lambda (m)
1021                  (if (equal (cadr m) "")
1022                      (list (symbol-name (car m)) m)
1023                    (list (concat (cadr m) " (" (symbol-name (car m)) ")") m)))
1024                post-methods))
1025         ;; Query the user.
1026         (cadr
1027          (assoc
1028           (setq gnus-last-posting-server
1029                 (if (and silent
1030                          gnus-last-posting-server)
1031                     ;; Just use the last value.
1032                     gnus-last-posting-server
1033                   (completing-read
1034                    "Posting method: " method-alist nil t
1035                    (cons (or gnus-last-posting-server "") 0))))
1036           method-alist))))
1037      ;; Override normal method.
1038      ((and (eq gnus-post-method 'current)
1039            (not (memq (car group-method) gnus-discouraged-post-methods))
1040            (gnus-get-function group-method 'request-post t))
1041       (assert (not arg))
1042       group-method)
1043      ;; Use gnus-post-method.
1044      ((listp gnus-post-method)          ;A method...
1045       (assert (not (listp (car gnus-post-method)))) ;... not a list of methods.
1046       gnus-post-method)
1047      ;; Use the normal select method (nil or native).
1048      (t gnus-select-method))))
1049
1050 \f
1051
1052 (defun gnus-extended-version ()
1053   "Stringified Gnus version and Emacs version.
1054 See the variable `gnus-user-agent'."
1055   (interactive)
1056   (if (stringp gnus-user-agent)
1057       gnus-user-agent
1058     ;; `gnus-user-agent' is a list:
1059     (let* ((float-output-format nil)
1060            (gnus-v
1061             (when (memq 'gnus gnus-user-agent)
1062               (concat "Gnus/"
1063                       (prin1-to-string (gnus-continuum-version gnus-version) t)
1064                       " (" gnus-version ")")))
1065            (emacs-v (gnus-emacs-version)))
1066       (concat gnus-v (when (and gnus-v emacs-v) " ")
1067               emacs-v))))
1068
1069 \f
1070 ;;;
1071 ;;; Gnus Mail Functions
1072 ;;;
1073
1074 ;;; Mail reply commands of Gnus summary mode
1075
1076 (defun gnus-summary-reply (&optional yank wide very-wide)
1077   "Start composing a mail reply to the current message.
1078 If prefix argument YANK is non-nil, the original article is yanked
1079 automatically.
1080 If WIDE, make a wide reply.
1081 If VERY-WIDE, make a very wide reply."
1082   (interactive
1083    (list (and current-prefix-arg
1084               (gnus-summary-work-articles 1))))
1085   ;; Allow user to require confirmation before replying by mail to the
1086   ;; author of a news article (or mail message).
1087   (when (or
1088             (not (or (gnus-news-group-p gnus-newsgroup-name)
1089                      gnus-confirm-treat-mail-like-news))
1090             (not (cond ((stringp gnus-confirm-mail-reply-to-news)
1091                         (string-match gnus-confirm-mail-reply-to-news
1092                                       gnus-newsgroup-name))
1093                        ((functionp gnus-confirm-mail-reply-to-news)
1094                         (funcall gnus-confirm-mail-reply-to-news gnus-newsgroup-name))
1095                        (t gnus-confirm-mail-reply-to-news)))
1096             (if (or wide very-wide)
1097                 t ;; Ignore gnus-confirm-mail-reply-to-news for wide and very
1098                   ;; wide replies.
1099               (y-or-n-p "Really reply by mail to article author? ")))
1100     (let* ((article
1101             (if (listp (car yank))
1102                 (caar yank)
1103               (car yank)))
1104            (gnus-article-reply (or article (gnus-summary-article-number)))
1105            (gnus-article-yanked-articles yank)
1106            (headers ""))
1107       ;; Stripping headers should be specified with mail-yank-ignored-headers.
1108       (when yank
1109         (gnus-summary-goto-subject article))
1110       (gnus-setup-message (if yank 'reply-yank 'reply)
1111         (if (not very-wide)
1112             (gnus-summary-select-article)
1113           (dolist (article very-wide)
1114             (gnus-summary-select-article nil nil nil article)
1115             (with-current-buffer (gnus-copy-article-buffer)
1116               (gnus-msg-treat-broken-reply-to)
1117               (save-restriction
1118                 (message-narrow-to-head)
1119                 (setq headers (concat headers (buffer-string)))))))
1120         (set-buffer (gnus-copy-article-buffer))
1121         (gnus-msg-treat-broken-reply-to gnus-msg-force-broken-reply-to)
1122         (save-restriction
1123           (message-narrow-to-head)
1124           (when very-wide
1125             (erase-buffer)
1126             (insert headers))
1127           (goto-char (point-max)))
1128         (mml-quote-region (point) (point-max))
1129         (message-reply nil wide)
1130         (when yank
1131           (gnus-inews-yank-articles yank))
1132         (gnus-summary-handle-replysign)))))
1133
1134 (defun gnus-summary-handle-replysign ()
1135   "Check the various replysign variables and take action accordingly."
1136   (when (or gnus-message-replysign gnus-message-replyencrypt)
1137     (let (signed encrypted)
1138       (with-current-buffer gnus-article-buffer
1139         (setq signed (memq 'signed gnus-article-wash-types))
1140         (setq encrypted (memq 'encrypted gnus-article-wash-types)))
1141       (cond ((and gnus-message-replyencrypt encrypted)
1142              (mml-secure-message mml-default-encrypt-method
1143                                  (if gnus-message-replysignencrypted
1144                                      'signencrypt
1145                                    'encrypt)))
1146             ((and gnus-message-replysign signed)
1147              (mml-secure-message mml-default-sign-method 'sign))))))
1148
1149 (defun gnus-summary-reply-with-original (n &optional wide)
1150   "Start composing a reply mail to the current message.
1151 The original article will be yanked."
1152   (interactive "P")
1153   (gnus-summary-reply (gnus-summary-work-articles n) wide))
1154
1155 (defun gnus-summary-reply-broken-reply-to (&optional yank wide very-wide)
1156   "Like `gnus-summary-reply' except removing reply-to field.
1157 If prefix argument YANK is non-nil, the original article is yanked
1158 automatically.
1159 If WIDE, make a wide reply.
1160 If VERY-WIDE, make a very wide reply."
1161   (interactive
1162    (list (and current-prefix-arg
1163               (gnus-summary-work-articles 1))))
1164   (let ((gnus-msg-force-broken-reply-to t))
1165     (gnus-summary-reply yank wide very-wide)))
1166
1167 (defun gnus-summary-reply-broken-reply-to-with-original (n &optional wide)
1168   "Like `gnus-summary-reply-with-original' except removing reply-to field.
1169 The original article will be yanked."
1170   (interactive "P")
1171   (gnus-summary-reply-broken-reply-to (gnus-summary-work-articles n) wide))
1172
1173 (defun gnus-summary-wide-reply (&optional yank)
1174   "Start composing a wide reply mail to the current message.
1175 If prefix argument YANK is non-nil, the original article is yanked
1176 automatically."
1177   (interactive
1178    (list (and current-prefix-arg
1179               (gnus-summary-work-articles 1))))
1180   (gnus-summary-reply yank t))
1181
1182 (defun gnus-summary-wide-reply-with-original (n)
1183   "Start composing a wide reply mail to the current message.
1184 The original article will be yanked.
1185 Uses the process/prefix convention."
1186   (interactive "P")
1187   (gnus-summary-reply-with-original n t))
1188
1189 (defun gnus-summary-very-wide-reply (&optional yank)
1190   "Start composing a very wide reply mail to the current message.
1191 If prefix argument YANK is non-nil, the original article is yanked
1192 automatically."
1193   (interactive
1194    (list (and current-prefix-arg
1195               (gnus-summary-work-articles 1))))
1196   (gnus-summary-reply yank t (gnus-summary-work-articles yank)))
1197
1198 (defun gnus-summary-very-wide-reply-with-original (n)
1199   "Start composing a very wide reply mail to the current message.
1200 The original article will be yanked."
1201   (interactive "P")
1202   (gnus-summary-reply
1203    (gnus-summary-work-articles n) t (gnus-summary-work-articles n)))
1204
1205 (defun gnus-summary-mail-forward (&optional arg post)
1206   "Forward the current message(s) to another user.
1207 If process marks exist, forward all marked messages;
1208 if ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml';
1209 if ARG is 1, decode the message and forward directly inline;
1210 if ARG is 2, forward message as an rfc822 MIME section;
1211 if ARG is 3, decode message and forward as an rfc822 MIME section;
1212 if ARG is 4, forward message directly inline;
1213 otherwise, use flipped `message-forward-as-mime'.
1214 If POST, post instead of mail.
1215 For the `inline' alternatives, also see the variable
1216 `message-forward-ignored-headers'."
1217   (interactive "P")
1218   (if (cdr (gnus-summary-work-articles nil))
1219       ;; Process marks are given.
1220       (gnus-uu-digest-mail-forward arg post)
1221     ;; No process marks.
1222     (let ((message-forward-as-mime message-forward-as-mime)
1223           (message-forward-show-mml message-forward-show-mml))
1224       (cond
1225        ((null arg))
1226        ((eq arg 1)
1227         (setq message-forward-as-mime nil
1228               message-forward-show-mml t))
1229        ((eq arg 2)
1230         (setq message-forward-as-mime t
1231               message-forward-show-mml nil))
1232        ((eq arg 3)
1233         (setq message-forward-as-mime t
1234               message-forward-show-mml t))
1235        ((eq arg 4)
1236         (setq message-forward-as-mime nil
1237               message-forward-show-mml nil))
1238        (t
1239         (setq message-forward-as-mime (not message-forward-as-mime))))
1240       (let* ((gnus-article-reply (gnus-summary-article-number))
1241              (gnus-article-yanked-articles (list gnus-article-reply)))
1242         (gnus-setup-message 'forward
1243           (gnus-summary-select-article)
1244           (let ((mail-parse-charset
1245                  (or (and (gnus-buffer-live-p gnus-article-buffer)
1246                           (with-current-buffer gnus-article-buffer
1247                             gnus-article-charset))
1248                      gnus-newsgroup-charset))
1249                 (mail-parse-ignored-charsets
1250                  gnus-newsgroup-ignored-charsets))
1251             (set-buffer gnus-original-article-buffer)
1252             (message-forward post)))))))
1253
1254 (defun gnus-summary-resend-message (address n)
1255   "Resend the current article to ADDRESS."
1256   (interactive
1257    (list (message-read-from-minibuffer
1258           "Resend message(s) to: "
1259           (when (and gnus-summary-resend-default-address
1260                      (gnus-buffer-live-p gnus-original-article-buffer))
1261             ;; If some other article is currently selected, the
1262             ;; initial-contents is wrong. Whatever, it is just the
1263             ;; initial-contents.
1264             (with-current-buffer gnus-original-article-buffer
1265               (nnmail-fetch-field "to"))))
1266          current-prefix-arg))
1267   (dolist (article (gnus-summary-work-articles n))
1268     (gnus-summary-select-article nil nil nil article)
1269     (with-current-buffer gnus-original-article-buffer
1270       (message-resend address))
1271     (gnus-summary-mark-article-as-forwarded article)))
1272
1273 ;; From: Matthieu Moy <Matthieu.Moy@imag.fr>
1274 (defun gnus-summary-resend-message-edit ()
1275   "Resend an article that has already been sent.
1276 A new buffer will be created to allow the user to modify body and
1277 contents of the message, and then, everything will happen as when
1278 composing a new message."
1279   (interactive)
1280   (let ((article (gnus-summary-article-number)))
1281     (gnus-setup-message 'reply-yank
1282       (gnus-summary-select-article t)
1283       (set-buffer gnus-original-article-buffer)
1284       (let ((cur (current-buffer))
1285             (to (message-fetch-field "to")))
1286         ;; Get a normal message buffer.
1287         (message-pop-to-buffer (message-buffer-name "Resend" to))
1288         (insert-buffer-substring cur)
1289         (mime-to-mml)
1290         (message-narrow-to-head-1)
1291         ;; Gnus will generate a new one when sending.
1292         (message-remove-header "Message-ID")
1293         ;; Remove unwanted headers.
1294         (message-remove-header message-ignored-resent-headers t)
1295         (goto-char (point-max))
1296         (insert mail-header-separator)
1297         ;; Add Gcc header.
1298         (gnus-inews-insert-archive-gcc)
1299         (gnus-inews-insert-gcc)
1300         (goto-char (point-min))
1301         (when (re-search-forward "^To:\\|^Newsgroups:" nil 'move)
1302           (forward-char 1))
1303         (widen)))))
1304
1305 (defun gnus-summary-post-forward (&optional arg)
1306   "Forward the current article to a newsgroup.
1307 See `gnus-summary-mail-forward' for ARG."
1308   (interactive "P")
1309   (gnus-summary-mail-forward arg t))
1310
1311 (defvar gnus-nastygram-message
1312   "The following article was inappropriately posted to %s.\n\n"
1313   "Format string to insert in nastygrams.
1314 The current group name will be inserted at \"%s\".")
1315
1316 (defun gnus-summary-mail-nastygram (n)
1317   "Send a nastygram to the author of the current article."
1318   (interactive "P")
1319   (when (or gnus-expert-user
1320             (gnus-y-or-n-p
1321              "Really send a nastygram to the author of the current article? "))
1322     (let ((group gnus-newsgroup-name))
1323       (gnus-summary-reply-with-original n)
1324       (set-buffer gnus-message-buffer)
1325       (message-goto-body)
1326       (insert (format gnus-nastygram-message group))
1327       (message-send-and-exit))))
1328
1329 (defun gnus-summary-mail-crosspost-complaint (n)
1330   "Send a complaint about crossposting to the current article(s)."
1331   (interactive "P")
1332   (dolist (article (gnus-summary-work-articles n))
1333     (set-buffer gnus-summary-buffer)
1334     (gnus-summary-goto-subject article)
1335     (let ((group (gnus-group-real-name gnus-newsgroup-name))
1336           newsgroups followup-to)
1337       (gnus-summary-select-article)
1338       (set-buffer gnus-original-article-buffer)
1339       (if (and (<= (length (message-tokenize-header
1340                             (setq newsgroups
1341                                   (mail-fetch-field "newsgroups"))
1342                             ", "))
1343                    1)
1344                (or (not (setq followup-to (mail-fetch-field "followup-to")))
1345                    (not (member group (message-tokenize-header
1346                                        followup-to ", ")))))
1347           (if followup-to
1348               (gnus-message 1 "Followup-to restricted")
1349             (gnus-message 1 "Not a crossposted article"))
1350         (set-buffer gnus-summary-buffer)
1351         (gnus-summary-reply-with-original 1)
1352         (set-buffer gnus-message-buffer)
1353         (message-goto-body)
1354         (insert (format gnus-crosspost-complaint newsgroups group))
1355         (message-goto-subject)
1356         (re-search-forward " *$")
1357         (replace-match " (crosspost notification)" t t)
1358         (gnus-deactivate-mark)
1359         (when (gnus-y-or-n-p "Send this complaint? ")
1360           (message-send-and-exit))))))
1361
1362 (defun gnus-mail-parse-comma-list ()
1363   (let (accumulated
1364         beg)
1365     (skip-chars-forward " ")
1366     (while (not (eobp))
1367       (setq beg (point))
1368       (skip-chars-forward "^,")
1369       (while (zerop
1370               (save-excursion
1371                 (save-restriction
1372                   (let ((i 0))
1373                     (narrow-to-region beg (point))
1374                     (goto-char beg)
1375                     (logand (progn
1376                               (while (search-forward "\"" nil t)
1377                                 (incf i))
1378                               (if (zerop i) 2 i))
1379                             2)))))
1380         (skip-chars-forward ",")
1381         (skip-chars-forward "^,"))
1382       (skip-chars-backward " ")
1383       (push (buffer-substring beg (point))
1384             accumulated)
1385       (skip-chars-forward "^,")
1386       (skip-chars-forward ", "))
1387     accumulated))
1388
1389 (defun gnus-inews-add-to-address (group)
1390   (let ((to-address (mail-fetch-field "to")))
1391     (when (and to-address
1392                (gnus-alive-p))
1393       ;; This mail group doesn't have a `to-list', so we add one
1394       ;; here.  Magic!
1395       (when (gnus-y-or-n-p
1396              (format "Do you want to add this as `to-list': %s? " to-address))
1397         (gnus-group-add-parameter group (cons 'to-list to-address))))))
1398
1399 (defun gnus-put-message ()
1400   "Put the current message in some group and return to Gnus."
1401   (interactive)
1402   (let ((reply gnus-article-reply)
1403         (winconf gnus-prev-winconf)
1404         (group gnus-newsgroup-name))
1405     (unless (and group
1406                  (not (gnus-group-read-only-p group)))
1407       (setq group (read-string "Put in group: " nil (gnus-writable-groups))))
1408
1409     (when (gnus-group-entry group)
1410       (error "No such group: %s" group))
1411     (save-excursion
1412       (save-restriction
1413         (widen)
1414         (message-narrow-to-headers)
1415         (let ((gnus-deletable-headers nil))
1416           (message-generate-headers
1417            (if (message-news-p)
1418                message-required-news-headers
1419              message-required-mail-headers)))
1420         (goto-char (point-max))
1421         (if (string-match " " group)
1422             (insert "Gcc: \"" group "\"\n")
1423           (insert "Gcc: " group "\n"))
1424         (widen)))
1425     (gnus-inews-do-gcc)
1426     (when (and (get-buffer gnus-group-buffer)
1427                (gnus-buffer-exists-p (car-safe reply))
1428                (cdr reply))
1429       (set-buffer (car reply))
1430       (gnus-summary-mark-article-as-replied (cdr reply)))
1431     (when winconf
1432       (set-window-configuration winconf))))
1433
1434 (defun gnus-article-mail (yank)
1435   "Send a reply to the address near point.
1436 If YANK is non-nil, include the original article."
1437   (interactive "P")
1438   (let ((address
1439          (buffer-substring
1440           (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point)))
1441           (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point))))))
1442     (when address
1443       (gnus-msg-mail address)
1444       (when yank
1445         (gnus-inews-yank-articles (list (cdr gnus-article-current)))))))
1446
1447 (defvar nntp-server-type)
1448 (defun gnus-bug ()
1449   "Send a bug report to the Gnus maintainers."
1450   (interactive)
1451   (unless (gnus-alive-p)
1452     (error "Gnus has been shut down"))
1453   (gnus-setup-message (if (message-mail-user-agent) 'message 'bug)
1454     (unless (message-mail-user-agent)
1455       (delete-other-windows)
1456       (when gnus-bug-create-help-buffer
1457         (switch-to-buffer "*Gnus Help Bug*")
1458         (erase-buffer)
1459         (insert gnus-bug-message)
1460         (goto-char (point-min)))
1461       (message-pop-to-buffer "*Gnus Bug*"))
1462     (let ((message-this-is-mail t))
1463       (message-setup `((To . ,gnus-maintainer) (Subject . ""))))
1464     (when gnus-bug-create-help-buffer
1465       (push `(gnus-bug-kill-buffer) message-send-actions))
1466     (goto-char (point-min))
1467     (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
1468     (forward-line 1)
1469     (insert (gnus-version) "\n"
1470             (emacs-version) "\n")
1471     (when (and (boundp 'nntp-server-type)
1472                (stringp nntp-server-type))
1473       (insert nntp-server-type))
1474     (insert "\n\n\n\n\n")
1475     (let (text)
1476       (with-current-buffer (gnus-get-buffer-create " *gnus environment info*")
1477         (erase-buffer)
1478         (gnus-debug)
1479         (setq text (buffer-string)))
1480       (insert "<#part type=application/emacs-lisp disposition=inline description=\"User settings\">\n" text "\n<#/part>"))
1481     (goto-char (point-min))
1482     (search-forward "Subject: " nil t)
1483     (message "")))
1484
1485 (defun gnus-bug-kill-buffer ()
1486   (when (get-buffer "*Gnus Help Bug*")
1487     (kill-buffer "*Gnus Help Bug*")))
1488
1489 (defun gnus-summary-yank-message (buffer n)
1490   "Yank the current article into a composed message."
1491   (interactive
1492    (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t)
1493          current-prefix-arg))
1494   (gnus-summary-iterate n
1495     (let ((gnus-inhibit-treatment t))
1496       (gnus-summary-select-article))
1497     (with-current-buffer buffer
1498       (message-yank-buffer gnus-article-buffer))))
1499
1500 (defun gnus-debug ()
1501   "Attempts to go through the Gnus source file and report what variables have been changed.
1502 The source file has to be in the Emacs load path."
1503   (interactive)
1504   (let ((files gnus-debug-files)
1505         (point (point))
1506         file expr olist sym)
1507     (gnus-message 4 "Please wait while we snoop your variables...")
1508     (sit-for 0)
1509     ;; Go through all the files looking for non-default values for variables.
1510     (with-current-buffer (gnus-get-buffer-create " *gnus bug info*")
1511       (while files
1512         (erase-buffer)
1513         (when (and (setq file (locate-library (pop files)))
1514                    (file-exists-p file))
1515           (insert-file-contents file)
1516           (goto-char (point-min))
1517           (if (not (re-search-forward "^;;* *Internal variables" nil t))
1518               (gnus-message 4 "Malformed sources in file %s" file)
1519             (narrow-to-region (point-min) (point))
1520             (goto-char (point-min))
1521             (while (setq expr (ignore-errors (read (current-buffer))))
1522               (ignore-errors
1523                 (and (or (eq (car expr) 'defvar)
1524                          (eq (car expr) 'defcustom))
1525                      (stringp (nth 3 expr))
1526                      (not (memq (nth 1 expr) gnus-debug-exclude-variables))
1527                      (or (not (boundp (nth 1 expr)))
1528                          (not (equal (eval (nth 2 expr))
1529                                      (symbol-value (nth 1 expr)))))
1530                      (push (nth 1 expr) olist)))))))
1531       (kill-buffer (current-buffer)))
1532     (when (setq olist (nreverse olist))
1533       (insert "------------------ Environment follows ------------------\n\n"))
1534     (while olist
1535       (if (boundp (car olist))
1536           (ignore-errors
1537            (gnus-pp
1538             `(setq ,(car olist)
1539                    ,(if (or (consp (setq sym (symbol-value (car olist))))
1540                             (and (symbolp sym)
1541                                  (not (or (eq sym nil)
1542                                           (eq sym t)))))
1543                         (list 'quote (symbol-value (car olist)))
1544                       (symbol-value (car olist))))))
1545         (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))
1546       (setq olist (cdr olist)))
1547     (insert "\n\n")
1548     ;; Remove any control chars - they seem to cause trouble for some
1549     ;; mailers.  (Byte-compiled output from the stuff above.)
1550     (goto-char point)
1551     (while (re-search-forward (mm-string-to-multibyte
1552                                "[\000-\010\013-\037\200-\237]") nil t)
1553       (replace-match (format "\\%03o" (string-to-char (match-string 0)))
1554                      t t))))
1555
1556 ;;; Treatment of rejected articles.
1557 ;;; Bounced mail.
1558
1559 (defun gnus-summary-resend-bounced-mail (&optional fetch)
1560   "Re-mail the current message.
1561 This only makes sense if the current message is a bounce message that
1562 contains some mail you have written which has been bounced back to
1563 you.
1564 If FETCH, try to fetch the article that this is a reply to, if indeed
1565 this is a reply."
1566   (interactive "P")
1567   (gnus-summary-select-article t)
1568   (let (summary-buffer parent)
1569     (if fetch
1570         (progn
1571           (setq summary-buffer (current-buffer))
1572           (set-buffer gnus-original-article-buffer)
1573           (article-goto-body)
1574           (when (re-search-forward "^References:\n?" nil t)
1575             (while (memq (char-after) '(?\t ? ))
1576               (forward-line 1))
1577             (skip-chars-backward "\t\n ")
1578             (setq parent
1579                   (gnus-parent-id (buffer-substring (match-end 0) (point))))))
1580       (set-buffer gnus-original-article-buffer))
1581     (gnus-setup-message 'compose-bounce
1582       (message-bounce)
1583       ;; Add Gcc header.
1584       (gnus-inews-insert-archive-gcc)
1585       (gnus-inews-insert-gcc)
1586       ;; If there are references, we fetch the article we answered to.
1587       (when parent
1588         (with-current-buffer summary-buffer
1589           (gnus-summary-refer-article parent)
1590           (gnus-summary-show-all-headers))))))
1591
1592 ;;; Gcc handling.
1593
1594 (defun gnus-inews-group-method (group)
1595   (cond
1596    ;; If the group doesn't exist, we assume
1597    ;; it's an archive group...
1598    ((and (null (gnus-get-info group))
1599          (eq (car (gnus-server-to-method gnus-message-archive-method))
1600              (car (gnus-server-to-method (gnus-group-method group)))))
1601     gnus-message-archive-method)
1602    ;; Use the method.
1603    ((gnus-info-method (gnus-get-info group))
1604     (gnus-info-method (gnus-get-info group)))
1605    ;; Find the method.
1606    (t (gnus-server-to-method (gnus-group-method group)))))
1607
1608 ;; Do Gcc handling, which copied the message over to some group.
1609 (defun gnus-inews-do-gcc (&optional gcc)
1610   (interactive)
1611   (save-excursion
1612     (save-restriction
1613       (message-narrow-to-headers)
1614       (let ((gcc (or gcc (mail-fetch-field "gcc" nil t)))
1615             (cur (current-buffer))
1616             groups group method group-art
1617             mml-externalize-attachments)
1618         (when gcc
1619           (message-remove-header "gcc")
1620           (widen)
1621           (setq groups (message-unquote-tokens
1622                         (message-tokenize-header gcc " ,")))
1623           ;; Copy the article over to some group(s).
1624           (while (setq group (pop groups))
1625             (setq method (gnus-inews-group-method group)
1626                   group (mm-encode-coding-string
1627                          group
1628                          (gnus-group-name-charset method group)))
1629             (unless (gnus-check-server method)
1630               (error "Can't open server %s" (if (stringp method) method
1631                                               (car method))))
1632             (unless (gnus-request-group group nil method)
1633               (gnus-request-create-group group method))
1634             (setq mml-externalize-attachments
1635                   (if (stringp gnus-gcc-externalize-attachments)
1636                       (string-match gnus-gcc-externalize-attachments group)
1637                     gnus-gcc-externalize-attachments))
1638             (save-excursion
1639               (nnheader-set-temp-buffer " *acc*")
1640               (insert-buffer-substring cur)
1641               (message-encode-message-body)
1642               (save-restriction
1643                 (message-narrow-to-headers)
1644                 (let* ((mail-parse-charset message-default-charset)
1645                        (newsgroups-field (save-restriction
1646                                            (message-narrow-to-headers-or-head)
1647                                            (message-fetch-field "Newsgroups")))
1648                        (followup-field (save-restriction
1649                                          (message-narrow-to-headers-or-head)
1650                                          (message-fetch-field "Followup-To")))
1651                        ;; BUG: We really need to get the charset for
1652                        ;; each name in the Newsgroups and Followup-To
1653                        ;; lines to allow crossposting between group
1654                        ;; namess with incompatible character sets.
1655                        ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08.
1656                        (group-field-charset
1657                         (gnus-group-name-charset
1658                          method (or newsgroups-field "")))
1659                        (followup-field-charset
1660                         (gnus-group-name-charset
1661                          method (or followup-field "")))
1662                        (rfc2047-header-encoding-alist
1663                         (append
1664                          (when group-field-charset
1665                            (list (cons "Newsgroups" group-field-charset)))
1666                          (when followup-field-charset
1667                            (list (cons "Followup-To" followup-field-charset)))
1668                          rfc2047-header-encoding-alist)))
1669                   (mail-encode-encoded-word-buffer)))
1670               (goto-char (point-min))
1671               (when (re-search-forward
1672                      (concat "^" (regexp-quote mail-header-separator) "$")
1673                      nil t)
1674                 (replace-match "" t t ))
1675               (when (or (not (gnus-check-backend-function
1676                               'request-accept-article group))
1677                         (not (setq group-art
1678                                    (gnus-request-accept-article
1679                                     group method t t))))
1680                 (gnus-message 1 "Couldn't store article in group %s: %s"
1681                               group (gnus-status-message method)))
1682               (when (and group-art
1683                          ;; FIXME: Should gcc-mark-as-read work when
1684                          ;; Gnus is not running?
1685                          (gnus-alive-p)
1686                          (or gnus-gcc-mark-as-read
1687                              (and
1688                               (boundp 'gnus-inews-mark-gcc-as-read)
1689                               (symbol-value 'gnus-inews-mark-gcc-as-read))))
1690                 (gnus-group-mark-article-read group (cdr group-art)))
1691               (kill-buffer (current-buffer)))))))))
1692
1693 (defun gnus-inews-insert-gcc ()
1694   "Insert Gcc headers based on `gnus-outgoing-message-group'."
1695   (save-excursion
1696     (save-restriction
1697       (message-narrow-to-headers)
1698       (let* ((group gnus-outgoing-message-group)
1699              (gcc (cond
1700                    ((functionp group)
1701                     (funcall group))
1702                    ((or (stringp group) (listp group))
1703                     group))))
1704         (when gcc
1705           (insert "Gcc: "
1706                   (if (stringp gcc)
1707                       (if (string-match " " gcc)
1708                           (concat "\"" gcc "\"")
1709                         gcc)
1710                     (mapconcat (lambda (group)
1711                                  (if (string-match " " group)
1712                                      (concat "\"" group "\"")
1713                                    group))
1714                                gcc " "))
1715                   "\n"))))))
1716
1717 (defun gnus-inews-insert-archive-gcc (&optional group)
1718   "Insert the Gcc to say where the article is to be archived."
1719   (setq group (cond (group
1720                      (gnus-group-decoded-name group))
1721                     (gnus-newsgroup-name
1722                      (gnus-group-decoded-name gnus-newsgroup-name))
1723                     (t
1724                      "")))
1725   (let* ((var gnus-message-archive-group)
1726          (gcc-self-val
1727           (and gnus-newsgroup-name
1728                (not (equal gnus-newsgroup-name ""))
1729                (gnus-group-find-parameter
1730                 gnus-newsgroup-name 'gcc-self)))
1731          result
1732          (groups
1733           (cond
1734            ((null gnus-message-archive-method)
1735             ;; Ignore.
1736             nil)
1737            ((stringp var)
1738             ;; Just a single group.
1739             (list var))
1740            ((null var)
1741             ;; We don't want this.
1742             nil)
1743            ((and (listp var) (stringp (car var)))
1744             ;; A list of groups.
1745             var)
1746            ((functionp var)
1747             ;; A function.
1748             (funcall var group))
1749            (t
1750             ;; An alist of regexps/functions/forms.
1751             (while (and var
1752                         (not
1753                          (setq result
1754                                (cond
1755                                 ((stringp (caar var))
1756                                  ;; Regexp.
1757                                  (when (string-match (caar var) group)
1758                                    (cdar var)))
1759                                 ((functionp (car var))
1760                                  ;; Function.
1761                                  (funcall (car var) group))
1762                                 (t
1763                                  (eval (car var)))))))
1764               (setq var (cdr var)))
1765             result)))
1766          name)
1767     (when (or groups gcc-self-val)
1768       (when (stringp groups)
1769         (setq groups (list groups)))
1770       (save-excursion
1771         (save-restriction
1772           (message-narrow-to-headers)
1773           (goto-char (point-max))
1774           (insert "Gcc: ")
1775           (if gcc-self-val
1776               ;; Use the `gcc-self' param value instead.
1777               (progn
1778                 (insert
1779                  (if (stringp gcc-self-val)
1780                      (if (string-match " " gcc-self-val)
1781                          (concat "\"" gcc-self-val "\"")
1782                        gcc-self-val)
1783                    ;; In nndoc groups, we use the parent group name
1784                    ;; instead of the current group.
1785                    (let ((group (or (gnus-group-find-parameter
1786                                      gnus-newsgroup-name 'parent-group)
1787                                     group)))
1788                      (if (string-match " " group)
1789                          (concat "\"" group "\"")
1790                        group))))
1791                 (if (not (eq gcc-self-val 'none))
1792                     (insert "\n")
1793                   (gnus-delete-line)))
1794             ;; Use the list of groups.
1795             (while (setq name (pop groups))
1796               (let ((str (if (string-match ":" name)
1797                              name
1798                            (gnus-group-prefixed-name
1799                             name gnus-message-archive-method))))
1800                 (insert (if (string-match " " str)
1801                             (concat "\"" str "\"")
1802                           str)))
1803               (when groups
1804                 (insert " ")))
1805             (insert "\n")))))))
1806
1807 (defun gnus-mailing-list-followup-to ()
1808   "Look at the headers in the current buffer and return a Mail-Followup-To address."
1809   (let ((x-been-there (gnus-fetch-original-field "x-beenthere"))
1810         (list-post (gnus-fetch-original-field "list-post")))
1811     (when (and list-post
1812                (string-match "mailto:\\([^>]+\\)" list-post))
1813       (setq list-post (match-string 1 list-post)))
1814     (or list-post
1815         x-been-there)))
1816
1817 ;;; Posting styles.
1818
1819 (defun gnus-configure-posting-styles (&optional group-name)
1820   "Configure posting styles according to `gnus-posting-styles'."
1821   (unless gnus-inhibit-posting-styles
1822     (let ((group (or group-name gnus-newsgroup-name ""))
1823           (styles gnus-posting-styles)
1824           style match attribute value v results
1825           filep name address element)
1826       ;; If the group has a posting-style parameter, add it at the end with a
1827       ;; regexp matching everything, to be sure it takes precedence over all
1828       ;; the others.
1829       (when gnus-newsgroup-name
1830         (let ((tmp-style (gnus-group-find-parameter group 'posting-style t)))
1831           (when tmp-style
1832             (setq styles (append styles (list (cons ".*" tmp-style)))))))
1833       ;; Go through all styles and look for matches.
1834       (dolist (style styles)
1835         (setq match (pop style))
1836         (goto-char (point-min))
1837         (when (cond
1838                ((stringp match)
1839                 ;; Regexp string match on the group name.
1840                 (string-match match group))
1841                ((eq match 'header)
1842                 ;; Obsolete format of header match.
1843                 (and (gnus-buffer-live-p gnus-article-copy)
1844                      (with-current-buffer gnus-article-copy
1845                        (save-restriction
1846                          (nnheader-narrow-to-headers)
1847                          (let ((header (message-fetch-field (pop style))))
1848                            (and header
1849                                 (string-match (pop style) header)))))))
1850                ((or (symbolp match)
1851                     (functionp match))
1852                 (cond
1853                  ((functionp match)
1854                   ;; Function to be called.
1855                   (funcall match))
1856                  ((boundp match)
1857                   ;; Variable to be checked.
1858                   (symbol-value match))))
1859                ((listp match)
1860                 (cond
1861                  ((eq (car match) 'header)
1862                   ;; New format of header match.
1863                   (and (gnus-buffer-live-p gnus-article-copy)
1864                        (with-current-buffer gnus-article-copy
1865                          (save-restriction
1866                            (nnheader-narrow-to-headers)
1867                            (let ((header (message-fetch-field (nth 1 match))))
1868                              (and header
1869                                   (string-match (nth 2 match) header)))))))
1870                  (t
1871                   ;; This is a form to be evaled.
1872                   (eval match)))))
1873           ;; We have a match, so we set the variables.
1874           (dolist (attribute style)
1875             (setq element (pop attribute)
1876                   filep nil)
1877             (setq value
1878                   (cond
1879                    ((eq (car attribute) :file)
1880                     (setq filep t)
1881                     (cadr attribute))
1882                    ((eq (car attribute) :value)
1883                     (cadr attribute))
1884                    (t
1885                     (car attribute))))
1886             ;; We get the value.
1887             (setq v
1888                   (cond
1889                    ((stringp value)
1890                     value)
1891                    ((or (symbolp value)
1892                         (functionp value))
1893                     (cond ((functionp value)
1894                            (funcall value))
1895                           ((boundp value)
1896                            (symbol-value value))))
1897                    ((listp value)
1898                     (eval value))))
1899             ;; Translate obsolescent value.
1900             (cond
1901              ((eq element 'signature-file)
1902               (setq element 'signature
1903                     filep t))
1904              ((eq element 'x-face-file)
1905               (setq element 'x-face
1906                     filep t)))
1907             ;; Post-processing for the signature posting-style:
1908             (and (eq element 'signature) filep
1909                  message-signature-directory
1910                  ;; don't actually use the signature directory
1911                  ;; if message-signature-file contains a path.
1912                  (not (file-name-directory v))
1913                  (setq v (nnheader-concat message-signature-directory v)))
1914             ;; Get the contents of file elems.
1915             (when (and filep v)
1916               (setq v (with-temp-buffer
1917                         (insert-file-contents v)
1918                         (buffer-substring
1919                          (point-min)
1920                          (progn
1921                            (goto-char (point-max))
1922                            (if (zerop (skip-chars-backward "\n"))
1923                                (point)
1924                              (1+ (point))))))))
1925             (setq results (delq (assoc element results) results))
1926             (push (cons element v) results))))
1927       ;; Now we have all the styles, so we insert them.
1928       (setq name (assq 'name results)
1929             address (assq 'address results))
1930       (setq results (delq name (delq address results)))
1931       (gnus-make-local-hook 'message-setup-hook)
1932       (setq results (sort results (lambda (x y)
1933                                     (string-lessp (car x) (car y)))))
1934       (dolist (result results)
1935         (add-hook 'message-setup-hook
1936                   (cond
1937                    ((eq 'eval (car result))
1938                     'ignore)
1939                    ((eq 'body (car result))
1940                     `(lambda ()
1941                        (save-excursion
1942                          (message-goto-body)
1943                          (insert ,(cdr result)))))
1944                    ((eq 'signature (car result))
1945                     (set (make-local-variable 'message-signature) nil)
1946                     (set (make-local-variable 'message-signature-file) nil)
1947                     (if (not (cdr result))
1948                         'ignore
1949                       `(lambda ()
1950                          (save-excursion
1951                            (let ((message-signature ,(cdr result)))
1952                              (when message-signature
1953                                (message-insert-signature)))))))
1954                    (t
1955                     (let ((header
1956                            (if (symbolp (car result))
1957                                (capitalize (symbol-name (car result)))
1958                              (car result))))
1959                       `(lambda ()
1960                          (save-excursion
1961                            (message-remove-header ,header)
1962                            (let ((value ,(cdr result)))
1963                              (when value
1964                                (message-goto-eoh)
1965                                (insert ,header ": " value)
1966                                (unless (bolp)
1967                                  (insert "\n")))))))))
1968                   nil 'local))
1969       (when (or name address)
1970         (add-hook 'message-setup-hook
1971                   `(lambda ()
1972                      (set (make-local-variable 'user-mail-address)
1973                           ,(or (cdr address) user-mail-address))
1974                      (let ((user-full-name ,(or (cdr name) (user-full-name)))
1975                            (user-mail-address
1976                             ,(or (cdr address) user-mail-address)))
1977                        (save-excursion
1978                          (message-remove-header "From")
1979                          (message-goto-eoh)
1980                          (insert "From: " (message-make-from) "\n"))))
1981                   nil 'local)))))
1982
1983 ;;; Allow redefinition of functions.
1984
1985 (gnus-ems-redefine)
1986
1987 (provide 'gnus-msg)
1988
1989 ;; arch-tag: 9f22b2f5-1c0a-49de-916e-4c88e984852b
1990 ;;; gnus-msg.el ends here