/[emacs]/emacs/lisp/gnus/gnus-msg.el
ViewVC logotype

Diff of /emacs/lisp/gnus/gnus-msg.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.19 by miles, Mon Sep 1 15:45:24 2003 UTC revision 1.19.2.1 by schwab, Thu Jul 22 16:45:47 2004 UTC
# Line 1  Line 1 
1  ;;; gnus-msg.el --- mail and post interface for Gnus  ;;; gnus-msg.el --- mail and post interface for Gnus
2  ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000  ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
3  ;;        Free Software Foundation, Inc.  ;;        Free Software Foundation, Inc.
4    
5  ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>  ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
# Line 33  Line 33 
33  (require 'gnus-ems)  (require 'gnus-ems)
34  (require 'message)  (require 'message)
35  (require 'gnus-art)  (require 'gnus-art)
36    (require 'gnus-util)
37    
38  (defcustom gnus-post-method 'current  (defcustom gnus-post-method 'current
39    "*Preferred method for posting USENET news.    "*Preferred method for posting USENET news.
# Line 54  method to use when posting." Line 55  method to use when posting."
55                   (const current)                   (const current)
56                   (sexp :tag "Methods" ,gnus-select-method)))                   (sexp :tag "Methods" ,gnus-select-method)))
57    
58  (defvar gnus-outgoing-message-group nil  (defcustom gnus-outgoing-message-group nil
59    "*All outgoing messages will be put in this group.    "*All outgoing messages will be put in this group.
60  If you want to store all your outgoing mail and articles in the group  If you want to store all your outgoing mail and articles in the group
61  \"nnml:archive\", you set this variable to that value.  This variable  \"nnml:archive\", you set this variable to that value.  This variable
# Line 63  can also be a list of group names. Line 64  can also be a list of group names.
64  If you want to have greater control over what group to put each  If you want to have greater control over what group to put each
65  message in, you can set this variable to a function that checks the  message in, you can set this variable to a function that checks the
66  current newsgroup name and then returns a suitable group name (or list  current newsgroup name and then returns a suitable group name (or list
67  of names).")  of names)."
68      :group 'gnus-message
69      :type '(choice (string :tag "Group")
70                     (function)))
71    
72  (defvar gnus-mailing-list-groups nil  (defcustom gnus-mailing-list-groups nil
73    "*Regexp matching groups that are really mailing lists.    "*If non-nil a regexp matching groups that are really mailing lists.
74  This is useful when you're reading a mailing list that has been  This is useful when you're reading a mailing list that has been
75  gatewayed to a newsgroup, and you want to followup to an article in  gatewayed to a newsgroup, and you want to followup to an article in
76  the group.")  the group."
77      :group 'gnus-message
78      :type '(choice (regexp)
79                     (const nil)))
80    
81    (defcustom gnus-add-to-list nil
82      "*If non-nil, add a `to-list' parameter automatically."
83      :group 'gnus-message
84      :type 'boolean)
85    
86  (defvar gnus-add-to-list nil  (defcustom gnus-crosspost-complaint
   "*If non-nil, add a `to-list' parameter automatically.")  
   
 (defvar gnus-crosspost-complaint  
87    "Hi,    "Hi,
88    
89  You posted the article below with the following Newsgroups header:  You posted the article below with the following Newsgroups header:
# Line 90  Thank you. Line 99  Thank you.
99  "  "
100    "Format string to be inserted when complaining about crossposts.    "Format string to be inserted when complaining about crossposts.
101  The first %s will be replaced by the Newsgroups header;  The first %s will be replaced by the Newsgroups header;
102  the second with the current group name.")  the second with the current group name."
103      :group 'gnus-message
104  (defvar gnus-message-setup-hook nil    :type 'string)
105    "Hook run after setting up a message buffer.")  
106    (defcustom gnus-message-setup-hook nil
107  (defvar gnus-bug-create-help-buffer t    "Hook run after setting up a message buffer."
108    "*Should we create the *Gnus Help Bug* buffer?")    :group 'gnus-message
109      :type 'hook)
110  (defvar gnus-posting-styles nil  
111    "*Alist of styles to use when posting.")  (defcustom gnus-bug-create-help-buffer t
112      "*Should we create the *Gnus Help Bug* buffer?"
113  (defcustom gnus-group-posting-charset-alist    :group 'gnus-message
114      :type 'boolean)
115    
116    (defcustom gnus-posting-styles nil
117      "*Alist of styles to use when posting.
118    See Info node `(gnus)Posting Styles'."
119      :group 'gnus-message
120      :link '(custom-manual "(gnus)Posting Styles")
121      :type '(repeat (cons (choice (regexp)
122                                   (variable)
123                                   (list (const header)
124                                         (string :tag "Header")
125                                         (regexp :tag "Regexp"))
126                                   (function)
127                                   (sexp))
128                           (repeat (list
129                                    (choice (const signature)
130                                            (const signature-file)
131                                            (const organization)
132                                            (const address)
133                                            (const x-face-file)
134                                            (const name)
135                                            (const body)
136                                            (symbol)
137                                            (string :tag "Header"))
138                                    (choice (string)
139                                            (function)
140                                            (variable)
141                                            (sexp)))))))
142    
143    (defcustom gnus-gcc-mark-as-read nil
144      "If non-nil, automatically mark Gcc articles as read."
145      :version "21.1"
146      :group 'gnus-message
147      :type 'boolean)
148    
149    (make-obsolete-variable 'gnus-inews-mark-gcc-as-read
150                            'gnus-gcc-mark-as-read)
151    
152    (defcustom gnus-gcc-externalize-attachments nil
153      "Should local-file attachments be included as external parts in Gcc copies?
154    If it is `all', attach files as external parts;
155    if a regexp and matches the Gcc group name, attach files as external parts;
156    if nil, attach files as normal parts."
157      :version "21.1"
158      :group 'gnus-message
159      :type '(choice (const nil :tag "None")
160                     (const all :tag "Any")
161                     (string :tag "Regexp")))
162    
163    (gnus-define-group-parameter
164     posting-charset-alist
165     :type list
166     :function-document
167     "Return the permitted unencoded charsets for posting of GROUP."
168     :variable gnus-group-posting-charset-alist
169     :variable-default
170    '(("^\\(no\\|fr\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1))    '(("^\\(no\\|fr\\)\\.[^,]*\\(,[ \t\n]*\\(no\\|fr\\)\\.[^,]*\\)*$" iso-8859-1 (iso-8859-1))
171      ("^\\(fido7\\|relcom\\)\\.[^,]*\\(,[ \t\n]*\\(fido7\\|relcom\\)\\.[^,]*\\)*$" koi8-r (koi8-r))      ("^\\(fido7\\|relcom\\)\\.[^,]*\\(,[ \t\n]*\\(fido7\\|relcom\\)\\.[^,]*\\)*$" koi8-r (koi8-r))
172      (message-this-is-mail nil nil)      (message-this-is-mail nil nil)
173      (message-this-is-news nil t))      (message-this-is-news nil t))
174     :variable-document
175    "Alist of regexps and permitted unencoded charsets for posting.    "Alist of regexps and permitted unencoded charsets for posting.
176  Each element of the alist has the form (TEST HEADER BODY-LIST), where  Each element of the alist has the form (TEST HEADER BODY-LIST), where
177  TEST is either a regular expression matching the newsgroup header or a  TEST is either a regular expression matching the newsgroup header or a
# Line 118  nil (always encode using quoted-printabl Line 184  nil (always encode using quoted-printabl
184    
185  Note that any value other than nil for HEADER infringes some RFCs, so  Note that any value other than nil for HEADER infringes some RFCs, so
186  use this option with care."  use this option with care."
187    :type '(repeat (list :tag "Permitted unencoded charsets"   :variable-group gnus-charset
188                    (choice :tag "Where"   :variable-type
189                     (regexp :tag "Group")   '(repeat (list :tag "Permitted unencoded charsets"
190                     (const :tag "Mail message" :value message-this-is-mail)                  (choice :tag "Where"
191                     (const :tag "News article" :value message-this-is-news))                          (regexp :tag "Group")
192                    (choice :tag "Header"                          (const :tag "Mail message" :value message-this-is-mail)
193                     (const :tag "None" nil)                          (const :tag "News article" :value message-this-is-news))
194                     (symbol :tag "Charset"))                  (choice :tag "Header"
195                    (choice :tag "Body"                          (const :tag "None" nil)
196                            (const :tag "Any" :value t)                          (symbol :tag "Charset"))
197                            (const :tag "None" :value nil)                  (choice :tag "Body"
198                            (repeat :tag "Charsets"                          (const :tag "Any" :value t)
199                                    (symbol :tag "Charset")))))                          (const :tag "None" :value nil)
200    :group 'gnus-charset)                          (repeat :tag "Charsets"
201                                    (symbol :tag "Charset")))))
202     :parameter-type '(choice :tag "Permitted unencoded charsets"
203                              :value nil
204                              (repeat (symbol)))
205     :parameter-document       "\
206    List of charsets that are permitted to be unencoded.")
207    
208    (defcustom gnus-debug-files
209      '("gnus.el" "gnus-sum.el" "gnus-group.el"
210        "gnus-art.el" "gnus-start.el" "gnus-async.el"
211        "gnus-msg.el" "gnus-score.el" "gnus-win.el" "gnus-topic.el"
212        "gnus-agent.el" "gnus-cache.el" "gnus-srvr.el"
213        "mm-util.el" "mm-decode.el" "nnmail.el" "message.el")
214      "Files whose variables will be reported in `gnus-bug'."
215      :version "21.1"
216      :group 'gnus-message
217      :type '(repeat (string :tag "File")))
218    
219    (defcustom gnus-debug-exclude-variables
220      '(mm-mime-mule-charset-alist
221        nnmail-split-fancy message-minibuffer-local-map)
222      "Variables that should not be reported in `gnus-bug'."
223      :version "21.1"
224      :group 'gnus-message
225      :type '(repeat (symbol :tag "Variable")))
226    
227    (defcustom gnus-discouraged-post-methods
228      '(nndraft nnml nnimap nnmaildir nnmh nnfolder nndir)
229      "A list of back ends that are not used in \"real\" newsgroups.
230    This variable is used only when `gnus-post-method' is `current'."
231      :version "21.3"
232      :group 'gnus-group-foreign
233      :type '(repeat (symbol :tag "Back end")))
234    
235    (defcustom gnus-message-replysign
236      nil
237      "Automatically sign replies to signed messages.
238    See also the `mml-default-sign-method' variable."
239      :group 'gnus-message
240      :type 'boolean)
241    
242    (defcustom gnus-message-replyencrypt
243      nil
244      "Automatically encrypt replies to encrypted messages.
245    See also the `mml-default-encrypt-method' variable."
246      :group 'gnus-message
247      :type 'boolean)
248    
249    (defcustom gnus-message-replysignencrypted
250      t
251      "Setting this causes automatically encrypted messages to also be signed."
252      :group 'gnus-message
253      :type 'boolean)
254    
255    (defcustom gnus-confirm-mail-reply-to-news nil
256      "If non-nil, Gnus requests confirmation when replying to news.
257    This is done because new users often reply by mistake when reading
258    news.
259    This can also be a function receiving the group name as the only
260    parameter which should return non-nil iff a confirmation is needed, or
261    a regexp, in which case a confirmation is asked for iff the group name
262    matches the regexp."
263      :group 'gnus-message
264      :type '(choice (const :tag "No" nil)
265                     (const :tag "Yes" t)
266                     (regexp :tag "Iff group matches regexp")
267                     (function :tag "Iff function evaluates to non-nil")))
268    
269    (defcustom gnus-confirm-treat-mail-like-news
270      nil
271      "If non-nil, Gnus will treat mail like news with regard to confirmation
272    when replying by mail.  See the `gnus-confirm-mail-reply-to-news' variable
273    for fine-tuning this.
274    If nil, Gnus will never ask for confirmation if replying to mail."
275      :group 'gnus-message
276      :type 'boolean)
277    
278    (defcustom gnus-summary-resend-default-address t
279      "If non-nil, Gnus tries to suggest a default address to resend to.
280    If nil, the address field will always be empty after invoking
281    `gnus-summary-resend-message'."
282      :group 'gnus-message
283      :type 'boolean)
284    
285  ;;; Internal variables.  ;;; Internal variables.
286    
287  (defvar gnus-inhibit-posting-styles nil  (defvar gnus-inhibit-posting-styles nil
288    "Inhibit the use of posting styles.")    "Inhibit the use of posting styles.")
289    
290    (defvar gnus-article-yanked-articles nil)
291  (defvar gnus-message-buffer "*Mail Gnus*")  (defvar gnus-message-buffer "*Mail Gnus*")
292  (defvar gnus-article-copy nil)  (defvar gnus-article-copy nil)
293    (defvar gnus-check-before-posting nil)
294  (defvar gnus-last-posting-server nil)  (defvar gnus-last-posting-server nil)
295  (defvar gnus-message-group-art nil)  (defvar gnus-message-group-art nil)
296    
297    (defvar gnus-msg-force-broken-reply-to nil)
298    
299  (defconst gnus-bug-message  (defconst gnus-bug-message
300    "Sending a bug report to the Gnus Towers.    "Sending a bug report to the Gnus Towers.
301  ========================================  ========================================
# Line 166  Thank you for your help in stamping out Line 319  Thank you for your help in stamping out
319    
320  (eval-and-compile  (eval-and-compile
321    (autoload 'gnus-uu-post-news "gnus-uu" nil t)    (autoload 'gnus-uu-post-news "gnus-uu" nil t)
322      (autoload 'news-setup "rnewspost")
323      (autoload 'news-reply-mode "rnewspost")
324    (autoload 'rmail-dont-reply-to "mail-utils")    (autoload 'rmail-dont-reply-to "mail-utils")
325    (autoload 'rmail-output "rmailout"))    (autoload 'rmail-output "rmailout"))
326    
# Line 176  Thank you for your help in stamping out Line 331  Thank you for your help in stamping out
331    
332  (gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map)  (gnus-define-keys (gnus-summary-send-map "S" gnus-summary-mode-map)
333    "p" gnus-summary-post-news    "p" gnus-summary-post-news
334      "i" gnus-summary-news-other-window
335    "f" gnus-summary-followup    "f" gnus-summary-followup
336    "F" gnus-summary-followup-with-original    "F" gnus-summary-followup-with-original
337    "c" gnus-summary-cancel-article    "c" gnus-summary-cancel-article
# Line 185  Thank you for your help in stamping out Line 341  Thank you for your help in stamping out
341    "R" gnus-summary-reply-with-original    "R" gnus-summary-reply-with-original
342    "w" gnus-summary-wide-reply    "w" gnus-summary-wide-reply
343    "W" gnus-summary-wide-reply-with-original    "W" gnus-summary-wide-reply-with-original
344      "v" gnus-summary-very-wide-reply
345      "V" gnus-summary-very-wide-reply-with-original
346    "n" gnus-summary-followup-to-mail    "n" gnus-summary-followup-to-mail
347    "N" gnus-summary-followup-to-mail-with-original    "N" gnus-summary-followup-to-mail-with-original
348    "m" gnus-summary-mail-other-window    "m" gnus-summary-mail-other-window
349    "u" gnus-uu-post-news    "u" gnus-uu-post-news
350    "\M-c" gnus-summary-mail-crosspost-complaint    "\M-c" gnus-summary-mail-crosspost-complaint
351      "Br" gnus-summary-reply-broken-reply-to
352      "BR" gnus-summary-reply-broken-reply-to-with-original
353    "om" gnus-summary-mail-forward    "om" gnus-summary-mail-forward
354    "op" gnus-summary-post-forward    "op" gnus-summary-post-forward
355    "Om" gnus-uu-digest-mail-forward    "Om" gnus-uu-digest-mail-forward
# Line 198  Thank you for your help in stamping out Line 358  Thank you for your help in stamping out
358  (gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map)  (gnus-define-keys (gnus-send-bounce-map "D" gnus-summary-send-map)
359    "b" gnus-summary-resend-bounced-mail    "b" gnus-summary-resend-bounced-mail
360    ;; "c" gnus-summary-send-draft    ;; "c" gnus-summary-send-draft
361    "r" gnus-summary-resend-message)    "r" gnus-summary-resend-message
362      "e" gnus-summary-resend-message-edit)
363    
364  ;;; Internal functions.  ;;; Internal functions.
365    
366    (defun gnus-inews-make-draft ()
367      `(lambda ()
368         (gnus-inews-make-draft-meta-information
369          ,gnus-newsgroup-name ',gnus-article-reply)))
370    
371  (defvar gnus-article-reply nil)  (defvar gnus-article-reply nil)
372  (defmacro gnus-setup-message (config &rest forms)  (defmacro gnus-setup-message (config &rest forms)
373    (let ((winconf (make-symbol "gnus-setup-message-winconf"))    (let ((winconf (make-symbol "gnus-setup-message-winconf"))
374          (buffer (make-symbol "gnus-setup-message-buffer"))          (buffer (make-symbol "gnus-setup-message-buffer"))
375          (article (make-symbol "gnus-setup-message-article"))          (article (make-symbol "gnus-setup-message-article"))
376            (yanked (make-symbol "gnus-setup-yanked-articles"))
377          (group (make-symbol "gnus-setup-message-group")))          (group (make-symbol "gnus-setup-message-group")))
378      `(let ((,winconf (current-window-configuration))      `(let ((,winconf (current-window-configuration))
379             (,buffer (buffer-name (current-buffer)))             (,buffer (buffer-name (current-buffer)))
380             (,article (and gnus-article-reply (gnus-summary-article-number)))             (,article gnus-article-reply)
381               (,yanked gnus-article-yanked-articles)
382             (,group gnus-newsgroup-name)             (,group gnus-newsgroup-name)
383             (message-header-setup-hook             (message-header-setup-hook
384              (copy-sequence message-header-setup-hook))              (copy-sequence message-header-setup-hook))
# Line 219  Thank you for your help in stamping out Line 387  Thank you for your help in stamping out
387         (setq mml-buffer-list nil)         (setq mml-buffer-list nil)
388         (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)         (add-hook 'message-header-setup-hook 'gnus-inews-insert-gcc)
389         (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)         (add-hook 'message-header-setup-hook 'gnus-inews-insert-archive-gcc)
390         (add-hook 'message-mode-hook 'gnus-configure-posting-styles)         ;; #### FIXME: for a reason that I did not manage to identify yet,
391           ;; the variable `gnus-newsgroup-name' does not honor a dynamically
392           ;; scoped or setq'ed value from a caller like `C-u gnus-summary-mail'.
393           ;; After evaluation of @forms below, it gets the value we actually want
394           ;; to override, and the posting styles are used. For that reason, I've
395           ;; added an optional argument to `gnus-configure-posting-styles' to
396           ;; make sure that the correct value for the group name is used. -- drv
397           (add-hook 'message-mode-hook
398                     (lambda ()
399                       (gnus-configure-posting-styles ,group)))
400           (gnus-pull ',(intern gnus-draft-meta-information-header)
401                      message-required-headers)
402           (when (and ,group
403                      (not (string= ,group "")))
404             (push (cons
405                    (intern gnus-draft-meta-information-header)
406                    (gnus-inews-make-draft))
407                   message-required-headers))
408         (unwind-protect         (unwind-protect
409             (progn             (progn
410               ,@forms)               ,@forms)
411           (gnus-inews-add-send-actions ,winconf ,buffer ,article)           (gnus-inews-add-send-actions ,winconf ,buffer ,article ,config
412                                          ,yanked)
413           (setq gnus-message-buffer (current-buffer))           (setq gnus-message-buffer (current-buffer))
414           (set (make-local-variable 'gnus-message-group-art)           (set (make-local-variable 'gnus-message-group-art)
415                (cons ,group ,article))                (cons ,group ,article))
# Line 233  Thank you for your help in stamping out Line 419  Thank you for your help in stamping out
419               (let ((mbl1 mml-buffer-list))               (let ((mbl1 mml-buffer-list))
420                 (setq mml-buffer-list mbl)  ;; Global value                 (setq mml-buffer-list mbl)  ;; Global value
421                 (set (make-local-variable 'mml-buffer-list) mbl1);; Local value                 (set (make-local-variable 'mml-buffer-list) mbl1);; Local value
422                   (gnus-make-local-hook 'kill-buffer-hook)
423                   (gnus-make-local-hook 'change-major-mode-hook)
424                 (add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t)                 (add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t)
425                 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))                 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))
426             (mml-destroy-buffers)             (mml-destroy-buffers)
427             (setq mml-buffer-list mbl)))             (setq mml-buffer-list mbl)))
428           (message-hide-headers)
429         (gnus-add-buffer)         (gnus-add-buffer)
430         (gnus-configure-windows ,config t)         (gnus-configure-windows ,config t)
431           (run-hooks 'post-command-hook)
432         (set-buffer-modified-p nil))))         (set-buffer-modified-p nil))))
433    
434    (defun gnus-inews-make-draft-meta-information (group article)
435      (concat "(\"" group "\" "
436              (if article (number-to-string
437                           (if (listp article)
438                               (car article)
439                             article)) "\"\"")
440              ")"))
441    
442  ;;;###autoload  ;;;###autoload
443  (defun gnus-msg-mail (&rest args)  (defun gnus-msg-mail (&optional to subject other-headers continue
444                                    switch-action yank-action send-actions)
445    "Start editing a mail message to be sent.    "Start editing a mail message to be sent.
446  Like `message-mail', but with Gnus paraphernalia, particularly the  Like `message-mail', but with Gnus paraphernalia, particularly the
447  Gcc: header for archiving purposes."  Gcc: header for archiving purposes."
448    (interactive)    (interactive)
449    (gnus-setup-message 'message    (let ((buf (current-buffer))
450      (apply 'message-mail args))          mail-buf)
451        (gnus-setup-message 'message
452          (message-mail to subject other-headers continue
453                        nil yank-action send-actions))
454        (when switch-action
455          (setq mail-buf (current-buffer))
456          (switch-to-buffer buf)
457          (apply switch-action mail-buf nil)))
458    ;; COMPOSEFUNC should return t if succeed.  Undocumented ???    ;; COMPOSEFUNC should return t if succeed.  Undocumented ???
459    t)    t)
460    
461    (defvar save-selected-window-window)
462    
463    ;;;###autoload
464    (defun gnus-button-mailto (address)
465      "Mail to ADDRESS."
466      (set-buffer (gnus-copy-article-buffer))
467      (gnus-setup-message 'message
468        (message-reply address))
469      (and (boundp 'save-selected-window-window)
470           (not (window-live-p save-selected-window-window))
471           (setq save-selected-window-window (selected-window))))
472    
473    ;;;###autoload
474    (defun gnus-button-reply (&optional to-address wide)
475      "Like `message-reply'."
476      (interactive)
477      (gnus-setup-message 'message
478        (message-reply to-address wide))
479      (and (boundp 'save-selected-window-window)
480           (not (window-live-p save-selected-window-window))
481           (setq save-selected-window-window (selected-window))))
482    
483  ;;;###autoload  ;;;###autoload
484  (define-mail-user-agent 'gnus-user-agent  (define-mail-user-agent 'gnus-user-agent
485        'gnus-msg-mail 'message-send-and-exit    'gnus-msg-mail 'message-send-and-exit
486        'message-kill-buffer 'message-send-hook)    'message-kill-buffer 'message-send-hook)
487    
488  (defun gnus-setup-posting-charset (group)  (defun gnus-setup-posting-charset (group)
489    (let ((alist gnus-group-posting-charset-alist)    (let ((alist gnus-group-posting-charset-alist)
# Line 266  Gcc: header for archiving purposes." Line 494  Gcc: header for archiving purposes."
494          (while (setq elem (pop alist))          (while (setq elem (pop alist))
495            (when (or (and (stringp (car elem))            (when (or (and (stringp (car elem))
496                           (string-match (car elem) group))                           (string-match (car elem) group))
497                      (and (gnus-functionp (car elem))                      (and (functionp (car elem))
498                           (funcall (car elem) group))                           (funcall (car elem) group))
499                      (and (symbolp (car elem))                      (and (symbolp (car elem))
500                           (symbol-value (car elem))))                           (symbol-value (car elem))))
501              (throw 'found (cons (cadr elem) (caddr elem)))))))))              (throw 'found (cons (cadr elem) (caddr elem)))))))))
502    
503  (defun gnus-inews-add-send-actions (winconf buffer article)  (defun gnus-inews-add-send-actions (winconf buffer article
504    (make-local-hook 'message-sent-hook)                                              &optional config yanked)
505      (gnus-make-local-hook 'message-sent-hook)
506    (add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc    (add-hook 'message-sent-hook (if gnus-agent 'gnus-agent-possibly-do-gcc
507                                   'gnus-inews-do-gcc) nil t)                                   'gnus-inews-do-gcc) nil t)
508    (when gnus-agent    (when gnus-agent
509      (make-local-hook 'message-header-hook)      (gnus-make-local-hook 'message-header-hook)
510      (add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t))      (add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t))
511    (setq message-post-method    (setq message-post-method
512          `(lambda (arg)          `(lambda (arg)
513             (gnus-post-method arg ,gnus-newsgroup-name)))             (gnus-post-method arg ,gnus-newsgroup-name)))
514    (setq message-newsreader (setq message-mailer (gnus-extended-version)))    (setq message-newsreader (setq message-mailer (gnus-extended-version)))
515    (message-add-action    (message-add-action
    `(set-window-configuration ,winconf) 'exit 'postpone 'kill)  
   (message-add-action  
516     `(when (gnus-buffer-exists-p ,buffer)     `(when (gnus-buffer-exists-p ,buffer)
517        (save-excursion        (set-window-configuration ,winconf))
518          (set-buffer ,buffer)     'exit 'postpone 'kill)
519          ,(when article    (let ((to-be-marked (cond
520             `(gnus-summary-mark-article-as-replied ,article))))                         (yanked
521     'send))                          (mapcar
522                             (lambda (x) (if (listp x) (car x) x)) yanked))
523                           (article (if (listp article) article (list article)))
524                           (t nil))))
525        (message-add-action
526         `(when (gnus-buffer-exists-p ,buffer)
527            (save-excursion
528              (set-buffer ,buffer)
529              ,(when to-be-marked
530                 (if (eq config 'forward)
531                     `(gnus-summary-mark-article-as-forwarded ',to-be-marked)
532                   `(gnus-summary-mark-article-as-replied ',to-be-marked)))))
533         'send)))
534    
535  (put 'gnus-setup-message 'lisp-indent-function 1)  (put 'gnus-setup-message 'lisp-indent-function 1)
536  (put 'gnus-setup-message 'edebug-form-spec '(form body))  (put 'gnus-setup-message 'edebug-form-spec '(form body))
# Line 306  If ARG is 1, prompt for a group name to Line 545  If ARG is 1, prompt for a group name to
545    ;; We can't `let' gnus-newsgroup-name here, since that leads    ;; We can't `let' gnus-newsgroup-name here, since that leads
546    ;; to local variables leaking.    ;; to local variables leaking.
547    (let ((group gnus-newsgroup-name)    (let ((group gnus-newsgroup-name)
548            ;; make sure last viewed article doesn't affect posting styles:
549            (gnus-article-copy)
550          (buffer (current-buffer)))          (buffer (current-buffer)))
551      (unwind-protect      (unwind-protect
552          (progn          (progn
# Line 317  If ARG is 1, prompt for a group name to Line 558  If ARG is 1, prompt for a group name to
558                                           (gnus-read-active-file-p))                                           (gnus-read-active-file-p))
559                        (gnus-group-group-name))                        (gnus-group-group-name))
560                    ""))                    ""))
561              ;; #### see comment in gnus-setup-message -- drv
562            (gnus-setup-message 'message (message-mail)))            (gnus-setup-message 'message (message-mail)))
563        (save-excursion        (save-excursion
564          (set-buffer buffer)          (set-buffer buffer)
565          (setq gnus-newsgroup-name group)))))          (setq gnus-newsgroup-name group)))))
566    
567    (defun gnus-group-news (&optional arg)
568      "Start composing a news.
569    If ARG, post to group under point.
570    If ARG is 1, prompt for group name to post to.
571    
572    This function prepares a news even when using mail groups.  This is useful
573    for posting messages to mail groups without actually sending them over the
574    network.  The corresponding back end must have a 'request-post method."
575      (interactive "P")
576      ;; We can't `let' gnus-newsgroup-name here, since that leads
577      ;; to local variables leaking.
578      (let ((group gnus-newsgroup-name)
579            ;; make sure last viewed article doesn't affect posting styles:
580            (gnus-article-copy)
581            (buffer (current-buffer)))
582        (unwind-protect
583            (progn
584              (setq gnus-newsgroup-name
585                    (if arg
586                        (if (= 1 (prefix-numeric-value arg))
587                            (completing-read "Use group: "
588                                             gnus-active-hashtb nil
589                                             (gnus-read-active-file-p))
590                          (gnus-group-group-name))
591                      ""))
592              ;; #### see comment in gnus-setup-message -- drv
593              (gnus-setup-message 'message
594                (message-news (gnus-group-real-name gnus-newsgroup-name))))
595          (save-excursion
596            (set-buffer buffer)
597            (setq gnus-newsgroup-name group)))))
598    
599  (defun gnus-group-post-news (&optional arg)  (defun gnus-group-post-news (&optional arg)
600    "Start composing a news message.    "Start composing a message (a news by default).
601  If ARG, post to the group under point.  If ARG, post to group under point.  If ARG is 1, prompt for group name.
602  If ARG is 1, prompt for a group name."  Depending on the selected group, the message might be either a mail or
603    a news."
604    (interactive "P")    (interactive "P")
605    ;; Bind this variable here to make message mode hooks work ok.    ;; Bind this variable here to make message mode hooks work ok.
606    (let ((gnus-newsgroup-name    (let ((gnus-newsgroup-name
# Line 334  If ARG is 1, prompt for a group name." Line 609  If ARG is 1, prompt for a group name."
609                   (completing-read "Newsgroup: " gnus-active-hashtb nil                   (completing-read "Newsgroup: " gnus-active-hashtb nil
610                                    (gnus-read-active-file-p))                                    (gnus-read-active-file-p))
611                 (gnus-group-group-name))                 (gnus-group-group-name))
612             "")))             ""))
613            ;; make sure last viewed article doesn't affect posting styles:
614            (gnus-article-copy))
615        (gnus-post-news 'post gnus-newsgroup-name nil nil nil nil
616                        (string= gnus-newsgroup-name ""))))
617    
618    (defun gnus-summary-mail-other-window (&optional arg)
619      "Start composing a mail in another window.
620    Use the posting of the current group by default.
621    If ARG, don't do that.  If ARG is 1, prompt for group name to find the
622    posting style."
623      (interactive "P")
624      ;; We can't `let' gnus-newsgroup-name here, since that leads
625      ;; to local variables leaking.
626      (let ((group gnus-newsgroup-name)
627            ;; make sure last viewed article doesn't affect posting styles:
628            (gnus-article-copy)
629            (buffer (current-buffer)))
630        (unwind-protect
631            (progn
632              (setq gnus-newsgroup-name
633                    (if arg
634                        (if (= 1 (prefix-numeric-value arg))
635                            (completing-read "Use group: "
636                                             gnus-active-hashtb nil
637                                             (gnus-read-active-file-p))
638                          "")
639                      gnus-newsgroup-name))
640              ;; #### see comment in gnus-setup-message -- drv
641              (gnus-setup-message 'message (message-mail)))
642          (save-excursion
643            (set-buffer buffer)
644            (setq gnus-newsgroup-name group)))))
645    
646    (defun gnus-summary-news-other-window (&optional arg)
647      "Start composing a news in another window.
648    Post to the current group by default.
649    If ARG, don't do that.  If ARG is 1, prompt for group name to post to.
650    
651    This function prepares a news even when using mail groups.  This is useful
652    for posting messages to mail groups without actually sending them over the
653    network.  The corresponding back end must have a 'request-post method."
654      (interactive "P")
655      ;; We can't `let' gnus-newsgroup-name here, since that leads
656      ;; to local variables leaking.
657      (let ((group gnus-newsgroup-name)
658            ;; make sure last viewed article doesn't affect posting styles:
659            (gnus-article-copy)
660            (buffer (current-buffer)))
661        (unwind-protect
662            (progn
663              (setq gnus-newsgroup-name
664                    (if arg
665                        (if (= 1 (prefix-numeric-value arg))
666                            (completing-read "Use group: "
667                                             gnus-active-hashtb nil
668                                             (gnus-read-active-file-p))
669                          "")
670                      gnus-newsgroup-name))
671              ;; #### see comment in gnus-setup-message -- drv
672              (gnus-setup-message 'message
673                (progn
674                  (message-news (gnus-group-real-name gnus-newsgroup-name))
675                  (set (make-local-variable 'gnus-discouraged-post-methods)
676                       (delq
677                        (car (gnus-find-method-for-group gnus-newsgroup-name))
678                        (copy-sequence gnus-discouraged-post-methods))))))
679          (save-excursion
680            (set-buffer buffer)
681            (setq gnus-newsgroup-name group)))))
682    
683    (defun gnus-summary-post-news (&optional arg)
684      "Start composing a message.  Post to the current group by default.
685    If ARG, don't do that.  If ARG is 1, prompt for a group name to post to.
686    Depending on the selected group, the message might be either a mail or
687    a news."
688      (interactive "P")
689      ;; Bind this variable here to make message mode hooks work ok.
690      (let ((gnus-newsgroup-name
691             (if arg
692                 (if (= 1 (prefix-numeric-value arg))
693                     (completing-read "Newsgroup: " gnus-active-hashtb nil
694                                      (gnus-read-active-file-p))
695                   "")
696               gnus-newsgroup-name))
697            ;; make sure last viewed article doesn't affect posting styles:
698            (gnus-article-copy))
699      (gnus-post-news 'post gnus-newsgroup-name)))      (gnus-post-news 'post gnus-newsgroup-name)))
700    
 (defun gnus-summary-post-news ()  
   "Start composing a news message."  
   (interactive)  
   (gnus-post-news 'post gnus-newsgroup-name))  
701    
702  (defun gnus-summary-followup (yank &optional force-news)  (defun gnus-summary-followup (yank &optional force-news)
703    "Compose a followup to an article.    "Compose a followup to an article.
704  If prefix argument YANK is non-nil, original article is yanked automatically."  If prefix argument YANK is non-nil, the original article is yanked
705    automatically.
706    YANK is a list of elements, where the car of each element is the
707    article number, and the cdr is the string to be yanked."
708    (interactive    (interactive
709     (list (and current-prefix-arg     (list (and current-prefix-arg
710                (gnus-summary-work-articles 1))))                (gnus-summary-work-articles 1))))
711    (when yank    (when yank
712      (gnus-summary-goto-subject (car yank)))      (gnus-summary-goto-subject
713         (if (listp (car yank))
714             (caar yank)
715           (car yank))))
716    (save-window-excursion    (save-window-excursion
717      (gnus-summary-select-article))      (gnus-summary-select-article))
718    (let ((headers (gnus-summary-article-header (gnus-summary-article-number)))    (let ((headers (gnus-summary-article-header (gnus-summary-article-number)))
# Line 357  If prefix argument YANK is non-nil, orig Line 720  If prefix argument YANK is non-nil, orig
720      ;; Send a followup.      ;; Send a followup.
721      (gnus-post-news nil gnus-newsgroup-name      (gnus-post-news nil gnus-newsgroup-name
722                      headers gnus-article-buffer                      headers gnus-article-buffer
723                      yank nil force-news)))                      yank nil force-news)
724        (gnus-summary-handle-replysign)))
725    
726  (defun gnus-summary-followup-with-original (n &optional force-news)  (defun gnus-summary-followup-with-original (n &optional force-news)
727    "Compose a followup to an article and include the original article."    "Compose a followup to an article and include the original article.
728    The text in the region will be yanked.  If the region isn't
729    active, the entire article will be yanked."
730    (interactive "P")    (interactive "P")
731    (gnus-summary-followup (gnus-summary-work-articles n) force-news))    (gnus-summary-followup (gnus-summary-work-articles n) force-news))
732    
# Line 377  If prefix argument YANK is non-nil, orig Line 743  If prefix argument YANK is non-nil, orig
743    (gnus-summary-followup (gnus-summary-work-articles arg) t))    (gnus-summary-followup (gnus-summary-work-articles arg) t))
744    
745  (defun gnus-inews-yank-articles (articles)  (defun gnus-inews-yank-articles (articles)
746    (let (beg article)    (let (beg article yank-string)
747      (message-goto-body)      (message-goto-body)
748      (while (setq article (pop articles))      (while (setq article (pop articles))
749          (when (listp article)
750            (setq yank-string (nth 1 article)
751                  article (nth 0 article)))
752        (save-window-excursion        (save-window-excursion
753          (set-buffer gnus-summary-buffer)          (set-buffer gnus-summary-buffer)
754          (gnus-summary-select-article nil nil nil article)          (gnus-summary-select-article nil nil nil article)
755          (gnus-summary-remove-process-mark article))          (gnus-summary-remove-process-mark article))
756        (gnus-copy-article-buffer)        (gnus-copy-article-buffer nil yank-string)
757        (let ((message-reply-buffer gnus-article-copy)        (let ((message-reply-buffer gnus-article-copy)
758              (message-reply-headers gnus-current-headers))              (message-reply-headers
759                 ;; The headers are decoded.
760                 (with-current-buffer gnus-article-copy
761                   (save-restriction
762                     (nnheader-narrow-to-headers)
763                     (nnheader-parse-naked-head)))))
764          (message-yank-original)          (message-yank-original)
765          (setq beg (or beg (mark t))))          (setq beg (or beg (mark t))))
766        (when articles        (when articles
# Line 403  post using the current select method." Line 777  post using the current select method."
777    (let ((articles (gnus-summary-work-articles n))    (let ((articles (gnus-summary-work-articles n))
778          (message-post-method          (message-post-method
779           `(lambda (arg)           `(lambda (arg)
780              (gnus-post-method (not (eq symp 'a)) ,gnus-newsgroup-name)))              (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name)))
781          article)          article)
782      (while (setq article (pop articles))      (while (setq article (pop articles))
783        (when (gnus-summary-select-article t nil nil article)        (when (gnus-summary-select-article t nil nil article)
# Line 435  header line with the old Message-ID." Line 809  header line with the old Message-ID."
809    
810    
811    
812  (defun gnus-copy-article-buffer (&optional article-buffer)  (defun gnus-copy-article-buffer (&optional article-buffer yank-string)
813    ;; make a copy of the article buffer with all text properties removed    ;; make a copy of the article buffer with all text properties removed
814    ;; this copy is in the buffer gnus-article-copy.    ;; this copy is in the buffer gnus-article-copy.
815    ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used    ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
# Line 451  header line with the old Message-ID." Line 825  header line with the old Message-ID."
825          (error "Can't find any article buffer")          (error "Can't find any article buffer")
826        (save-excursion        (save-excursion
827          (set-buffer article-buffer)          (set-buffer article-buffer)
828          (save-restriction          (let ((gnus-newsgroup-charset (or gnus-article-charset
829            ;; Copy over the (displayed) article buffer, delete                                            gnus-newsgroup-charset))
830            ;; hidden text and remove text properties.                (gnus-newsgroup-ignored-charsets
831            (widen)                 (or gnus-article-ignored-charsets
832            (copy-to-buffer gnus-article-copy (point-min) (point-max))                     gnus-newsgroup-ignored-charsets)))
833            (set-buffer gnus-article-copy)            (save-restriction
834            (gnus-article-delete-text-of-type 'annotation)              ;; Copy over the (displayed) article buffer, delete
835            (gnus-remove-text-with-property 'gnus-prev)              ;; hidden text and remove text properties.
836            (gnus-remove-text-with-property 'gnus-next)              (widen)
837            (insert              (copy-to-buffer gnus-article-copy (point-min) (point-max))
838             (prog1              (set-buffer gnus-article-copy)
839                 (buffer-substring-no-properties (point-min) (point-max))              (when yank-string
840               (erase-buffer)))                (message-goto-body)
841            ;; Find the original headers.                (delete-region (point) (point-max))
842            (set-buffer gnus-original-article-buffer)                (insert yank-string))
843            (goto-char (point-min))              (gnus-article-delete-text-of-type 'annotation)
844            (while (looking-at message-unix-mail-delimiter)              (gnus-remove-text-with-property 'gnus-prev)
845              (forward-line 1))              (gnus-remove-text-with-property 'gnus-next)
846            (setq beg (point))              (gnus-remove-text-with-property 'gnus-decoration)
847            (setq end (or (search-forward "\n\n" nil t) (point)))              (insert
848            ;; Delete the headers from the displayed articles.               (prog1
849            (set-buffer gnus-article-copy)                   (buffer-substring-no-properties (point-min) (point-max))
850            (delete-region (goto-char (point-min))                 (erase-buffer)))
851                           (or (search-forward "\n\n" nil t) (point-max)))              ;; Find the original headers.
852            ;; Insert the original article headers.              (set-buffer gnus-original-article-buffer)
853            (insert-buffer-substring gnus-original-article-buffer beg end)              (goto-char (point-min))
854            (article-decode-encoded-words)))              (while (looking-at message-unix-mail-delimiter)
855                  (forward-line 1))
856                (let ((mail-header-separator ""))
857                  (setq beg (point)
858                        end (or (message-goto-body)
859                                ;; There may be just a header.
860                                (point-max))))
861                ;; Delete the headers from the displayed articles.
862                (set-buffer gnus-article-copy)
863                (let ((mail-header-separator ""))
864                  (delete-region (goto-char (point-min))
865                                 (or (message-goto-body) (point-max))))
866                ;; Insert the original article headers.
867                (insert-buffer-substring gnus-original-article-buffer beg end)
868                ;; Decode charsets.
869                (let ((gnus-article-decode-hook
870                       (delq 'article-decode-charset
871                             (copy-sequence gnus-article-decode-hook))))
872                  (run-hooks 'gnus-article-decode-hook)))))
873        gnus-article-copy)))        gnus-article-copy)))
874    
875  (defun gnus-post-news (post &optional group header article-buffer yank subject  (defun gnus-post-news (post &optional group header article-buffer yank subject
876                              force-news)                              force-news)
877    (when article-buffer    (when article-buffer
878      (gnus-copy-article-buffer))      (gnus-copy-article-buffer))
879    (let ((gnus-article-reply article-buffer)    (let ((gnus-article-reply (and article-buffer (gnus-summary-article-number)))
880            (gnus-article-yanked-articles yank)
881          (add-to-list gnus-add-to-list))          (add-to-list gnus-add-to-list))
882      (gnus-setup-message (cond (yank 'reply-yank)      (gnus-setup-message (cond (yank 'reply-yank)
883                                (article-buffer 'reply)                                (article-buffer 'reply)
# Line 495  header line with the old Message-ID." Line 888  header line with the old Message-ID."
888               to-address to-group mailing-list to-list               to-address to-group mailing-list to-list
889               newsgroup-p)               newsgroup-p)
890          (when group          (when group
891            (setq to-address (gnus-group-find-parameter group 'to-address)            (setq to-address (gnus-parameter-to-address group)
892                  to-group (gnus-group-find-parameter group 'to-group)                  to-group (gnus-group-find-parameter group 'to-group)
893                  to-list (gnus-group-find-parameter group 'to-list)                  to-list (gnus-parameter-to-list group)
894                  newsgroup-p (gnus-group-find-parameter group 'newsgroup)                  newsgroup-p (gnus-group-find-parameter group 'newsgroup)
895                  mailing-list (when gnus-mailing-list-groups                  mailing-list (when gnus-mailing-list-groups
896                                 (string-match gnus-mailing-list-groups group))                                 (string-match gnus-mailing-list-groups group))
# Line 509  header line with the old Message-ID." Line 902  header line with the old Message-ID."
902                  force-news                  force-news
903                  (and (gnus-news-group-p                  (and (gnus-news-group-p
904                        (or pgroup gnus-newsgroup-name)                        (or pgroup gnus-newsgroup-name)
905                        (if header (mail-header-number header)                        (or header gnus-current-article))
                         gnus-current-article))  
906                       (not mailing-list)                       (not mailing-list)
907                       (not to-list)                       (not to-list)
908                       (not to-address)))                       (not to-address)))
# Line 519  header line with the old Message-ID." Line 911  header line with the old Message-ID."
911                  (message-news (or to-group group))                  (message-news (or to-group group))
912                (set-buffer gnus-article-copy)                (set-buffer gnus-article-copy)
913                (gnus-msg-treat-broken-reply-to)                (gnus-msg-treat-broken-reply-to)
914                (message-followup (if (or newsgroup-p force-news) nil to-group)))                (message-followup (if (or newsgroup-p force-news)
915                                        (if (save-restriction
916                                              (article-narrow-to-head)
917                                              (message-fetch-field "newsgroups"))
918                                            nil
919                                          "")
920                                      to-group)))
921            ;; The is mail.            ;; The is mail.
922            (if post            (if post
923                (progn                (progn
# Line 537  header line with the old Message-ID." Line 935  header line with the old Message-ID."
935          (when yank          (when yank
936            (gnus-inews-yank-articles yank))))))            (gnus-inews-yank-articles yank))))))
937    
938  (defun gnus-msg-treat-broken-reply-to ()  (defun gnus-msg-treat-broken-reply-to (&optional force)
939    "Remove the Reply-to header if broken-reply-to."    "Remove the Reply-to header if broken-reply-to."
940    (when (gnus-group-find-parameter    (when (or force
941           gnus-newsgroup-name 'broken-reply-to)              (gnus-group-find-parameter
942                 gnus-newsgroup-name 'broken-reply-to))
943      (save-restriction      (save-restriction
944        (message-narrow-to-head)        (message-narrow-to-head)
945        (message-remove-header "reply-to"))))        (message-remove-header "reply-to"))))
# Line 548  header line with the old Message-ID." Line 947  header line with the old Message-ID."
947  (defun gnus-post-method (arg group &optional silent)  (defun gnus-post-method (arg group &optional silent)
948    "Return the posting method based on GROUP and ARG.    "Return the posting method based on GROUP and ARG.
949  If SILENT, don't prompt the user."  If SILENT, don't prompt the user."
950    (let ((group-method (gnus-find-method-for-group group)))    (let ((gnus-post-method (or (gnus-parameter-post-method group)
951                                  gnus-post-method))
952            (group-method (gnus-find-method-for-group group)))
953      (cond      (cond
954       ;; If the group-method is nil (which shouldn't happen) we use       ;; If the group-method is nil (which shouldn't happen) we use
955       ;; the default method.       ;; the default method.
956       ((null group-method)       ((null group-method)
957        (or (and (null (eq gnus-post-method 'active)) gnus-post-method)        (or (and (listp gnus-post-method) ;If not current/native/nil
958            gnus-select-method message-post-method))                 (not (listp (car gnus-post-method))) ; and not a list of methods
959                   gnus-post-method)        ;then use it.
960              gnus-select-method
961              message-post-method))
962       ;; We want the inverse of the default       ;; We want the inverse of the default
963       ((and arg (not (eq arg 0)))       ((and arg (not (eq arg 0)))
964        (if (eq gnus-post-method 'active)        (if (eq gnus-post-method 'current)
965            gnus-select-method            gnus-select-method
966          group-method))          group-method))
967       ;; We query the user for a post method.       ;; We query the user for a post method.
968       ((or arg       ((or arg
969            (and gnus-post-method            (and (listp gnus-post-method)
                (not (eq gnus-post-method 'current))  
970                 (listp (car gnus-post-method))))                 (listp (car gnus-post-method))))
971        (let* ((methods        (let* ((methods
972                ;; Collect all methods we know about.                ;; Collect all methods we know about.
973                (append                (append
974                 (when (and gnus-post-method                 (when (listp gnus-post-method)
                           (not (eq gnus-post-method 'current)))  
975                   (if (listp (car gnus-post-method))                   (if (listp (car gnus-post-method))
976                       gnus-post-method                       gnus-post-method
977                     (list gnus-post-method)))                     (list gnus-post-method)))
# Line 590  If SILENT, don't prompt the user." Line 992  If SILENT, don't prompt the user."
992          (setq method-alist          (setq method-alist
993                (mapcar                (mapcar
994                 (lambda (m)                 (lambda (m)
995                   (list (concat (cadr m) " (" (symbol-name (car m)) ")") m))                   (if (equal (cadr m) "")
996                         (list (symbol-name (car m)) m)
997                       (list (concat (cadr m) " (" (symbol-name (car m)) ")") m)))
998                 post-methods))                 post-methods))
999          ;; Query the user.          ;; Query the user.
1000          (cadr          (cadr
# Line 606  If SILENT, don't prompt the user." Line 1010  If SILENT, don't prompt the user."
1010            method-alist))))            method-alist))))
1011       ;; Override normal method.       ;; Override normal method.
1012       ((and (eq gnus-post-method 'current)       ((and (eq gnus-post-method 'current)
1013             (not (eq (car group-method) 'nndraft))             (not (memq (car group-method) gnus-discouraged-post-methods))
1014             (gnus-get-function group-method 'request-post t)             (gnus-get-function group-method 'request-post t))
1015             (not arg))        (assert (not arg))
1016        group-method)        group-method)
1017       ((and gnus-post-method       ;; Use gnus-post-method.
1018             (not (eq gnus-post-method 'current)))       ((listp gnus-post-method)          ;A method...
1019          (assert (not (listp (car gnus-post-method)))) ;... not a list of methods.
1020        gnus-post-method)        gnus-post-method)
1021       ;; Use the normal select method.       ;; Use the normal select method (nil or native).
1022       (t gnus-select-method))))       (t gnus-select-method))))
1023    
1024    
1025    
 ;; Dummies to avoid byte-compile warning.  
 (eval-when-compile  
   (defvar nnspool-rejected-article-hook)  
   (defvar xemacs-codename))  
   
1026  (defun gnus-extended-version ()  (defun gnus-extended-version ()
1027    "Stringified Gnus version and Emacs version."    "Stringified Gnus version and Emacs version.
1028    See the variable `gnus-user-agent'."
1029    (interactive)    (interactive)
1030    (concat    (let* ((float-output-format nil)
1031     "Gnus/" (prin1-to-string (gnus-continuum-version gnus-version) t)           (gnus-v
1032     " (" gnus-version ")"            (concat "Gnus/"
1033     " "                    (prin1-to-string (gnus-continuum-version gnus-version) t)
1034     (cond                    " (" gnus-version ")"))
1035      ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version)           (emacs-v (gnus-emacs-version)))
1036       (concat "Emacs/" (match-string 1 emacs-version)))      (if (stringp gnus-user-agent)
1037      ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?"          gnus-user-agent
1038                     emacs-version)        (concat gnus-v
1039       (concat (match-string 1 emacs-version)                (when emacs-v
1040               (format "/%d.%d" emacs-major-version emacs-minor-version)                  (concat " " emacs-v))))))
              (if (match-beginning 3)  
                  (match-string 3 emacs-version)  
                "")  
              (if (boundp 'xemacs-codename)  
                  (concat " (" xemacs-codename ")")  
                "")))  
     (t emacs-version))))  
1041    
1042    
1043  ;;;  ;;;
# Line 652  If SILENT, don't prompt the user." Line 1046  If SILENT, don't prompt the user."
1046    
1047  ;;; Mail reply commands of Gnus summary mode  ;;; Mail reply commands of Gnus summary mode
1048    
1049  (defun gnus-summary-reply (&optional yank wide)  (defun gnus-summary-reply (&optional yank wide very-wide)
1050    "Start composing a reply mail to the current message.    "Start composing a mail reply to the current message.
1051  If prefix argument YANK is non-nil, the original article is yanked  If prefix argument YANK is non-nil, the original article is yanked
1052  automatically."  automatically.
1053    If WIDE, make a wide reply.
1054    If VERY-WIDE, make a very wide reply."
1055    (interactive    (interactive
1056     (list (and current-prefix-arg     (list (and current-prefix-arg
1057                (gnus-summary-work-articles 1))))                (gnus-summary-work-articles 1))))
1058    ;; Stripping headers should be specified with mail-yank-ignored-headers.    ;; Allow user to require confirmation before replying by mail to the
1059    (when yank    ;; author of a news article (or mail message).
1060      (gnus-summary-goto-subject (car yank)))    (when (or
1061    (let ((gnus-article-reply t))              (not (or (gnus-news-group-p gnus-newsgroup-name)
1062      (gnus-setup-message (if yank 'reply-yank 'reply)                       gnus-confirm-treat-mail-like-news))
1063        (gnus-summary-select-article)              (not (cond ((stringp gnus-confirm-mail-reply-to-news)
1064        (set-buffer (gnus-copy-article-buffer))                          (string-match gnus-confirm-mail-reply-to-news
1065        (gnus-msg-treat-broken-reply-to)                                        gnus-newsgroup-name))
1066        (save-restriction                         ((functionp gnus-confirm-mail-reply-to-news)
1067          (message-narrow-to-head)                          (funcall gnus-confirm-mail-reply-to-news gnus-newsgroup-name))
1068          (goto-char (point-max)))                         (t gnus-confirm-mail-reply-to-news)))
1069        (mml-quote-region (point) (point-max))              (y-or-n-p "Really reply by mail to article author? "))
1070        (message-reply nil wide)      (let* ((article
1071                (if (listp (car yank))
1072                    (caar yank)
1073                  (car yank)))
1074               (gnus-article-reply (or article (gnus-summary-article-number)))
1075               (gnus-article-yanked-articles yank)
1076               (headers ""))
1077          ;; Stripping headers should be specified with mail-yank-ignored-headers.
1078        (when yank        (when yank
1079          (gnus-inews-yank-articles yank)))))          (gnus-summary-goto-subject article))
1080          (gnus-setup-message (if yank 'reply-yank 'reply)
1081            (if (not very-wide)
1082                (gnus-summary-select-article)
1083              (dolist (article very-wide)
1084                (gnus-summary-select-article nil nil nil article)
1085                (save-excursion
1086                  (set-buffer (gnus-copy-article-buffer))
1087                  (gnus-msg-treat-broken-reply-to)
1088                  (save-restriction
1089                    (message-narrow-to-head)
1090                    (setq headers (concat headers (buffer-string)))))))
1091            (set-buffer (gnus-copy-article-buffer))
1092            (gnus-msg-treat-broken-reply-to gnus-msg-force-broken-reply-to)
1093            (save-restriction
1094              (message-narrow-to-head)
1095              (when very-wide
1096                (erase-buffer)
1097                (insert headers))
1098              (goto-char (point-max)))
1099            (mml-quote-region (point) (point-max))
1100            (message-reply nil wide)
1101            (when yank
1102              (gnus-inews-yank-articles yank))
1103            (gnus-summary-handle-replysign)))))
1104    
1105    (defun gnus-summary-handle-replysign ()
1106      "Check the various replysign variables and take action accordingly."
1107      (when (or gnus-message-replysign gnus-message-replyencrypt)
1108        (let (signed encrypted)
1109          (save-excursion
1110            (set-buffer gnus-article-buffer)
1111            (setq signed (memq 'signed gnus-article-wash-types))
1112            (setq encrypted (memq 'encrypted gnus-article-wash-types)))
1113          (cond ((and gnus-message-replyencrypt encrypted)
1114                 (mml-secure-message mml-default-encrypt-method
1115                                     (if gnus-message-replysignencrypted
1116                                         'signencrypt
1117                                       'encrypt)))
1118                ((and gnus-message-replysign signed)
1119                 (mml-secure-message mml-default-sign-method 'sign))))))
1120    
1121  (defun gnus-summary-reply-with-original (n &optional wide)  (defun gnus-summary-reply-with-original (n &optional wide)
1122    "Start composing a reply mail to the current message.    "Start composing a reply mail to the current message.
# Line 681  The original article will be yanked." Line 1124  The original article will be yanked."
1124    (interactive "P")    (interactive "P")
1125    (gnus-summary-reply (gnus-summary-work-articles n) wide))    (gnus-summary-reply (gnus-summary-work-articles n) wide))
1126    
1127    (defun gnus-summary-reply-broken-reply-to (&optional yank wide very-wide)
1128      "Like `gnus-summary-reply' except removing reply-to field.
1129    If prefix argument YANK is non-nil, the original article is yanked
1130    automatically.
1131    If WIDE, make a wide reply.
1132    If VERY-WIDE, make a very wide reply."
1133      (interactive
1134       (list (and current-prefix-arg
1135                  (gnus-summary-work-articles 1))))
1136      (let ((gnus-msg-force-broken-reply-to t))
1137        (gnus-summary-reply yank wide very-wide)))
1138    
1139    (defun gnus-summary-reply-broken-reply-to-with-original (n &optional wide)
1140      "Like `gnus-summary-reply-with-original' except removing reply-to field.
1141    The original article will be yanked."
1142      (interactive "P")
1143      (gnus-summary-reply-broken-reply-to (gnus-summary-work-articles n) wide))
1144    
1145  (defun gnus-summary-wide-reply (&optional yank)  (defun gnus-summary-wide-reply (&optional yank)
1146    "Start composing a wide reply mail to the current message.    "Start composing a wide reply mail to the current message.
1147  If prefix argument YANK is non-nil, the original article is yanked  If prefix argument YANK is non-nil, the original article is yanked
# Line 692  automatically." Line 1153  automatically."
1153    
1154  (defun gnus-summary-wide-reply-with-original (n)  (defun gnus-summary-wide-reply-with-original (n)
1155    "Start composing a wide reply mail to the current message.    "Start composing a wide reply mail to the current message.
1156  The original article will be yanked."  The original article will be yanked.
1157    Uses the process/prefix convention."
1158    (interactive "P")    (interactive "P")
1159    (gnus-summary-reply-with-original n t))    (gnus-summary-reply-with-original n t))
1160    
1161    (defun gnus-summary-very-wide-reply (&optional yank)
1162      "Start composing a very wide reply mail to the current message.
1163    If prefix argument YANK is non-nil, the original article is yanked
1164    automatically."
1165      (interactive
1166       (list (and current-prefix-arg
1167                  (gnus-summary-work-articles 1))))
1168      (gnus-summary-reply yank t (gnus-summary-work-articles yank)))
1169    
1170    (defun gnus-summary-very-wide-reply-with-original (n)
1171      "Start composing a very wide reply mail to the current message.
1172    The original article will be yanked."
1173      (interactive "P")
1174      (gnus-summary-reply
1175       (gnus-summary-work-articles n) t (gnus-summary-work-articles n)))
1176    
1177  (defun gnus-summary-mail-forward (&optional arg post)  (defun gnus-summary-mail-forward (&optional arg post)
1178    "Forward the current message to another user.    "Forward the current message(s) to another user.
1179  If ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml';  If process marks exist, forward all marked messages;
1180    if ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml';
1181  if ARG is 1, decode the message and forward directly inline;  if ARG is 1, decode the message and forward directly inline;
1182  if ARG is 2, forward message as an rfc822 MIME section;  if ARG is 2, forward message as an rfc822 MIME section;
1183  if ARG is 3, decode message and forward as an rfc822 MIME section;  if ARG is 3, decode message and forward as an rfc822 MIME section;
1184  if ARG is 4, forward message directly inline;  if ARG is 4, forward message directly inline;
1185  otherwise, use flipped `message-forward-as-mime'.  otherwise, use flipped `message-forward-as-mime'.
1186  If POST, post instead of mail."  If POST, post instead of mail.
1187    For the `inline' alternatives, also see the variable
1188    `message-forward-ignored-headers'."
1189    (interactive "P")    (interactive "P")
1190    (let ((message-forward-as-mime message-forward-as-mime)    (if (cdr (gnus-summary-work-articles nil))
1191          (message-forward-show-mml message-forward-show-mml))        ;; Process marks are given.
1192      (cond        (gnus-uu-digest-mail-forward arg post)
1193       ((null arg))      ;; No process marks.
1194       ((eq arg 1) (setq message-forward-as-mime nil      (let ((message-forward-as-mime message-forward-as-mime)
1195                         message-forward-show-mml t))            (message-forward-show-mml message-forward-show-mml))
1196       ((eq arg 2) (setq message-forward-as-mime t        (cond
1197                         message-forward-show-mml nil))         ((null arg))
1198       ((eq arg 3) (setq message-forward-as-mime t         ((eq arg 1)
1199                         message-forward-show-mml t))          (setq message-forward-as-mime nil
1200       ((eq arg 4) (setq message-forward-as-mime nil                message-forward-show-mml t))
1201                         message-forward-show-mml nil))         ((eq arg 2)
1202       (t (setq message-forward-as-mime (not message-forward-as-mime))))          (setq message-forward-as-mime t
1203      (gnus-setup-message 'forward                message-forward-show-mml nil))
1204        (gnus-summary-select-article)         ((eq arg 3)
1205        (let ((mail-parse-charset gnus-newsgroup-charset)          (setq message-forward-as-mime t
1206              (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets))                message-forward-show-mml t))
1207          (set-buffer gnus-original-article-buffer)         ((eq arg 4)
1208          (message-forward post)))))          (setq message-forward-as-mime nil
1209                  message-forward-show-mml nil))
1210           (t
1211            (setq message-forward-as-mime (not message-forward-as-mime))))
1212          (let* ((gnus-article-reply (gnus-summary-article-number))
1213                 (gnus-article-yanked-articles (list gnus-article-reply)))
1214            (gnus-setup-message 'forward
1215              (gnus-summary-select-article)
1216              (let ((mail-parse-charset
1217                     (or (and (gnus-buffer-live-p gnus-article-buffer)
1218                              (with-current-buffer gnus-article-buffer
1219                                gnus-article-charset))
1220                         gnus-newsgroup-charset))
1221                    (mail-parse-ignored-charsets
1222                     gnus-newsgroup-ignored-charsets))
1223                (set-buffer gnus-original-article-buffer)
1224                (message-forward post)))))))
1225    
1226  (defun gnus-summary-resend-message (address n)  (defun gnus-summary-resend-message (address n)
1227    "Resend the current article to ADDRESS."    "Resend the current article to ADDRESS."
1228    (interactive "sResend message(s) to: \nP")    (interactive
1229       (list (message-read-from-minibuffer
1230              "Resend message(s) to: "
1231              (when (and gnus-summary-resend-default-address
1232                         (gnus-buffer-live-p gnus-original-article-buffer))
1233                ;; If some other article is currently selected, the
1234                ;; initial-contents is wrong. Whatever, it is just the
1235                ;; initial-contents.
1236                (with-current-buffer gnus-original-article-buffer
1237                  (nnmail-fetch-field "to"))))
1238             current-prefix-arg))
1239    (let ((articles (gnus-summary-work-articles n))    (let ((articles (gnus-summary-work-articles n))
1240          article)          article)
1241      (while (setq article (pop articles))      (while (setq article (pop articles))
1242        (gnus-summary-select-article nil nil nil article)        (gnus-summary-select-article nil nil nil article)
1243        (save-excursion        (save-excursion
1244          (set-buffer gnus-original-article-buffer)          (set-buffer gnus-original-article-buffer)
1245          (message-resend address)))))          (message-resend address))
1246          (gnus-summary-mark-article-as-forwarded article))))
1247    
1248    ;; From: Matthieu Moy <Matthieu.Moy@imag.fr>
1249    (defun gnus-summary-resend-message-edit ()
1250      "Resend an article that has already been sent.
1251    A new buffer will be created to allow the user to modify body and
1252    contents of the message, and then, everything will happen as when
1253    composing a new message."
1254      (interactive)
1255      (let ((article (gnus-summary-article-number)))
1256        (gnus-setup-message 'reply-yank
1257          (gnus-summary-select-article t)
1258          (set-buffer gnus-original-article-buffer)
1259          (let ((cur (current-buffer))
1260                (to (message-fetch-field "to")))
1261            ;; Get a normal message buffer.
1262            (message-pop-to-buffer (message-buffer-name "Resend" to))
1263            (insert-buffer-substring cur)
1264            (message-narrow-to-head-1)
1265            ;; Gnus will generate a new one when sending.
1266            (message-remove-header "Message-ID")
1267            (message-remove-header message-ignored-resent-headers t)
1268            ;; Remove unwanted headers.
1269            (goto-char (point-max))
1270            (insert mail-header-separator)
1271            (goto-char (point-min))
1272            (when (re-search-forward "^To:\\|^Newsgroups:" nil 'move)
1273              (forward-char 1))
1274            (widen)))))
1275    
1276  (defun gnus-summary-post-forward (&optional arg)  (defun gnus-summary-post-forward (&optional arg)
1277    "Forward the current article to a newsgroup.    "Forward the current article to a newsgroup.
# Line 796  The current group name will be inserted Line 1332  The current group name will be inserted
1332            (when (gnus-y-or-n-p "Send this complaint? ")            (when (gnus-y-or-n-p "Send this complaint? ")
1333              (message-send-and-exit)))))))              (message-send-and-exit)))))))
1334    
 (defun gnus-summary-mail-other-window ()  
   "Compose mail in other window."  
   (interactive)  
   (gnus-setup-message 'message  
     (message-mail)))  
   
1335  (defun gnus-mail-parse-comma-list ()  (defun gnus-mail-parse-comma-list ()
1336    (let (accumulated    (let (accumulated
1337          beg)          beg)
# Line 836  The current group name will be inserted Line 1366  The current group name will be inserted
1366        ;; This mail group doesn't have a `to-list', so we add one        ;; This mail group doesn't have a `to-list', so we add one
1367        ;; here.  Magic!        ;; here.  Magic!
1368        (when (gnus-y-or-n-p        (when (gnus-y-or-n-p
1369               (format "Do you want to add this as `to-list': %s " to-address))               (format "Do you want to add this as `to-list': %s? " to-address))
1370          (gnus-group-add-parameter group (cons 'to-list to-address))))))          (gnus-group-add-parameter group (cons 'to-list to-address))))))
1371    
1372  (defun gnus-put-message ()  (defun gnus-put-message ()
# Line 845  The current group name will be inserted Line 1375  The current group name will be inserted
1375    (let ((reply gnus-article-reply)    (let ((reply gnus-article-reply)
1376          (winconf gnus-prev-winconf)          (winconf gnus-prev-winconf)
1377          (group gnus-newsgroup-name))          (group gnus-newsgroup-name))
1378        (unless (and group
1379                     (not (gnus-group-read-only-p group)))
1380          (setq group (read-string "Put in group: " nil (gnus-writable-groups))))
1381    
     (or (and group (not (gnus-group-read-only-p group)))  
         (setq group (read-string "Put in group: " nil  
                                  (gnus-writable-groups))))  
1382      (when (gnus-gethash group gnus-newsrc-hashtb)      (when (gnus-gethash group gnus-newsrc-hashtb)
1383        (error "No such group: %s" group))        (error "No such group: %s" group))
   
1384      (save-excursion      (save-excursion
1385        (save-restriction        (save-restriction
1386          (widen)          (widen)
1387          (message-narrow-to-headers)          (message-narrow-to-headers)
1388          (let (gnus-deletable-headers)          (let ((gnus-deletable-headers nil))
1389            (if (message-news-p)            (message-generate-headers
1390                (message-generate-headers message-required-news-headers)             (if (message-news-p)
1391              (message-generate-headers message-required-mail-headers)))                 message-required-news-headers
1392                 message-required-mail-headers)))
1393          (goto-char (point-max))          (goto-char (point-max))
1394          (insert "Gcc: " group "\n")          (if (string-match " " group)
1395                (insert "Gcc: \"" group "\"\n")
1396              (insert "Gcc: " group "\n"))
1397          (widen)))          (widen)))
   
1398      (gnus-inews-do-gcc)      (gnus-inews-do-gcc)
1399        (when (and (get-buffer gnus-group-buffer)
1400      (when (get-buffer gnus-group-buffer)                 (gnus-buffer-exists-p (car-safe reply))
1401        (when (gnus-buffer-exists-p (car-safe reply))                 (cdr reply))
1402          (set-buffer (car reply))        (set-buffer (car reply))
1403          (and (cdr reply)        (gnus-summary-mark-article-as-replied (cdr reply)))
1404               (gnus-summary-mark-article-as-replied      (when winconf
1405                (cdr reply))))        (set-window-configuration winconf))))
       (when winconf  
         (set-window-configuration winconf)))))  
1406    
1407  (defun gnus-article-mail (yank)  (defun gnus-article-mail (yank)
1408    "Send a reply to the address near point.    "Send a reply to the address near point.
# Line 884  If YANK is non-nil, include the original Line 1413  If YANK is non-nil, include the original
1413            (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point)))            (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point)))
1414            (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point))))))            (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point))))))
1415      (when address      (when address
1416        (message-reply address)        (gnus-msg-mail address)
1417        (when yank        (when yank
1418          (gnus-inews-yank-articles (list (cdr gnus-article-current)))))))          (gnus-inews-yank-articles (list (cdr gnus-article-current)))))))
1419    
# Line 919  If YANK is non-nil, include the original Line 1448  If YANK is non-nil, include the original
1448      (let (text)      (let (text)
1449        (save-excursion        (save-excursion
1450          (set-buffer (gnus-get-buffer-create " *gnus environment info*"))          (set-buffer (gnus-get-buffer-create " *gnus environment info*"))
1451            (erase-buffer)
1452          (gnus-debug)          (gnus-debug)
1453          (setq text (buffer-string)))          (setq text (buffer-string)))
1454        (insert "<#part type=application/x-emacs-lisp disposition=inline description=\"User settings\">\n" text "\n<#/part>"))        (insert "<#part type=application/emacs-lisp disposition=inline description=\"User settings\">\n" text "\n<#/part>"))
1455      (goto-char (point-min))      (goto-char (point-min))
1456      (search-forward "Subject: " nil t)      (search-forward "Subject: " nil t)
1457      (message "")))      (message "")))
# Line 936  If YANK is non-nil, include the original Line 1466  If YANK is non-nil, include the original
1466     (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t)     (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t)
1467           current-prefix-arg))           current-prefix-arg))
1468    (gnus-summary-iterate n    (gnus-summary-iterate n
1469      (let ((gnus-display-mime-function nil)      (let ((gnus-inhibit-treatment t))
           (gnus-inhibit-treatment t))  
1470        (gnus-summary-select-article))        (gnus-summary-select-article))
1471      (save-excursion      (save-excursion
1472        (set-buffer buffer)        (set-buffer buffer)
# Line 947  If YANK is non-nil, include the original Line 1476  If YANK is non-nil, include the original
1476    "Attempts to go through the Gnus source file and report what variables have been changed.    "Attempts to go through the Gnus source file and report what variables have been changed.
1477  The source file has to be in the Emacs load path."  The source file has to be in the Emacs load path."
1478    (interactive)    (interactive)
1479    (let ((files '("gnus.el" "gnus-sum.el" "gnus-group.el"    (let ((files gnus-debug-files)
                  "gnus-art.el" "gnus-start.el" "gnus-async.el"  
                  "gnus-msg.el" "gnus-score.el" "gnus-win.el" "gnus-topic.el"  
                  "nnmail.el" "message.el"))  
1480          (point (point))          (point (point))
1481          file expr olist sym)          file expr olist sym)
1482      (gnus-message 4 "Please wait while we snoop your variables...")      (gnus-message 4 "Please wait while we snoop your variables...")
# Line 973  The source file has to be in the Emacs l Line 1499  The source file has to be in the Emacs l
1499                  (and (or (eq (car expr) 'defvar)                  (and (or (eq (car expr) 'defvar)
1500                           (eq (car expr) 'defcustom))                           (eq (car expr) 'defcustom))
1501                       (stringp (nth 3 expr))                       (stringp (nth 3 expr))
1502                         (not (memq (nth 1 expr) gnus-debug-exclude-variables))
1503                       (or (not (boundp (nth 1 expr)))                       (or (not (boundp (nth 1 expr)))
1504                           (not (equal (eval (nth 2 expr))                           (not (equal (eval (nth 2 expr))
1505                                       (symbol-value (nth 1 expr)))))                                       (symbol-value (nth 1 expr)))))
# Line 982  The source file has to be in the Emacs l Line 1509  The source file has to be in the Emacs l
1509        (insert "------------------ Environment follows ------------------\n\n"))        (insert "------------------ Environment follows ------------------\n\n"))
1510      (while olist      (while olist
1511        (if (boundp (car olist))        (if (boundp (car olist))
1512            (condition-case ()            (ignore-errors
1513                (pp `(setq ,(car olist)              (pp `(setq ,(car olist)
1514                           ,(if (or (consp (setq sym (symbol-value (car olist))))                         ,(if (or (consp (setq sym (symbol-value (car olist))))
1515                                    (and (symbolp sym)                                  (and (symbolp sym)
1516                                         (not (or (eq sym nil)                                       (not (or (eq sym nil)
1517                                                  (eq sym t)))))                                                (eq sym t)))))
1518                                (list 'quote (symbol-value (car olist)))                              (list 'quote (symbol-value (car olist)))
1519                              (symbol-value (car olist))))                            (symbol-value (car olist))))
1520                    (current-buffer))                  (current-buffer)))
             (error  
              (format "(setq %s 'whatever)\n" (car olist))))  
1521          (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))          (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))
1522        (setq olist (cdr olist)))        (setq olist (cdr olist)))
1523      (insert "\n\n")      (insert "\n\n")
# Line 1008  The source file has to be in the Emacs l Line 1533  The source file has to be in the Emacs l
1533    
1534  (defun gnus-summary-resend-bounced-mail (&optional fetch)  (defun gnus-summary-resend-bounced-mail (&optional fetch)
1535    "Re-mail the current message.    "Re-mail the current message.
1536  This only makes sense if the current message is a bounce message than  This only makes sense if the current message is a bounce message that
1537  contains some mail you have written which has been bounced back to  contains some mail you have written which has been bounced back to
1538  you.  you.
1539  If FETCH, try to fetch the article that this is a reply to, if indeed  If FETCH, try to fetch the article that this is a reply to, if indeed
# Line 1028  this is a reply." Line 1553  this is a reply."
1553  ;;; Gcc handling.  ;;; Gcc handling.
1554    
1555  (defun gnus-inews-group-method (group)  (defun gnus-inews-group-method (group)
1556    (cond ((and (null (gnus-get-info group))    (cond
1557                (eq (car gnus-message-archive-method)     ;; If the group doesn't exist, we assume
1558                    (car     ;; it's an archive group...
1559                     (gnus-server-to-method     ((and (null (gnus-get-info group))
1560                      (gnus-group-method group)))))           (eq (car (gnus-server-to-method gnus-message-archive-method))
1561           ;; If the group doesn't exist, we assume               (car (gnus-server-to-method (gnus-group-method group)))))
1562           ;; it's an archive group...      gnus-message-archive-method)
1563           gnus-message-archive-method)     ;; Use the method.
1564          ;; Use the method.     ((gnus-info-method (gnus-get-info group))
1565          ((gnus-info-method (gnus-get-info group))      (gnus-info-method (gnus-get-info group)))
1566           (gnus-info-method (gnus-get-info group)))     ;; Find the method.
1567          ;; Find the method.     (t (gnus-server-to-method (gnus-group-method group)))))
         (t (gnus-group-method group))))  
1568    
1569  ;; Do Gcc handling, which copied the message over to some group.  ;; Do Gcc handling, which copied the message over to some group.
1570  (defun gnus-inews-do-gcc (&optional gcc)  (defun gnus-inews-do-gcc (&optional gcc)
1571    (interactive)    (interactive)
1572    (when (gnus-alive-p)    (save-excursion
1573      (save-excursion      (save-restriction
1574        (save-restriction        (message-narrow-to-headers)
1575          (message-narrow-to-headers)        (let ((gcc (or gcc (mail-fetch-field "gcc" nil t)))
1576          (let ((gcc (or gcc (mail-fetch-field "gcc" nil t)))              (cur (current-buffer))
1577                (cur (current-buffer))              groups group method group-art
1578                groups group method)              mml-externalize-attachments)
1579            (when gcc          (when gcc
1580              (message-remove-header "gcc")            (message-remove-header "gcc")
1581              (widen)            (widen)
1582              (setq groups (message-unquote-tokens            (setq groups (message-unquote-tokens
1583                            (message-tokenize-header gcc " ,")))                          (message-tokenize-header gcc " ,")))
1584              ;; Copy the article over to some group(s).            ;; Copy the article over to some group(s).
1585              (while (setq group (pop groups))            (while (setq group (pop groups))
1586                (gnus-check-server              (unless (gnus-check-server
1587                 (setq method (gnus-inews-group-method group)))                       (setq method (gnus-inews-group-method group)))
1588                (unless (gnus-request-group group t method)                (error "Can't open server %s" (if (stringp method) method
1589                  (gnus-request-create-group group method))                                                (car method))))
1590                (save-excursion              (unless (gnus-request-group group nil method)
1591                  (nnheader-set-temp-buffer " *acc*")                (gnus-request-create-group group method))
1592                  (insert-buffer-substring cur)              (setq mml-externalize-attachments
1593                  (message-encode-message-body)                    (if (stringp gnus-gcc-externalize-attachments)
1594                  (save-restriction                        (string-match gnus-gcc-externalize-attachments group)
1595                    (message-narrow-to-headers)                      gnus-gcc-externalize-attachments))
1596                    (let ((mail-parse-charset message-default-charset)              (save-excursion
1597                          (rfc2047-header-encoding-alist                (nnheader-set-temp-buffer " *acc*")
1598                           (cons '("Newsgroups" . default)                (insert-buffer-substring cur)
1599                                 rfc2047-header-encoding-alist)))                (message-encode-message-body)
1600                      (mail-encode-encoded-word-buffer)))                (save-restriction
1601                  (goto-char (point-min))                  (message-narrow-to-headers)
1602                  (when (re-search-forward                  (let* ((mail-parse-charset message-default-charset)
1603                         (concat "^" (regexp-quote mail-header-separator) "$")                         (newsgroups-field (save-restriction
1604                         nil t)                                             (message-narrow-to-headers-or-head)
1605                    (replace-match "" t t ))                                             (message-fetch-field "Newsgroups")))
1606                  (unless (gnus-request-accept-article group method t t)                         (followup-field (save-restriction
1607                    (gnus-message 1 "Couldn't store article in group %s: %s"                                           (message-narrow-to-headers-or-head)
1608                                  group (gnus-status-message method))                                           (message-fetch-field "Followup-To")))
1609                    (sit-for 2))                         ;; BUG: We really need to get the charset for
1610                  (kill-buffer (current-buffer))))))))))                         ;; each name in the Newsgroups and Followup-To
1611                           ;; lines to allow crossposting between group
1612                           ;; namess with incompatible character sets.
1613                           ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08.
1614                           (group-field-charset
1615                            (gnus-group-name-charset
1616                             method (or newsgroups-field "")))
1617                           (followup-field-charset
1618                            (gnus-group-name-charset
1619                             method (or followup-field "")))
1620                           (rfc2047-header-encoding-alist
1621                            (append
1622                             (when group-field-charset
1623                               (list (cons "Newsgroups" group-field-charset)))
1624                             (when followup-field-charset
1625                               (list (cons "Followup-To" followup-field-charset)))
1626                             rfc2047-header-encoding-alist)))
1627                      (mail-encode-encoded-word-buffer)))
1628                  (goto-char (point-min))
1629                  (when (re-search-forward
1630                         (concat "^" (regexp-quote mail-header-separator) "$")
1631                         nil t)
1632                    (replace-match "" t t ))
1633                  (unless (setq group-art
1634                                (gnus-request-accept-article group method t t))
1635                    (gnus-message 1 "Couldn't store article in group %s: %s"
1636                                  group (gnus-status-message method))
1637                    (sit-for 2))
1638                  (when (and group-art
1639                             ;; FIXME: Should gcc-mark-as-read work when
1640                             ;; Gnus is not running?
1641                             (gnus-alive-p)
1642                             (or gnus-gcc-mark-as-read
1643                                 (and
1644                                  (boundp 'gnus-inews-mark-gcc-as-read)
1645                                  (symbol-value 'gnus-inews-mark-gcc-as-read))))
1646                    (gnus-group-mark-article-read group (cdr group-art)))
1647                  (kill-buffer (current-buffer)))))))))
1648    
1649  (defun gnus-inews-insert-gcc ()  (defun gnus-inews-insert-gcc ()
1650    "Insert Gcc headers based on `gnus-outgoing-message-group'."    "Insert Gcc headers based on `gnus-outgoing-message-group'."
# Line 1092  this is a reply." Line 1653  this is a reply."
1653        (message-narrow-to-headers)        (message-narrow-to-headers)
1654        (let* ((group gnus-outgoing-message-group)        (let* ((group gnus-outgoing-message-group)
1655               (gcc (cond               (gcc (cond
1656                     ((gnus-functionp group)                     ((functionp group)
1657                      (funcall group))                      (funcall group))
1658                     ((or (stringp group) (list group))                     ((or (stringp group) (list group))
1659                      group))))                      group))))
1660          (when gcc          (when gcc
1661            (insert "Gcc: "            (insert "Gcc: "
1662                    (if (stringp gcc) gcc                    (if (stringp gcc)
1663                      (mapconcat 'identity gcc " "))                        (if (string-match " " gcc)
1664                              (concat "\"" gcc "\"")
1665                            gcc)
1666                        (mapconcat (lambda (group)
1667                                     (if (string-match " " group)
1668                                         (concat "\"" group "\"")
1669                                       group))
1670                                   gcc " "))
1671                    "\n"))))))                    "\n"))))))
1672    
1673  (defun gnus-inews-insert-archive-gcc (&optional group)  (defun gnus-inews-insert-archive-gcc (&optional group)
# Line 1126  this is a reply." Line 1694  this is a reply."
1694             ((and (listp var) (stringp (car var)))             ((and (listp var) (stringp (car var)))
1695              ;; A list of groups.              ;; A list of groups.
1696              var)              var)
1697             ((gnus-functionp var)             ((functionp var)
1698              ;; A function.              ;; A function.
1699              (funcall var group))              (funcall var group))
1700             (t             (t
# Line 1139  this is a reply." Line 1707  this is a reply."
1707                                   ;; Regexp.                                   ;; Regexp.
1708                                   (when (string-match (caar var) group)                                   (when (string-match (caar var) group)
1709                                     (cdar var)))                                     (cdar var)))
1710                                  ((gnus-functionp (car var))                                  ((functionp (car var))
1711                                   ;; Function.                                   ;; Function.
1712                                   (funcall (car var) group))                                   (funcall (car var) group))
1713                                  (t                                  (t
# Line 1160  this is a reply." Line 1728  this is a reply."
1728                (progn                (progn
1729                  (insert                  (insert
1730                   (if (stringp gcc-self-val)                   (if (stringp gcc-self-val)
1731                       gcc-self-val                       (if (string-match " " gcc-self-val)
1732                     group))                           (concat "\"" gcc-self-val "\"")
1733                           gcc-self-val)
1734                       ;; In nndoc groups, we use the parent group name
1735                       ;; instead of the current group.
1736                       (let ((group (or (gnus-group-find-parameter
1737                                         gnus-newsgroup-name 'parent-group)
1738                                        group)))
1739                         (if (string-match " " group)
1740                             (concat "\"" group "\"")
1741                           group))))
1742                  (if (not (eq gcc-self-val 'none))                  (if (not (eq gcc-self-val 'none))
1743                      (insert "\n")                      (insert "\n")
1744                    (progn                    (gnus-delete-line)))
                     (beginning-of-line)  
                     (kill-line))))  
1745              ;; Use the list of groups.              ;; Use the list of groups.
1746              (while (setq name (pop groups))              (while (setq name (pop groups))
1747                (insert (if (string-match ":" name)                (let ((str (if (string-match ":" name)
1748                            name                               name
1749                          (gnus-group-prefixed-name                             (gnus-group-prefixed-name
1750                           name gnus-message-archive-method)))                              name gnus-message-archive-method))))
1751                    (insert (if (string-match " " str)
1752                                (concat "\"" str "\"")
1753                              str)))
1754                (when groups                (when groups
1755                  (insert " ")))                  (insert " ")))
1756              (insert "\n")))))))              (insert "\n")))))))
1757    
1758    (defun gnus-mailing-list-followup-to ()
1759      "Look at the headers in the current buffer and return a Mail-Followup-To address."
1760      (let ((x-been-there (gnus-fetch-original-field "x-beenthere"))
1761            (list-post (gnus-fetch-original-field "list-post")))
1762        (when (and list-post
1763                   (string-match "mailto:\\([^>]+\\)" list-post))
1764          (setq list-post (match-string 1 list-post)))
1765        (or list-post
1766            x-been-there)))
1767    
1768  ;;; Posting styles.  ;;; Posting styles.
1769    
1770  (defun gnus-configure-posting-styles ()  (defun gnus-configure-posting-styles (&optional group-name)
1771    "Configure posting styles according to `gnus-posting-styles'."    "Configure posting styles according to `gnus-posting-styles'."
1772    (unless gnus-inhibit-posting-styles    (unless gnus-inhibit-posting-styles
1773      (let ((group (or gnus-newsgroup-name ""))      (let ((group (or group-name gnus-newsgroup-name ""))
1774            (styles gnus-posting-styles)            (styles gnus-posting-styles)
1775            style match variable attribute value v results            style match attribute value v results
1776            filep name address element)            filep name address element)
1777        ;; If the group has a posting-style parameter, add it at the end with a        ;; If the group has a posting-style parameter, add it at the end with a
1778        ;; regexp matching everything, to be sure it takes precedence over all        ;; regexp matching everything, to be sure it takes precedence over all
# Line 1202  this is a reply." Line 1790  this is a reply."
1790                  ;; Regexp string match on the group name.                  ;; Regexp string match on the group name.
1791                  (string-match match group))                  (string-match match group))
1792                 ((eq match 'header)                 ((eq match 'header)
1793                  (let ((header (message-fetch-field (pop style))))                  ;; Obsolete format of header match.
1794                    (and header                  (and (gnus-buffer-live-p gnus-article-copy)
1795                         (string-match (pop style) header))))                       (with-current-buffer gnus-article-copy
1796                           (let ((header (message-fetch-field (pop style))))
1797                             (and header
1798                                  (string-match (pop style) header))))))
1799                 ((or (symbolp match)                 ((or (symbolp match)
1800                      (gnus-functionp match))                      (functionp match))
1801                  (cond                  (cond
1802                   ((gnus-functionp match)                   ((functionp match)
1803                    ;; Function to be called.                    ;; Function to be called.
1804                    (funcall match))                    (funcall match))
1805                   ((boundp match)                   ((boundp match)
1806                    ;; Variable to be checked.                    ;; Variable to be checked.
1807                    (symbol-value match))))                    (symbol-value match))))
1808                 ((listp match)                 ((listp match)
1809                  ;; This is a form to be evaled.                  (cond
1810                  (eval match)))                   ((eq (car match) 'header)
1811                      ;; New format of header match.
1812                      (and (gnus-buffer-live-p gnus-article-copy)
1813                           (with-current-buffer gnus-article-copy
1814                             (let ((header (message-fetch-field (nth 1 match))))
1815                               (and header
1816                                    (string-match (nth 2 match) header))))))
1817                     (t
1818                      ;; This is a form to be evaled.
1819                      (eval match)))))
1820            ;; We have a match, so we set the variables.            ;; We have a match, so we set the variables.
1821            (dolist (attribute style)            (dolist (attribute style)
1822              (setq element (pop attribute)              (setq element (pop attribute)
                   variable nil  
1823                    filep nil)                    filep nil)
1824              (setq value              (setq value
1825                    (cond                    (cond
# Line 1237  this is a reply." Line 1836  this is a reply."
1836                     ((stringp value)                     ((stringp value)
1837                      value)                      value)
1838                     ((or (symbolp value)                     ((or (symbolp value)
1839                          (gnus-functionp value))                          (functionp value))
1840                      (cond ((gnus-functionp value)                      (cond ((functionp value)
1841                             (funcall value))                             (funcall value))
1842                            ((boundp value)                            ((boundp value)
1843                             (symbol-value value))))                             (symbol-value value))))
1844                     ((listp value)                     ((listp value)
1845                      (eval value))))                      (eval value))))
1846              ;; Translate obsolescent value.              ;; Translate obsolescent value.
1847              (when (eq element 'signature-file)              (cond
1848                 ((eq element 'signature-file)
1849                (setq element 'signature                (setq element 'signature
1850                      filep t))                      filep t))
1851                 ((eq element 'x-face-file)
1852                  (setq element 'x-face
1853                        filep t)))
1854              ;; Get the contents of file elems.              ;; Get the contents of file elems.
1855              (when (and filep v)              (when (and filep v)
1856                (setq v (with-temp-buffer                (setq v (with-temp-buffer
1857                          (insert-file-contents v)                          (insert-file-contents v)
1858                            (goto-char (point-max))
1859                            (while (bolp)
1860                              (delete-char -1))
1861                          (buffer-string))))                          (buffer-string))))
1862              (setq results (delq (assoc element results) results))              (setq results (delq (assoc element results) results))
1863              (push (cons element v) results))))              (push (cons element v) results))))
# Line 1259  this is a reply." Line 1865  this is a reply."
1865        (setq name (assq 'name results)        (setq name (assq 'name results)
1866              address (assq 'address results))              address (assq 'address results))
1867        (setq results (delq name (delq address results)))        (setq results (delq name (delq address results)))
1868        (make-local-variable 'message-setup-hook)        (gnus-make-local-hook 'message-setup-hook)
1869          (setq results (sort results (lambda (x y)
1870                                        (string-lessp (car x) (car y)))))
1871        (dolist (result results)        (dolist (result results)
1872          (add-hook 'message-setup-hook          (add-hook 'message-setup-hook
1873                    (cond                    (cond
# Line 1291  this is a reply." Line 1899  this is a reply."
1899                             (let ((value ,(cdr result)))                             (let ((value ,(cdr result)))
1900                               (when value                               (when value
1901                                 (message-goto-eoh)                                 (message-goto-eoh)
1902                                 (insert ,header ": " value "\n"))))))))))                                 (insert ,header ": " value)
1903                                   (unless (bolp)
1904                                     (insert "\n")))))))))
1905                      nil 'local))
1906        (when (or name address)        (when (or name address)
1907          (add-hook 'message-setup-hook          (add-hook 'message-setup-hook
1908                    `(lambda ()                    `(lambda ()
1909                       (set (make-local-variable 'user-mail-address)                       (set (make-local-variable 'user-mail-address)
1910                            ,(or (cdr address) user-mail-address))                            ,(or (cdr address) user-mail-address))
1911                       (let ((user-full-name ,(or (cdr name) (user-full-name)))                       (let ((user-full-name ,(or (cdr name) (user-full-name)))
1912                             (user-mail-address                             (user-mail-address
1913                              ,(or (cdr address) user-mail-address)))                              ,(or (cdr address) user-mail-address)))
1914                         (save-excursion                         (save-excursion
1915                           (message-remove-header "From")                           (message-remove-header "From")
1916                           (message-goto-eoh)                           (message-goto-eoh)
1917                           (insert "From: " (message-make-from) "\n")))))))))                           (insert "From: " (message-make-from) "\n"))))
1918                      nil 'local)))))
1919    
1920  ;;; Allow redefinition of functions.  ;;; Allow redefinition of functions.
1921    

Legend:
Removed from v.1.19  
changed lines
  Added in v.1.19.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26