/[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.16.4.2 by miles, Tue Oct 14 23:34:50 2003 UTC revision 1.16.4.3 by miles, Thu Sep 16 00:12:16 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                     (if (memq ,config '(reply-yank reply))
399                         (lambda ()
400                           (gnus-configure-posting-styles ,group))
401                       (lambda ()
402                         ;; There may be an old " *gnus article copy*" buffer.
403                         (let (gnus-article-copy)
404                           (gnus-configure-posting-styles ,group)))))
405           (gnus-pull ',(intern gnus-draft-meta-information-header)
406                      message-required-headers)
407           (when (and ,group
408                      (not (string= ,group "")))
409             (push (cons
410                    (intern gnus-draft-meta-information-header)
411                    (gnus-inews-make-draft))
412                   message-required-headers))
413         (unwind-protect         (unwind-protect
414             (progn             (progn
415               ,@forms)               ,@forms)
416           (gnus-inews-add-send-actions ,winconf ,buffer ,article)           (gnus-inews-add-send-actions ,winconf ,buffer ,article ,config
417                                          ,yanked)
418           (setq gnus-message-buffer (current-buffer))           (setq gnus-message-buffer (current-buffer))
419           (set (make-local-variable 'gnus-message-group-art)           (set (make-local-variable 'gnus-message-group-art)
420                (cons ,group ,article))                (cons ,group ,article))
# Line 233  Thank you for your help in stamping out Line 424  Thank you for your help in stamping out
424               (let ((mbl1 mml-buffer-list))               (let ((mbl1 mml-buffer-list))
425                 (setq mml-buffer-list mbl)  ;; Global value                 (setq mml-buffer-list mbl)  ;; Global value
426                 (set (make-local-variable 'mml-buffer-list) mbl1);; Local value                 (set (make-local-variable 'mml-buffer-list) mbl1);; Local value
427                   (gnus-make-local-hook 'kill-buffer-hook)
428                   (gnus-make-local-hook 'change-major-mode-hook)
429                 (add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t)                 (add-hook 'change-major-mode-hook 'mml-destroy-buffers nil t)
430                 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))                 (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))
431             (mml-destroy-buffers)             (mml-destroy-buffers)
432             (setq mml-buffer-list mbl)))             (setq mml-buffer-list mbl)))
433           (message-hide-headers)
434         (gnus-add-buffer)         (gnus-add-buffer)
435         (gnus-configure-windows ,config t)         (gnus-configure-windows ,config t)
436           (run-hooks 'post-command-hook)
437         (set-buffer-modified-p nil))))         (set-buffer-modified-p nil))))
438    
439    (defun gnus-inews-make-draft-meta-information (group article)
440      (concat "(\"" group "\" "
441              (if article (number-to-string
442                           (if (listp article)
443                               (car article)
444                             article)) "\"\"")
445              ")"))
446    
447  ;;;###autoload  ;;;###autoload
448  (defun gnus-msg-mail (&rest args)  (defun gnus-msg-mail (&optional to subject other-headers continue
449                                    switch-action yank-action send-actions)
450    "Start editing a mail message to be sent.    "Start editing a mail message to be sent.
451  Like `message-mail', but with Gnus paraphernalia, particularly the  Like `message-mail', but with Gnus paraphernalia, particularly the
452  Gcc: header for archiving purposes."  Gcc: header for archiving purposes."
453    (interactive)    (interactive)
454    (gnus-setup-message 'message    (let ((buf (current-buffer))
455      (apply 'message-mail args))          mail-buf)
456        (gnus-setup-message 'message
457          (message-mail to subject other-headers continue
458                        nil yank-action send-actions))
459        (when switch-action
460          (setq mail-buf (current-buffer))
461          (switch-to-buffer buf)
462          (apply switch-action mail-buf nil)))
463    ;; COMPOSEFUNC should return t if succeed.  Undocumented ???    ;; COMPOSEFUNC should return t if succeed.  Undocumented ???
464    t)    t)
465    
466    (defvar save-selected-window-window)
467    
468    ;;;###autoload
469    (defun gnus-button-mailto (address)
470      "Mail to ADDRESS."
471      (set-buffer (gnus-copy-article-buffer))
472      (gnus-setup-message 'message
473        (message-reply address))
474      (and (boundp 'save-selected-window-window)
475           (not (window-live-p save-selected-window-window))
476           (setq save-selected-window-window (selected-window))))
477    
478    ;;;###autoload
479    (defun gnus-button-reply (&optional to-address wide)
480      "Like `message-reply'."
481      (interactive)
482      (gnus-setup-message 'message
483        (message-reply to-address wide))
484      (and (boundp 'save-selected-window-window)
485           (not (window-live-p save-selected-window-window))
486           (setq save-selected-window-window (selected-window))))
487    
488  ;;;###autoload  ;;;###autoload
489  (define-mail-user-agent 'gnus-user-agent  (define-mail-user-agent 'gnus-user-agent
490        'gnus-msg-mail 'message-send-and-exit    'gnus-msg-mail 'message-send-and-exit
491        'message-kill-buffer 'message-send-hook)    'message-kill-buffer 'message-send-hook)
492    
493  (defun gnus-setup-posting-charset (group)  (defun gnus-setup-posting-charset (group)
494    (let ((alist gnus-group-posting-charset-alist)    (let ((alist gnus-group-posting-charset-alist)
# Line 266  Gcc: header for archiving purposes." Line 499  Gcc: header for archiving purposes."
499          (while (setq elem (pop alist))          (while (setq elem (pop alist))
500            (when (or (and (stringp (car elem))            (when (or (and (stringp (car elem))
501                           (string-match (car elem) group))                           (string-match (car elem) group))
502                      (and (gnus-functionp (car elem))                      (and (functionp (car elem))
503                           (funcall (car elem) group))                           (funcall (car elem) group))
504                      (and (symbolp (car elem))                      (and (symbolp (car elem))
505                           (symbol-value (car elem))))                           (symbol-value (car elem))))
506              (throw 'found (cons (cadr elem) (caddr elem)))))))))              (throw 'found (cons (cadr elem) (caddr elem)))))))))
507    
508  (defun gnus-inews-add-send-actions (winconf buffer article)  (defun gnus-inews-add-send-actions (winconf buffer article
509    (make-local-hook 'message-sent-hook)                                              &optional config yanked)
510      (gnus-make-local-hook 'message-sent-hook)
511    (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
512                                   'gnus-inews-do-gcc) nil t)                                   'gnus-inews-do-gcc) nil t)
513    (when gnus-agent    (when gnus-agent
514      (make-local-hook 'message-header-hook)      (gnus-make-local-hook 'message-header-hook)
515      (add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t))      (add-hook 'message-header-hook 'gnus-agent-possibly-save-gcc nil t))
516    (setq message-post-method    (setq message-post-method
517          `(lambda (arg)          `(lambda (arg)
518             (gnus-post-method arg ,gnus-newsgroup-name)))             (gnus-post-method arg ,gnus-newsgroup-name)))
519    (setq message-newsreader (setq message-mailer (gnus-extended-version)))    (setq message-newsreader (setq message-mailer (gnus-extended-version)))
520    (message-add-action    (message-add-action
    `(set-window-configuration ,winconf) 'exit 'postpone 'kill)  
   (message-add-action  
521     `(when (gnus-buffer-exists-p ,buffer)     `(when (gnus-buffer-exists-p ,buffer)
522        (save-excursion        (set-window-configuration ,winconf))
523          (set-buffer ,buffer)     'exit 'postpone 'kill)
524          ,(when article    (let ((to-be-marked (cond
525             `(gnus-summary-mark-article-as-replied ,article))))                         (yanked
526     'send))                          (mapcar
527                             (lambda (x) (if (listp x) (car x) x)) yanked))
528                           (article (if (listp article) article (list article)))
529                           (t nil))))
530        (message-add-action
531         `(when (gnus-buffer-exists-p ,buffer)
532            (save-excursion
533              (set-buffer ,buffer)
534              ,(when to-be-marked
535                 (if (eq config 'forward)
536                     `(gnus-summary-mark-article-as-forwarded ',to-be-marked)
537                   `(gnus-summary-mark-article-as-replied ',to-be-marked)))))
538         'send)))
539    
540  (put 'gnus-setup-message 'lisp-indent-function 1)  (put 'gnus-setup-message 'lisp-indent-function 1)
541  (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 550  If ARG is 1, prompt for a group name to
550    ;; We can't `let' gnus-newsgroup-name here, since that leads    ;; We can't `let' gnus-newsgroup-name here, since that leads
551    ;; to local variables leaking.    ;; to local variables leaking.
552    (let ((group gnus-newsgroup-name)    (let ((group gnus-newsgroup-name)
553            ;; make sure last viewed article doesn't affect posting styles:
554            (gnus-article-copy)
555          (buffer (current-buffer)))          (buffer (current-buffer)))
556      (unwind-protect      (unwind-protect
557          (progn          (progn
# Line 317  If ARG is 1, prompt for a group name to Line 563  If ARG is 1, prompt for a group name to
563                                           (gnus-read-active-file-p))                                           (gnus-read-active-file-p))
564                        (gnus-group-group-name))                        (gnus-group-group-name))
565                    ""))                    ""))
566              ;; #### see comment in gnus-setup-message -- drv
567            (gnus-setup-message 'message (message-mail)))            (gnus-setup-message 'message (message-mail)))
568        (save-excursion        (save-excursion
569          (set-buffer buffer)          (set-buffer buffer)
570          (setq gnus-newsgroup-name group)))))          (setq gnus-newsgroup-name group)))))
571    
572    (defun gnus-group-news (&optional arg)
573      "Start composing a news.
574    If ARG, post to group under point.
575    If ARG is 1, prompt for group name to post to.
576    
577    This function prepares a news even when using mail groups.  This is useful
578    for posting messages to mail groups without actually sending them over the
579    network.  The corresponding back end must have a 'request-post method."
580      (interactive "P")
581      ;; We can't `let' gnus-newsgroup-name here, since that leads
582      ;; to local variables leaking.
583      (let ((group gnus-newsgroup-name)
584            ;; make sure last viewed article doesn't affect posting styles:
585            (gnus-article-copy)
586            (buffer (current-buffer)))
587        (unwind-protect
588            (progn
589              (setq gnus-newsgroup-name
590                    (if arg
591                        (if (= 1 (prefix-numeric-value arg))
592                            (completing-read "Use group: "
593                                             gnus-active-hashtb nil
594                                             (gnus-read-active-file-p))
595                          (gnus-group-group-name))
596                      ""))
597              ;; #### see comment in gnus-setup-message -- drv
598              (gnus-setup-message 'message
599                (message-news (gnus-group-real-name gnus-newsgroup-name))))
600          (save-excursion
601            (set-buffer buffer)
602            (setq gnus-newsgroup-name group)))))
603    
604  (defun gnus-group-post-news (&optional arg)  (defun gnus-group-post-news (&optional arg)
605    "Start composing a news message.    "Start composing a message (a news by default).
606  If ARG, post to the group under point.  If ARG, post to group under point.  If ARG is 1, prompt for group name.
607  If ARG is 1, prompt for a group name."  Depending on the selected group, the message might be either a mail or
608    a news."
609    (interactive "P")    (interactive "P")
610    ;; Bind this variable here to make message mode hooks work ok.    ;; Bind this variable here to make message mode hooks work ok.
611    (let ((gnus-newsgroup-name    (let ((gnus-newsgroup-name
# Line 334  If ARG is 1, prompt for a group name." Line 614  If ARG is 1, prompt for a group name."
614                   (completing-read "Newsgroup: " gnus-active-hashtb nil                   (completing-read "Newsgroup: " gnus-active-hashtb nil
615                                    (gnus-read-active-file-p))                                    (gnus-read-active-file-p))
616                 (gnus-group-group-name))                 (gnus-group-group-name))
617             "")))             ""))
618            ;; make sure last viewed article doesn't affect posting styles:
619            (gnus-article-copy))
620        (gnus-post-news 'post gnus-newsgroup-name nil nil nil nil
621                        (string= gnus-newsgroup-name ""))))
622    
623    (defun gnus-summary-mail-other-window (&optional arg)
624      "Start composing a mail in another window.
625    Use the posting of the current group by default.
626    If ARG, don't do that.  If ARG is 1, prompt for group name to find the
627    posting style."
628      (interactive "P")
629      ;; We can't `let' gnus-newsgroup-name here, since that leads
630      ;; to local variables leaking.
631      (let ((group gnus-newsgroup-name)
632            ;; make sure last viewed article doesn't affect posting styles:
633            (gnus-article-copy)
634            (buffer (current-buffer)))
635        (unwind-protect
636            (progn
637              (setq gnus-newsgroup-name
638                    (if arg
639                        (if (= 1 (prefix-numeric-value arg))
640                            (completing-read "Use group: "
641                                             gnus-active-hashtb nil
642                                             (gnus-read-active-file-p))
643                          "")
644                      gnus-newsgroup-name))
645              ;; #### see comment in gnus-setup-message -- drv
646              (gnus-setup-message 'message (message-mail)))
647          (save-excursion
648            (set-buffer buffer)
649            (setq gnus-newsgroup-name group)))))
650    
651    (defun gnus-summary-news-other-window (&optional arg)
652      "Start composing a news in another window.
653    Post to the current group by default.
654    If ARG, don't do that.  If ARG is 1, prompt for group name to post to.
655    
656    This function prepares a news even when using mail groups.  This is useful
657    for posting messages to mail groups without actually sending them over the
658    network.  The corresponding back end must have a 'request-post method."
659      (interactive "P")
660      ;; We can't `let' gnus-newsgroup-name here, since that leads
661      ;; to local variables leaking.
662      (let ((group gnus-newsgroup-name)
663            ;; make sure last viewed article doesn't affect posting styles:
664            (gnus-article-copy)
665            (buffer (current-buffer)))
666        (unwind-protect
667            (progn
668              (setq gnus-newsgroup-name
669                    (if arg
670                        (if (= 1 (prefix-numeric-value arg))
671                            (completing-read "Use group: "
672                                             gnus-active-hashtb nil
673                                             (gnus-read-active-file-p))
674                          "")
675                      gnus-newsgroup-name))
676              ;; #### see comment in gnus-setup-message -- drv
677              (gnus-setup-message 'message
678                (progn
679                  (message-news (gnus-group-real-name gnus-newsgroup-name))
680                  (set (make-local-variable 'gnus-discouraged-post-methods)
681                       (delq
682                        (car (gnus-find-method-for-group gnus-newsgroup-name))
683                        (copy-sequence gnus-discouraged-post-methods))))))
684          (save-excursion
685            (set-buffer buffer)
686            (setq gnus-newsgroup-name group)))))
687    
688    (defun gnus-summary-post-news (&optional arg)
689      "Start composing a message.  Post to the current group by default.
690    If ARG, don't do that.  If ARG is 1, prompt for a group name to post to.
691    Depending on the selected group, the message might be either a mail or
692    a news."
693      (interactive "P")
694      ;; Bind this variable here to make message mode hooks work ok.
695      (let ((gnus-newsgroup-name
696             (if arg
697                 (if (= 1 (prefix-numeric-value arg))
698                     (completing-read "Newsgroup: " gnus-active-hashtb nil
699                                      (gnus-read-active-file-p))
700                   "")
701               gnus-newsgroup-name))
702            ;; make sure last viewed article doesn't affect posting styles:
703            (gnus-article-copy))
704      (gnus-post-news 'post gnus-newsgroup-name)))      (gnus-post-news 'post gnus-newsgroup-name)))
705    
 (defun gnus-summary-post-news ()  
   "Start composing a news message."  
   (interactive)  
   (gnus-post-news 'post gnus-newsgroup-name))  
706    
707  (defun gnus-summary-followup (yank &optional force-news)  (defun gnus-summary-followup (yank &optional force-news)
708    "Compose a followup to an article.    "Compose a followup to an article.
709  If prefix argument YANK is non-nil, original article is yanked automatically."  If prefix argument YANK is non-nil, the original article is yanked
710    automatically.
711    YANK is a list of elements, where the car of each element is the
712    article number, and the cdr is the string to be yanked."
713    (interactive    (interactive
714     (list (and current-prefix-arg     (list (and current-prefix-arg
715                (gnus-summary-work-articles 1))))                (gnus-summary-work-articles 1))))
716    (when yank    (when yank
717      (gnus-summary-goto-subject (car yank)))      (gnus-summary-goto-subject
718         (if (listp (car yank))
719             (caar yank)
720           (car yank))))
721    (save-window-excursion    (save-window-excursion
722      (gnus-summary-select-article))      (gnus-summary-select-article))
723    (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 725  If prefix argument YANK is non-nil, orig
725      ;; Send a followup.      ;; Send a followup.
726      (gnus-post-news nil gnus-newsgroup-name      (gnus-post-news nil gnus-newsgroup-name
727                      headers gnus-article-buffer                      headers gnus-article-buffer
728                      yank nil force-news)))                      yank nil force-news)
729        (gnus-summary-handle-replysign)))
730    
731  (defun gnus-summary-followup-with-original (n &optional force-news)  (defun gnus-summary-followup-with-original (n &optional force-news)
732    "Compose a followup to an article and include the original article."    "Compose a followup to an article and include the original article.
733    The text in the region will be yanked.  If the region isn't
734    active, the entire article will be yanked."
735    (interactive "P")    (interactive "P")
736    (gnus-summary-followup (gnus-summary-work-articles n) force-news))    (gnus-summary-followup (gnus-summary-work-articles n) force-news))
737    
# Line 377  If prefix argument YANK is non-nil, orig Line 748  If prefix argument YANK is non-nil, orig
748    (gnus-summary-followup (gnus-summary-work-articles arg) t))    (gnus-summary-followup (gnus-summary-work-articles arg) t))
749    
750  (defun gnus-inews-yank-articles (articles)  (defun gnus-inews-yank-articles (articles)
751    (let (beg article)    (let (beg article yank-string)
752      (message-goto-body)      (message-goto-body)
753      (while (setq article (pop articles))      (while (setq article (pop articles))
754          (when (listp article)
755            (setq yank-string (nth 1 article)
756                  article (nth 0 article)))
757        (save-window-excursion        (save-window-excursion
758          (set-buffer gnus-summary-buffer)          (set-buffer gnus-summary-buffer)
759          (gnus-summary-select-article nil nil nil article)          (gnus-summary-select-article nil nil nil article)
760          (gnus-summary-remove-process-mark article))          (gnus-summary-remove-process-mark article))
761        (gnus-copy-article-buffer)        (gnus-copy-article-buffer nil yank-string)
762        (let ((message-reply-buffer gnus-article-copy)        (let ((message-reply-buffer gnus-article-copy)
763              (message-reply-headers gnus-current-headers))              (message-reply-headers
764                 ;; The headers are decoded.
765                 (with-current-buffer gnus-article-copy
766                   (save-restriction
767                     (nnheader-narrow-to-headers)
768                     (nnheader-parse-naked-head)))))
769          (message-yank-original)          (message-yank-original)
770          (setq beg (or beg (mark t))))          (setq beg (or beg (mark t))))
771        (when articles        (when articles
# Line 403  post using the current select method." Line 782  post using the current select method."
782    (let ((articles (gnus-summary-work-articles n))    (let ((articles (gnus-summary-work-articles n))
783          (message-post-method          (message-post-method
784           `(lambda (arg)           `(lambda (arg)
785              (gnus-post-method (not (eq symp 'a)) ,gnus-newsgroup-name)))              (gnus-post-method (eq ',symp 'a) ,gnus-newsgroup-name)))
786          article)          article)
787      (while (setq article (pop articles))      (while (setq article (pop articles))
788        (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 814  header line with the old Message-ID."
814    
815    
816    
817  (defun gnus-copy-article-buffer (&optional article-buffer)  (defun gnus-copy-article-buffer (&optional article-buffer yank-string)
818    ;; make a copy of the article buffer with all text properties removed    ;; make a copy of the article buffer with all text properties removed
819    ;; this copy is in the buffer gnus-article-copy.    ;; this copy is in the buffer gnus-article-copy.
820    ;; 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 830  header line with the old Message-ID."
830          (error "Can't find any article buffer")          (error "Can't find any article buffer")
831        (save-excursion        (save-excursion
832          (set-buffer article-buffer)          (set-buffer article-buffer)
833          (save-restriction          (let ((gnus-newsgroup-charset (or gnus-article-charset
834            ;; Copy over the (displayed) article buffer, delete                                            gnus-newsgroup-charset))
835            ;; hidden text and remove text properties.                (gnus-newsgroup-ignored-charsets
836            (widen)                 (or gnus-article-ignored-charsets
837            (copy-to-buffer gnus-article-copy (point-min) (point-max))                     gnus-newsgroup-ignored-charsets)))
838            (set-buffer gnus-article-copy)            (save-restriction
839            (gnus-article-delete-text-of-type 'annotation)              ;; Copy over the (displayed) article buffer, delete
840            (gnus-remove-text-with-property 'gnus-prev)              ;; hidden text and remove text properties.
841            (gnus-remove-text-with-property 'gnus-next)              (widen)
842            (insert              (copy-to-buffer gnus-article-copy (point-min) (point-max))
843             (prog1              (set-buffer gnus-article-copy)
844                 (buffer-substring-no-properties (point-min) (point-max))              (when yank-string
845               (erase-buffer)))                (message-goto-body)
846            ;; Find the original headers.                (delete-region (point) (point-max))
847            (set-buffer gnus-original-article-buffer)                (insert yank-string))
848            (goto-char (point-min))              (gnus-article-delete-text-of-type 'annotation)
849            (while (looking-at message-unix-mail-delimiter)              (gnus-remove-text-with-property 'gnus-prev)
850              (forward-line 1))              (gnus-remove-text-with-property 'gnus-next)
851            (setq beg (point))              (gnus-remove-text-with-property 'gnus-decoration)
852            (setq end (or (search-forward "\n\n" nil t) (point)))              (insert
853            ;; Delete the headers from the displayed articles.               (prog1
854            (set-buffer gnus-article-copy)                   (buffer-substring-no-properties (point-min) (point-max))
855            (delete-region (goto-char (point-min))                 (erase-buffer)))
856                           (or (search-forward "\n\n" nil t) (point-max)))              ;; Find the original headers.
857            ;; Insert the original article headers.              (set-buffer gnus-original-article-buffer)
858            (insert-buffer-substring gnus-original-article-buffer beg end)              (goto-char (point-min))
859            (article-decode-encoded-words)))              (while (looking-at message-unix-mail-delimiter)
860                  (forward-line 1))
861                (let ((mail-header-separator ""))
862                  (setq beg (point)
863                        end (or (message-goto-body)
864                                ;; There may be just a header.
865                                (point-max))))
866                ;; Delete the headers from the displayed articles.
867                (set-buffer gnus-article-copy)
868                (let ((mail-header-separator ""))
869                  (delete-region (goto-char (point-min))
870                                 (or (message-goto-body) (point-max))))
871                ;; Insert the original article headers.
872                (insert-buffer-substring gnus-original-article-buffer beg end)
873                ;; Decode charsets.
874                (let ((gnus-article-decode-hook
875                       (delq 'article-decode-charset
876                             (copy-sequence gnus-article-decode-hook))))
877                  (run-hooks 'gnus-article-decode-hook)))))
878        gnus-article-copy)))        gnus-article-copy)))
879    
880  (defun gnus-post-news (post &optional group header article-buffer yank subject  (defun gnus-post-news (post &optional group header article-buffer yank subject
881                              force-news)                              force-news)
882    (when article-buffer    (when article-buffer
883      (gnus-copy-article-buffer))      (gnus-copy-article-buffer))
884    (let ((gnus-article-reply article-buffer)    (let ((gnus-article-reply (and article-buffer (gnus-summary-article-number)))
885            (gnus-article-yanked-articles yank)
886          (add-to-list gnus-add-to-list))          (add-to-list gnus-add-to-list))
887      (gnus-setup-message (cond (yank 'reply-yank)      (gnus-setup-message (cond (yank 'reply-yank)
888                                (article-buffer 'reply)                                (article-buffer 'reply)
# Line 495  header line with the old Message-ID." Line 893  header line with the old Message-ID."
893               to-address to-group mailing-list to-list               to-address to-group mailing-list to-list
894               newsgroup-p)               newsgroup-p)
895          (when group          (when group
896            (setq to-address (gnus-group-find-parameter group 'to-address)            (setq to-address (gnus-parameter-to-address group)
897                  to-group (gnus-group-find-parameter group 'to-group)                  to-group (gnus-group-find-parameter group 'to-group)
898                  to-list (gnus-group-find-parameter group 'to-list)                  to-list (gnus-parameter-to-list group)
899                  newsgroup-p (gnus-group-find-parameter group 'newsgroup)                  newsgroup-p (gnus-group-find-parameter group 'newsgroup)
900                  mailing-list (when gnus-mailing-list-groups                  mailing-list (when gnus-mailing-list-groups
901                                 (string-match gnus-mailing-list-groups group))                                 (string-match gnus-mailing-list-groups group))
# Line 509  header line with the old Message-ID." Line 907  header line with the old Message-ID."
907                  force-news                  force-news
908                  (and (gnus-news-group-p                  (and (gnus-news-group-p
909                        (or pgroup gnus-newsgroup-name)                        (or pgroup gnus-newsgroup-name)
910                        (if header (mail-header-number header)                        (or header gnus-current-article))
                         gnus-current-article))  
911                       (not mailing-list)                       (not mailing-list)
912                       (not to-list)                       (not to-list)
913                       (not to-address)))                       (not to-address)))
# Line 519  header line with the old Message-ID." Line 916  header line with the old Message-ID."
916                  (message-news (or to-group group))                  (message-news (or to-group group))
917                (set-buffer gnus-article-copy)                (set-buffer gnus-article-copy)
918                (gnus-msg-treat-broken-reply-to)                (gnus-msg-treat-broken-reply-to)
919                (message-followup (if (or newsgroup-p force-news) nil to-group)))                (message-followup (if (or newsgroup-p force-news)
920                                        (if (save-restriction
921                                              (article-narrow-to-head)
922                                              (message-fetch-field "newsgroups"))
923                                            nil
924                                          "")
925                                      to-group)))
926            ;; The is mail.            ;; The is mail.
927            (if post            (if post
928                (progn                (progn
# Line 537  header line with the old Message-ID." Line 940  header line with the old Message-ID."
940          (when yank          (when yank
941            (gnus-inews-yank-articles yank))))))            (gnus-inews-yank-articles yank))))))
942    
943  (defun gnus-msg-treat-broken-reply-to ()  (defun gnus-msg-treat-broken-reply-to (&optional force)
944    "Remove the Reply-to header if broken-reply-to."    "Remove the Reply-to header if broken-reply-to."
945    (when (gnus-group-find-parameter    (when (or force
946           gnus-newsgroup-name 'broken-reply-to)              (gnus-group-find-parameter
947                 gnus-newsgroup-name 'broken-reply-to))
948      (save-restriction      (save-restriction
949        (message-narrow-to-head)        (message-narrow-to-head)
950        (message-remove-header "reply-to"))))        (message-remove-header "reply-to"))))
# Line 548  header line with the old Message-ID." Line 952  header line with the old Message-ID."
952  (defun gnus-post-method (arg group &optional silent)  (defun gnus-post-method (arg group &optional silent)
953    "Return the posting method based on GROUP and ARG.    "Return the posting method based on GROUP and ARG.
954  If SILENT, don't prompt the user."  If SILENT, don't prompt the user."
955    (let ((group-method (gnus-find-method-for-group group)))    (let ((gnus-post-method (or (gnus-parameter-post-method group)
956                                  gnus-post-method))
957            (group-method (gnus-find-method-for-group group)))
958      (cond      (cond
959       ;; If the group-method is nil (which shouldn't happen) we use       ;; If the group-method is nil (which shouldn't happen) we use
960       ;; the default method.       ;; the default method.
961       ((null group-method)       ((null group-method)
962        (or (and (null (eq gnus-post-method 'active)) gnus-post-method)        (or (and (listp gnus-post-method) ;If not current/native/nil
963            gnus-select-method message-post-method))                 (not (listp (car gnus-post-method))) ; and not a list of methods
964                   gnus-post-method)        ;then use it.
965              gnus-select-method
966              message-post-method))
967       ;; We want the inverse of the default       ;; We want the inverse of the default
968       ((and arg (not (eq arg 0)))       ((and arg (not (eq arg 0)))
969        (if (eq gnus-post-method 'active)        (if (eq gnus-post-method 'current)
970            gnus-select-method            gnus-select-method
971          group-method))          group-method))
972       ;; We query the user for a post method.       ;; We query the user for a post method.
973       ((or arg       ((or arg
974            (and gnus-post-method            (and (listp gnus-post-method)
                (not (eq gnus-post-method 'current))  
975                 (listp (car gnus-post-method))))                 (listp (car gnus-post-method))))
976        (let* ((methods        (let* ((methods
977                ;; Collect all methods we know about.                ;; Collect all methods we know about.
978                (append                (append
979                 (when (and gnus-post-method                 (when (listp gnus-post-method)
                           (not (eq gnus-post-method 'current)))  
980                   (if (listp (car gnus-post-method))                   (if (listp (car gnus-post-method))
981                       gnus-post-method                       gnus-post-method
982                     (list gnus-post-method)))                     (list gnus-post-method)))
# Line 590  If SILENT, don't prompt the user." Line 997  If SILENT, don't prompt the user."
997          (setq method-alist          (setq method-alist
998                (mapcar                (mapcar
999                 (lambda (m)                 (lambda (m)
1000                   (list (concat (cadr m) " (" (symbol-name (car m)) ")") m))                   (if (equal (cadr m) "")
1001                         (list (symbol-name (car m)) m)
1002                       (list (concat (cadr m) " (" (symbol-name (car m)) ")") m)))
1003                 post-methods))                 post-methods))
1004          ;; Query the user.          ;; Query the user.
1005          (cadr          (cadr
# Line 606  If SILENT, don't prompt the user." Line 1015  If SILENT, don't prompt the user."
1015            method-alist))))            method-alist))))
1016       ;; Override normal method.       ;; Override normal method.
1017       ((and (eq gnus-post-method 'current)       ((and (eq gnus-post-method 'current)
1018             (not (eq (car group-method) 'nndraft))             (not (memq (car group-method) gnus-discouraged-post-methods))
1019             (gnus-get-function group-method 'request-post t)             (gnus-get-function group-method 'request-post t))
1020             (not arg))        (assert (not arg))
1021        group-method)        group-method)
1022       ((and gnus-post-method       ;; Use gnus-post-method.
1023             (not (eq gnus-post-method 'current)))       ((listp gnus-post-method)          ;A method...
1024          (assert (not (listp (car gnus-post-method)))) ;... not a list of methods.
1025        gnus-post-method)        gnus-post-method)
1026       ;; Use the normal select method.       ;; Use the normal select method (nil or native).
1027       (t gnus-select-method))))       (t gnus-select-method))))
1028    
1029    
1030    
 ;; Dummies to avoid byte-compile warning.  
 (eval-when-compile  
   (defvar nnspool-rejected-article-hook)  
   (defvar xemacs-codename))  
   
1031  (defun gnus-extended-version ()  (defun gnus-extended-version ()
1032    "Stringified Gnus version and Emacs version."    "Stringified Gnus version and Emacs version.
1033    See the variable `gnus-user-agent'."
1034    (interactive)    (interactive)
1035    (concat    (let* ((float-output-format nil)
1036     "Gnus/" (prin1-to-string (gnus-continuum-version gnus-version) t)           (gnus-v
1037     " (" gnus-version ")"            (concat "Gnus/"
1038     " "                    (prin1-to-string (gnus-continuum-version gnus-version) t)
1039     (cond                    " (" gnus-version ")"))
1040      ((string-match "^\\(\\([.0-9]+\\)*\\)\\.[0-9]+$" emacs-version)           (emacs-v (gnus-emacs-version)))
1041       (concat "Emacs/" (match-string 1 emacs-version)))      (if (stringp gnus-user-agent)
1042      ((string-match "\\([A-Z]*[Mm][Aa][Cc][Ss]\\)[^(]*\\(\\((beta.*)\\|'\\)\\)?"          gnus-user-agent
1043                     emacs-version)        (concat gnus-v
1044       (concat (match-string 1 emacs-version)                (when emacs-v
1045               (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))))  
1046    
1047    
1048  ;;;  ;;;
# Line 652  If SILENT, don't prompt the user." Line 1051  If SILENT, don't prompt the user."
1051    
1052  ;;; Mail reply commands of Gnus summary mode  ;;; Mail reply commands of Gnus summary mode
1053    
1054  (defun gnus-summary-reply (&optional yank wide)  (defun gnus-summary-reply (&optional yank wide very-wide)
1055    "Start composing a reply mail to the current message.    "Start composing a mail reply to the current message.
1056  If prefix argument YANK is non-nil, the original article is yanked  If prefix argument YANK is non-nil, the original article is yanked
1057  automatically."  automatically.
1058    If WIDE, make a wide reply.
1059    If VERY-WIDE, make a very wide reply."
1060    (interactive    (interactive
1061     (list (and current-prefix-arg     (list (and current-prefix-arg
1062                (gnus-summary-work-articles 1))))                (gnus-summary-work-articles 1))))
1063    ;; Stripping headers should be specified with mail-yank-ignored-headers.    ;; Allow user to require confirmation before replying by mail to the
1064    (when yank    ;; author of a news article (or mail message).
1065      (gnus-summary-goto-subject (car yank)))    (when (or
1066    (let ((gnus-article-reply t))              (not (or (gnus-news-group-p gnus-newsgroup-name)
1067      (gnus-setup-message (if yank 'reply-yank 'reply)                       gnus-confirm-treat-mail-like-news))
1068        (gnus-summary-select-article)              (not (cond ((stringp gnus-confirm-mail-reply-to-news)
1069        (set-buffer (gnus-copy-article-buffer))                          (string-match gnus-confirm-mail-reply-to-news
1070        (gnus-msg-treat-broken-reply-to)                                        gnus-newsgroup-name))
1071        (save-restriction                         ((functionp gnus-confirm-mail-reply-to-news)
1072          (message-narrow-to-head)                          (funcall gnus-confirm-mail-reply-to-news gnus-newsgroup-name))
1073          (goto-char (point-max)))                         (t gnus-confirm-mail-reply-to-news)))
1074        (mml-quote-region (point) (point-max))              (y-or-n-p "Really reply by mail to article author? "))
1075        (message-reply nil wide)      (let* ((article
1076                (if (listp (car yank))
1077                    (caar yank)
1078                  (car yank)))
1079               (gnus-article-reply (or article (gnus-summary-article-number)))
1080               (gnus-article-yanked-articles yank)
1081               (headers ""))
1082          ;; Stripping headers should be specified with mail-yank-ignored-headers.
1083        (when yank        (when yank
1084          (gnus-inews-yank-articles yank)))))          (gnus-summary-goto-subject article))
1085          (gnus-setup-message (if yank 'reply-yank 'reply)
1086            (if (not very-wide)
1087                (gnus-summary-select-article)
1088              (dolist (article very-wide)
1089                (gnus-summary-select-article nil nil nil article)
1090                (save-excursion
1091                  (set-buffer (gnus-copy-article-buffer))
1092                  (gnus-msg-treat-broken-reply-to)
1093                  (save-restriction
1094                    (message-narrow-to-head)
1095                    (setq headers (concat headers (buffer-string)))))))
1096            (set-buffer (gnus-copy-article-buffer))
1097            (gnus-msg-treat-broken-reply-to gnus-msg-force-broken-reply-to)
1098            (save-restriction
1099              (message-narrow-to-head)
1100              (when very-wide
1101                (erase-buffer)
1102                (insert headers))
1103              (goto-char (point-max)))
1104            (mml-quote-region (point) (point-max))
1105            (message-reply nil wide)
1106            (when yank
1107              (gnus-inews-yank-articles yank))
1108            (gnus-summary-handle-replysign)))))
1109    
1110    (defun gnus-summary-handle-replysign ()
1111      "Check the various replysign variables and take action accordingly."
1112      (when (or gnus-message-replysign gnus-message-replyencrypt)
1113        (let (signed encrypted)
1114          (save-excursion
1115            (set-buffer gnus-article-buffer)
1116            (setq signed (memq 'signed gnus-article-wash-types))
1117            (setq encrypted (memq 'encrypted gnus-article-wash-types)))
1118          (cond ((and gnus-message-replyencrypt encrypted)
1119                 (mml-secure-message mml-default-encrypt-method
1120                                     (if gnus-message-replysignencrypted
1121                                         'signencrypt
1122                                       'encrypt)))
1123                ((and gnus-message-replysign signed)
1124                 (mml-secure-message mml-default-sign-method 'sign))))))
1125    
1126  (defun gnus-summary-reply-with-original (n &optional wide)  (defun gnus-summary-reply-with-original (n &optional wide)
1127    "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 1129  The original article will be yanked."
1129    (interactive "P")    (interactive "P")
1130    (gnus-summary-reply (gnus-summary-work-articles n) wide))    (gnus-summary-reply (gnus-summary-work-articles n) wide))
1131    
1132    (defun gnus-summary-reply-broken-reply-to (&optional yank wide very-wide)
1133      "Like `gnus-summary-reply' except removing reply-to field.
1134    If prefix argument YANK is non-nil, the original article is yanked
1135    automatically.
1136    If WIDE, make a wide reply.
1137    If VERY-WIDE, make a very wide reply."
1138      (interactive
1139       (list (and current-prefix-arg
1140                  (gnus-summary-work-articles 1))))
1141      (let ((gnus-msg-force-broken-reply-to t))
1142        (gnus-summary-reply yank wide very-wide)))
1143    
1144    (defun gnus-summary-reply-broken-reply-to-with-original (n &optional wide)
1145      "Like `gnus-summary-reply-with-original' except removing reply-to field.
1146    The original article will be yanked."
1147      (interactive "P")
1148      (gnus-summary-reply-broken-reply-to (gnus-summary-work-articles n) wide))
1149    
1150  (defun gnus-summary-wide-reply (&optional yank)  (defun gnus-summary-wide-reply (&optional yank)
1151    "Start composing a wide reply mail to the current message.    "Start composing a wide reply mail to the current message.
1152  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 1158  automatically."
1158    
1159  (defun gnus-summary-wide-reply-with-original (n)  (defun gnus-summary-wide-reply-with-original (n)
1160    "Start composing a wide reply mail to the current message.    "Start composing a wide reply mail to the current message.
1161  The original article will be yanked."  The original article will be yanked.
1162    Uses the process/prefix convention."
1163    (interactive "P")    (interactive "P")
1164    (gnus-summary-reply-with-original n t))    (gnus-summary-reply-with-original n t))
1165    
1166    (defun gnus-summary-very-wide-reply (&optional yank)
1167      "Start composing a very wide reply mail to the current message.
1168    If prefix argument YANK is non-nil, the original article is yanked
1169    automatically."
1170      (interactive
1171       (list (and current-prefix-arg
1172                  (gnus-summary-work-articles 1))))
1173      (gnus-summary-reply yank t (gnus-summary-work-articles yank)))
1174    
1175    (defun gnus-summary-very-wide-reply-with-original (n)
1176      "Start composing a very wide reply mail to the current message.
1177    The original article will be yanked."
1178      (interactive "P")
1179      (gnus-summary-reply
1180       (gnus-summary-work-articles n) t (gnus-summary-work-articles n)))
1181    
1182  (defun gnus-summary-mail-forward (&optional arg post)  (defun gnus-summary-mail-forward (&optional arg post)
1183    "Forward the current message to another user.    "Forward the current message(s) to another user.
1184  If ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml';  If process marks exist, forward all marked messages;
1185    if ARG is nil, see `message-forward-as-mime' and `message-forward-show-mml';
1186  if ARG is 1, decode the message and forward directly inline;  if ARG is 1, decode the message and forward directly inline;
1187  if ARG is 2, forward message as an rfc822 MIME section;  if ARG is 2, forward message as an rfc822 MIME section;
1188  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;
1189  if ARG is 4, forward message directly inline;  if ARG is 4, forward message directly inline;
1190  otherwise, use flipped `message-forward-as-mime'.  otherwise, use flipped `message-forward-as-mime'.
1191  If POST, post instead of mail."  If POST, post instead of mail.
1192    For the `inline' alternatives, also see the variable
1193    `message-forward-ignored-headers'."
1194    (interactive "P")    (interactive "P")
1195    (let ((message-forward-as-mime message-forward-as-mime)    (if (cdr (gnus-summary-work-articles nil))
1196          (message-forward-show-mml message-forward-show-mml))        ;; Process marks are given.
1197      (cond        (gnus-uu-digest-mail-forward arg post)
1198       ((null arg))      ;; No process marks.
1199       ((eq arg 1) (setq message-forward-as-mime nil      (let ((message-forward-as-mime message-forward-as-mime)
1200                         message-forward-show-mml t))            (message-forward-show-mml message-forward-show-mml))
1201       ((eq arg 2) (setq message-forward-as-mime t        (cond
1202                         message-forward-show-mml nil))         ((null arg))
1203       ((eq arg 3) (setq message-forward-as-mime t         ((eq arg 1)
1204                         message-forward-show-mml t))          (setq message-forward-as-mime nil
1205       ((eq arg 4) (setq message-forward-as-mime nil                message-forward-show-mml t))
1206                         message-forward-show-mml nil))         ((eq arg 2)
1207       (t (setq message-forward-as-mime (not message-forward-as-mime))))          (setq message-forward-as-mime t
1208      (gnus-setup-message 'forward                message-forward-show-mml nil))
1209        (gnus-summary-select-article)         ((eq arg 3)
1210        (let ((mail-parse-charset gnus-newsgroup-charset)          (setq message-forward-as-mime t
1211              (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets))                message-forward-show-mml t))
1212          (set-buffer gnus-original-article-buffer)         ((eq arg 4)
1213          (message-forward post)))))          (setq message-forward-as-mime nil
1214                  message-forward-show-mml nil))
1215           (t
1216            (setq message-forward-as-mime (not message-forward-as-mime))))
1217          (let* ((gnus-article-reply (gnus-summary-article-number))
1218                 (gnus-article-yanked-articles (list gnus-article-reply)))
1219            (gnus-setup-message 'forward
1220              (gnus-summary-select-article)
1221              (let ((mail-parse-charset
1222                     (or (and (gnus-buffer-live-p gnus-article-buffer)
1223                              (with-current-buffer gnus-article-buffer
1224                                gnus-article-charset))
1225                         gnus-newsgroup-charset))
1226                    (mail-parse-ignored-charsets
1227                     gnus-newsgroup-ignored-charsets))
1228                (set-buffer gnus-original-article-buffer)
1229                (message-forward post)))))))
1230    
1231  (defun gnus-summary-resend-message (address n)  (defun gnus-summary-resend-message (address n)
1232    "Resend the current article to ADDRESS."    "Resend the current article to ADDRESS."
1233    (interactive "sResend message(s) to: \nP")    (interactive
1234       (list (message-read-from-minibuffer
1235              "Resend message(s) to: "
1236              (when (and gnus-summary-resend-default-address
1237                         (gnus-buffer-live-p gnus-original-article-buffer))
1238                ;; If some other article is currently selected, the
1239                ;; initial-contents is wrong. Whatever, it is just the
1240                ;; initial-contents.
1241                (with-current-buffer gnus-original-article-buffer
1242                  (nnmail-fetch-field "to"))))
1243             current-prefix-arg))
1244    (let ((articles (gnus-summary-work-articles n))    (let ((articles (gnus-summary-work-articles n))
1245          article)          article)
1246      (while (setq article (pop articles))      (while (setq article (pop articles))
1247        (gnus-summary-select-article nil nil nil article)        (gnus-summary-select-article nil nil nil article)
1248        (save-excursion        (save-excursion
1249          (set-buffer gnus-original-article-buffer)          (set-buffer gnus-original-article-buffer)
1250          (message-resend address)))))          (message-resend address))
1251          (gnus-summary-mark-article-as-forwarded article))))
1252    
1253    ;; From: Matthieu Moy <Matthieu.Moy@imag.fr>
1254    (defun gnus-summary-resend-message-edit ()
1255      "Resend an article that has already been sent.
1256    A new buffer will be created to allow the user to modify body and
1257    contents of the message, and then, everything will happen as when
1258    composing a new message."
1259      (interactive)
1260      (let ((article (gnus-summary-article-number)))
1261        (gnus-setup-message 'reply-yank
1262          (gnus-summary-select-article t)
1263          (set-buffer gnus-original-article-buffer)
1264          (let ((cur (current-buffer))
1265                (to (message-fetch-field "to")))
1266            ;; Get a normal message buffer.
1267            (message-pop-to-buffer (message-buffer-name "Resend" to))
1268            (insert-buffer-substring cur)
1269            (mime-to-mml)
1270            (message-narrow-to-head-1)
1271            ;; Gnus will generate a new one when sending.
1272            (message-remove-header "Message-ID")
1273            (message-remove-header message-ignored-resent-headers t)
1274            ;; Remove unwanted headers.
1275            (goto-char (point-max))
1276            (insert mail-header-separator)
1277            (goto-char (point-min))
1278            (when (re-search-forward "^To:\\|^Newsgroups:" nil 'move)
1279              (forward-char 1))
1280            (widen)))))
1281    
1282  (defun gnus-summary-post-forward (&optional arg)  (defun gnus-summary-post-forward (&optional arg)
1283    "Forward the current article to a newsgroup.    "Forward the current article to a newsgroup.
# Line 796  The current group name will be inserted Line 1338  The current group name will be inserted
1338            (when (gnus-y-or-n-p "Send this complaint? ")            (when (gnus-y-or-n-p "Send this complaint? ")
1339              (message-send-and-exit)))))))              (message-send-and-exit)))))))
1340    
 (defun gnus-summary-mail-other-window ()  
   "Compose mail in other window."  
   (interactive)  
   (gnus-setup-message 'message  
     (message-mail)))  
   
1341  (defun gnus-mail-parse-comma-list ()  (defun gnus-mail-parse-comma-list ()
1342    (let (accumulated    (let (accumulated
1343          beg)          beg)
# Line 836  The current group name will be inserted Line 1372  The current group name will be inserted
1372        ;; 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
1373        ;; here.  Magic!        ;; here.  Magic!
1374        (when (gnus-y-or-n-p        (when (gnus-y-or-n-p
1375               (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))
1376          (gnus-group-add-parameter group (cons 'to-list to-address))))))          (gnus-group-add-parameter group (cons 'to-list to-address))))))
1377    
1378  (defun gnus-put-message ()  (defun gnus-put-message ()
# Line 845  The current group name will be inserted Line 1381  The current group name will be inserted
1381    (let ((reply gnus-article-reply)    (let ((reply gnus-article-reply)
1382          (winconf gnus-prev-winconf)          (winconf gnus-prev-winconf)
1383          (group gnus-newsgroup-name))          (group gnus-newsgroup-name))
1384        (unless (and group
1385                     (not (gnus-group-read-only-p group)))
1386          (setq group (read-string "Put in group: " nil (gnus-writable-groups))))
1387    
     (or (and group (not (gnus-group-read-only-p group)))  
         (setq group (read-string "Put in group: " nil  
                                  (gnus-writable-groups))))  
1388      (when (gnus-gethash group gnus-newsrc-hashtb)      (when (gnus-gethash group gnus-newsrc-hashtb)
1389        (error "No such group: %s" group))        (error "No such group: %s" group))
   
1390      (save-excursion      (save-excursion
1391        (save-restriction        (save-restriction
1392          (widen)          (widen)
1393          (message-narrow-to-headers)          (message-narrow-to-headers)
1394          (let (gnus-deletable-headers)          (let ((gnus-deletable-headers nil))
1395            (if (message-news-p)            (message-generate-headers
1396                (message-generate-headers message-required-news-headers)             (if (message-news-p)
1397              (message-generate-headers message-required-mail-headers)))                 message-required-news-headers
1398                 message-required-mail-headers)))
1399          (goto-char (point-max))          (goto-char (point-max))
1400          (insert "Gcc: " group "\n")          (if (string-match " " group)
1401                (insert "Gcc: \"" group "\"\n")
1402              (insert "Gcc: " group "\n"))
1403          (widen)))          (widen)))
   
1404      (gnus-inews-do-gcc)      (gnus-inews-do-gcc)
1405        (when (and (get-buffer gnus-group-buffer)
1406      (when (get-buffer gnus-group-buffer)                 (gnus-buffer-exists-p (car-safe reply))
1407        (when (gnus-buffer-exists-p (car-safe reply))                 (cdr reply))
1408          (set-buffer (car reply))        (set-buffer (car reply))
1409          (and (cdr reply)        (gnus-summary-mark-article-as-replied (cdr reply)))
1410               (gnus-summary-mark-article-as-replied      (when winconf
1411                (cdr reply))))        (set-window-configuration winconf))))
       (when winconf  
         (set-window-configuration winconf)))))  
1412    
1413  (defun gnus-article-mail (yank)  (defun gnus-article-mail (yank)
1414    "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 1419  If YANK is non-nil, include the original
1419            (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point)))            (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point)))
1420            (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point))))))            (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point))))))
1421      (when address      (when address
1422        (message-reply address)        (gnus-msg-mail address)
1423        (when yank        (when yank
1424          (gnus-inews-yank-articles (list (cdr gnus-article-current)))))))          (gnus-inews-yank-articles (list (cdr gnus-article-current)))))))
1425    
# Line 919  If YANK is non-nil, include the original Line 1454  If YANK is non-nil, include the original
1454      (let (text)      (let (text)
1455        (save-excursion        (save-excursion
1456          (set-buffer (gnus-get-buffer-create " *gnus environment info*"))          (set-buffer (gnus-get-buffer-create " *gnus environment info*"))
1457            (erase-buffer)
1458          (gnus-debug)          (gnus-debug)
1459          (setq text (buffer-string)))          (setq text (buffer-string)))
1460        (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>"))
1461      (goto-char (point-min))      (goto-char (point-min))
1462      (search-forward "Subject: " nil t)      (search-forward "Subject: " nil t)
1463      (message "")))      (message "")))
# Line 936  If YANK is non-nil, include the original Line 1472  If YANK is non-nil, include the original
1472     (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t)     (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t)
1473           current-prefix-arg))           current-prefix-arg))
1474    (gnus-summary-iterate n    (gnus-summary-iterate n
1475      (let ((gnus-display-mime-function nil)      (let ((gnus-inhibit-treatment t))
           (gnus-inhibit-treatment t))  
1476        (gnus-summary-select-article))        (gnus-summary-select-article))
1477      (save-excursion      (save-excursion
1478        (set-buffer buffer)        (set-buffer buffer)
# Line 947  If YANK is non-nil, include the original Line 1482  If YANK is non-nil, include the original
1482    "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.
1483  The source file has to be in the Emacs load path."  The source file has to be in the Emacs load path."
1484    (interactive)    (interactive)
1485    (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"))  
1486          (point (point))          (point (point))
1487          file expr olist sym)          file expr olist sym)
1488      (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 1505  The source file has to be in the Emacs l
1505                  (and (or (eq (car expr) 'defvar)                  (and (or (eq (car expr) 'defvar)
1506                           (eq (car expr) 'defcustom))                           (eq (car expr) 'defcustom))
1507                       (stringp (nth 3 expr))                       (stringp (nth 3 expr))
1508                         (not (memq (nth 1 expr) gnus-debug-exclude-variables))
1509                       (or (not (boundp (nth 1 expr)))                       (or (not (boundp (nth 1 expr)))
1510                           (not (equal (eval (nth 2 expr))                           (not (equal (eval (nth 2 expr))
1511                                       (symbol-value (nth 1 expr)))))                                       (symbol-value (nth 1 expr)))))
# Line 982  The source file has to be in the Emacs l Line 1515  The source file has to be in the Emacs l
1515        (insert "------------------ Environment follows ------------------\n\n"))        (insert "------------------ Environment follows ------------------\n\n"))
1516      (while olist      (while olist
1517        (if (boundp (car olist))        (if (boundp (car olist))
1518            (condition-case ()            (ignore-errors
1519                (pp `(setq ,(car olist)             (gnus-pp
1520                           ,(if (or (consp (setq sym (symbol-value (car olist))))              `(setq ,(car olist)
1521                                    (and (symbolp sym)                     ,(if (or (consp (setq sym (symbol-value (car olist))))
1522                                         (not (or (eq sym nil)                              (and (symbolp sym)
1523                                                  (eq sym t)))))                                   (not (or (eq sym nil)
1524                                (list 'quote (symbol-value (car olist)))                                            (eq sym t)))))
1525                              (symbol-value (car olist))))                          (list 'quote (symbol-value (car olist)))
1526                    (current-buffer))                        (symbol-value (car olist))))))
             (error  
              (format "(setq %s 'whatever)\n" (car olist))))  
1527          (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))          (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))
1528        (setq olist (cdr olist)))        (setq olist (cdr olist)))
1529      (insert "\n\n")      (insert "\n\n")
# Line 1008  The source file has to be in the Emacs l Line 1539  The source file has to be in the Emacs l
1539    
1540  (defun gnus-summary-resend-bounced-mail (&optional fetch)  (defun gnus-summary-resend-bounced-mail (&optional fetch)
1541    "Re-mail the current message.    "Re-mail the current message.
1542  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
1543  contains some mail you have written which has been bounced back to  contains some mail you have written which has been bounced back to
1544  you.  you.
1545  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 1559  this is a reply."
1559  ;;; Gcc handling.  ;;; Gcc handling.
1560    
1561  (defun gnus-inews-group-method (group)  (defun gnus-inews-group-method (group)
1562    (cond ((and (null (gnus-get-info group))    (cond
1563                (eq (car gnus-message-archive-method)     ;; If the group doesn't exist, we assume
1564                    (car     ;; it's an archive group...
1565                     (gnus-server-to-method     ((and (null (gnus-get-info group))
1566                      (gnus-group-method group)))))           (eq (car (gnus-server-to-method gnus-message-archive-method))
1567           ;; If the group doesn't exist, we assume               (car (gnus-server-to-method (gnus-group-method group)))))
1568           ;; it's an archive group...      gnus-message-archive-method)
1569           gnus-message-archive-method)     ;; Use the method.
1570          ;; Use the method.     ((gnus-info-method (gnus-get-info group))
1571          ((gnus-info-method (gnus-get-info group))      (gnus-info-method (gnus-get-info group)))
1572           (gnus-info-method (gnus-get-info group)))     ;; Find the method.
1573          ;; Find the method.     (t (gnus-server-to-method (gnus-group-method group)))))
         (t (gnus-group-method group))))  
1574    
1575  ;; Do Gcc handling, which copied the message over to some group.  ;; Do Gcc handling, which copied the message over to some group.
1576  (defun gnus-inews-do-gcc (&optional gcc)  (defun gnus-inews-do-gcc (&optional gcc)
1577    (interactive)    (interactive)
1578    (when (gnus-alive-p)    (save-excursion
1579      (save-excursion      (save-restriction
1580        (save-restriction        (message-narrow-to-headers)
1581          (message-narrow-to-headers)        (let ((gcc (or gcc (mail-fetch-field "gcc" nil t)))
1582          (let ((gcc (or gcc (mail-fetch-field "gcc" nil t)))              (cur (current-buffer))
1583                (cur (current-buffer))              groups group method group-art
1584                groups group method)              mml-externalize-attachments)
1585            (when gcc          (when gcc
1586              (message-remove-header "gcc")            (message-remove-header "gcc")
1587              (widen)            (widen)
1588              (setq groups (message-unquote-tokens            (setq groups (message-unquote-tokens
1589                            (message-tokenize-header gcc " ,")))                          (message-tokenize-header gcc " ,")))
1590              ;; Copy the article over to some group(s).            ;; Copy the article over to some group(s).
1591              (while (setq group (pop groups))            (while (setq group (pop groups))
1592                (gnus-check-server              (unless (gnus-check-server
1593                 (setq method (gnus-inews-group-method group)))                       (setq method (gnus-inews-group-method group)))
1594                (unless (gnus-request-group group t method)                (error "Can't open server %s" (if (stringp method) method
1595                  (gnus-request-create-group group method))                                                (car method))))
1596                (save-excursion              (unless (gnus-request-group group nil method)
1597                  (nnheader-set-temp-buffer " *acc*")                (gnus-request-create-group group method))
1598                  (insert-buffer-substring cur)              (setq mml-externalize-attachments
1599                  (message-encode-message-body)                    (if (stringp gnus-gcc-externalize-attachments)
1600                  (save-restriction                        (string-match gnus-gcc-externalize-attachments group)
1601                    (message-narrow-to-headers)                      gnus-gcc-externalize-attachments))
1602                    (let ((mail-parse-charset message-default-charset)              (save-excursion
1603                          (rfc2047-header-encoding-alist                (nnheader-set-temp-buffer " *acc*")
1604                           (cons '("Newsgroups" . default)                (insert-buffer-substring cur)
1605                                 rfc2047-header-encoding-alist)))                (message-encode-message-body)
1606                      (mail-encode-encoded-word-buffer)))                (save-restriction
1607                  (goto-char (point-min))                  (message-narrow-to-headers)
1608                  (when (re-search-forward                  (let* ((mail-parse-charset message-default-charset)
1609                         (concat "^" (regexp-quote mail-header-separator) "$")                         (newsgroups-field (save-restriction
1610                         nil t)                                             (message-narrow-to-headers-or-head)
1611                    (replace-match "" t t ))                                             (message-fetch-field "Newsgroups")))
1612                  (unless (gnus-request-accept-article group method t t)                         (followup-field (save-restriction
1613                    (gnus-message 1 "Couldn't store article in group %s: %s"                                           (message-narrow-to-headers-or-head)
1614                                  group (gnus-status-message method))                                           (message-fetch-field "Followup-To")))
1615                    (sit-for 2))                         ;; BUG: We really need to get the charset for
1616                  (kill-buffer (current-buffer))))))))))                         ;; each name in the Newsgroups and Followup-To
1617                           ;; lines to allow crossposting between group
1618                           ;; namess with incompatible character sets.
1619                           ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08.
1620                           (group-field-charset
1621                            (gnus-group-name-charset
1622                             method (or newsgroups-field "")))
1623                           (followup-field-charset
1624                            (gnus-group-name-charset
1625                             method (or followup-field "")))
1626                           (rfc2047-header-encoding-alist
1627                            (append
1628                             (when group-field-charset
1629                               (list (cons "Newsgroups" group-field-charset)))
1630                             (when followup-field-charset
1631                               (list (cons "Followup-To" followup-field-charset)))
1632                             rfc2047-header-encoding-alist)))
1633                      (mail-encode-encoded-word-buffer)))
1634                  (goto-char (point-min))
1635                  (when (re-search-forward
1636                         (concat "^" (regexp-quote mail-header-separator) "$")
1637                         nil t)
1638                    (replace-match "" t t ))
1639                  (unless (setq group-art
1640                                (gnus-request-accept-article group method t t))
1641                    (gnus-message 1 "Couldn't store article in group %s: %s"
1642                                  group (gnus-status-message method))
1643                    (sit-for 2))
1644                  (when (and group-art
1645                             ;; FIXME: Should gcc-mark-as-read work when
1646                             ;; Gnus is not running?
1647                             (gnus-alive-p)
1648                             (or gnus-gcc-mark-as-read
1649                                 (and
1650                                  (boundp 'gnus-inews-mark-gcc-as-read)
1651                                  (symbol-value 'gnus-inews-mark-gcc-as-read))))
1652                    (gnus-group-mark-article-read group (cdr group-art)))
1653                  (kill-buffer (current-buffer)))))))))
1654    
1655  (defun gnus-inews-insert-gcc ()  (defun gnus-inews-insert-gcc ()
1656    "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 1659  this is a reply."
1659        (message-narrow-to-headers)        (message-narrow-to-headers)
1660        (let* ((group gnus-outgoing-message-group)        (let* ((group gnus-outgoing-message-group)
1661               (gcc (cond               (gcc (cond
1662                     ((gnus-functionp group)                     ((functionp group)
1663                      (funcall group))                      (funcall group))
1664                     ((or (stringp group) (list group))                     ((or (stringp group) (list group))
1665                      group))))                      group))))
1666          (when gcc          (when gcc
1667            (insert "Gcc: "            (insert "Gcc: "
1668                    (if (stringp gcc) gcc                    (if (stringp gcc)
1669                      (mapconcat 'identity gcc " "))                        (if (string-match " " gcc)
1670                              (concat "\"" gcc "\"")
1671                            gcc)
1672                        (mapconcat (lambda (group)
1673                                     (if (string-match " " group)
1674                                         (concat "\"" group "\"")
1675                                       group))
1676                                   gcc " "))
1677                    "\n"))))))                    "\n"))))))
1678    
1679  (defun gnus-inews-insert-archive-gcc (&optional group)  (defun gnus-inews-insert-archive-gcc (&optional group)
# Line 1126  this is a reply." Line 1700  this is a reply."
1700             ((and (listp var) (stringp (car var)))             ((and (listp var) (stringp (car var)))
1701              ;; A list of groups.              ;; A list of groups.
1702              var)              var)
1703             ((gnus-functionp var)             ((functionp var)
1704              ;; A function.              ;; A function.
1705              (funcall var group))              (funcall var group))
1706             (t             (t
# Line 1139  this is a reply." Line 1713  this is a reply."
1713                                   ;; Regexp.                                   ;; Regexp.
1714                                   (when (string-match (caar var) group)                                   (when (string-match (caar var) group)
1715                                     (cdar var)))                                     (cdar var)))
1716                                  ((gnus-functionp (car var))                                  ((functionp (car var))
1717                                   ;; Function.                                   ;; Function.
1718                                   (funcall (car var) group))                                   (funcall (car var) group))
1719                                  (t                                  (t
# Line 1160  this is a reply." Line 1734  this is a reply."
1734                (progn                (progn
1735                  (insert                  (insert
1736                   (if (stringp gcc-self-val)                   (if (stringp gcc-self-val)
1737                       gcc-self-val                       (if (string-match " " gcc-self-val)
1738                     group))                           (concat "\"" gcc-self-val "\"")
1739                           gcc-self-val)
1740                       ;; In nndoc groups, we use the parent group name
1741                       ;; instead of the current group.
1742                       (let ((group (or (gnus-group-find-parameter
1743                                         gnus-newsgroup-name 'parent-group)
1744                                        group)))
1745                         (if (string-match " " group)
1746                             (concat "\"" group "\"")
1747                           group))))
1748                  (if (not (eq gcc-self-val 'none))                  (if (not (eq gcc-self-val 'none))
1749                      (insert "\n")                      (insert "\n")
1750                    (progn                    (gnus-delete-line)))
                     (beginning-of-line)  
                     (kill-line))))  
1751              ;; Use the list of groups.              ;; Use the list of groups.
1752              (while (setq name (pop groups))              (while (setq name (pop groups))
1753                (insert (if (string-match ":" name)                (let ((str (if (string-match ":" name)
1754                            name                               name
1755                          (gnus-group-prefixed-name                             (gnus-group-prefixed-name
1756                           name gnus-message-archive-method)))                              name gnus-message-archive-method))))
1757                    (insert (if (string-match " " str)
1758                                (concat "\"" str "\"")
1759                              str)))
1760                (when groups                (when groups
1761                  (insert " ")))                  (insert " ")))
1762              (insert "\n")))))))              (insert "\n")))))))
1763    
1764    (defun gnus-mailing-list-followup-to ()
1765      "Look at the headers in the current buffer and return a Mail-Followup-To address."
1766      (let ((x-been-there (gnus-fetch-original-field "x-beenthere"))
1767            (list-post (gnus-fetch-original-field "list-post")))
1768        (when (and list-post
1769                   (string-match "mailto:\\([^>]+\\)" list-post))
1770          (setq list-post (match-string 1 list-post)))
1771        (or list-post
1772            x-been-there)))
1773    
1774  ;;; Posting styles.  ;;; Posting styles.
1775    
1776  (defun gnus-configure-posting-styles ()  (defun gnus-configure-posting-styles (&optional group-name)
1777    "Configure posting styles according to `gnus-posting-styles'."    "Configure posting styles according to `gnus-posting-styles'."
1778    (unless gnus-inhibit-posting-styles    (unless gnus-inhibit-posting-styles
1779      (let ((group (or gnus-newsgroup-name ""))      (let ((group (or group-name gnus-newsgroup-name ""))
1780            (styles gnus-posting-styles)            (styles gnus-posting-styles)
1781            style match variable attribute value v results            style match attribute value v results
1782            filep name address element)            filep name address element)
1783        ;; 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
1784        ;; 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 1796  this is a reply."
1796                  ;; Regexp string match on the group name.                  ;; Regexp string match on the group name.
1797                  (string-match match group))                  (string-match match group))
1798                 ((eq match 'header)                 ((eq match 'header)
1799                  (let ((header (message-fetch-field (pop style))))                  ;; Obsolete format of header match.
1800                    (and header                  (and (gnus-buffer-live-p gnus-article-copy)
1801                         (string-match (pop style) header))))                       (with-current-buffer gnus-article-copy
1802                           (let ((header (message-fetch-field (pop style))))
1803                             (and header
1804                                  (string-match (pop style) header))))))
1805                 ((or (symbolp match)                 ((or (symbolp match)
1806                      (gnus-functionp match))                      (functionp match))
1807                  (cond                  (cond
1808                   ((gnus-functionp match)                   ((functionp match)
1809                    ;; Function to be called.                    ;; Function to be called.
1810                    (funcall match))                    (funcall match))
1811                   ((boundp match)                   ((boundp match)
1812                    ;; Variable to be checked.                    ;; Variable to be checked.
1813                    (symbol-value match))))                    (symbol-value match))))
1814                 ((listp match)                 ((listp match)
1815                  ;; This is a form to be evaled.                  (cond
1816                  (eval match)))                   ((eq (car match) 'header)
1817                      ;; New format of header match.
1818                      (and (gnus-buffer-live-p gnus-article-copy)
1819                           (with-current-buffer gnus-article-copy
1820                             (let ((header (message-fetch-field (nth 1 match))))
1821                               (and header
1822                                    (string-match (nth 2 match) header))))))
1823                     (t
1824                      ;; This is a form to be evaled.
1825                      (eval match)))))
1826            ;; We have a match, so we set the variables.            ;; We have a match, so we set the variables.
1827            (dolist (attribute style)            (dolist (attribute style)
1828              (setq element (pop attribute)              (setq element (pop attribute)
                   variable nil  
1829                    filep nil)                    filep nil)
1830              (setq value              (setq value
1831                    (cond                    (cond
# Line 1237  this is a reply." Line 1842  this is a reply."
1842                     ((stringp value)                     ((stringp value)
1843                      value)                      value)
1844                     ((or (symbolp value)                     ((or (symbolp value)
1845                          (gnus-functionp value))                          (functionp value))
1846                      (cond ((gnus-functionp value)                      (cond ((functionp value)
1847                             (funcall value))                             (funcall value))
1848                            ((boundp value)                            ((boundp value)
1849                             (symbol-value value))))                             (symbol-value value))))
1850                     ((listp value)                     ((listp value)
1851                      (eval value))))                      (eval value))))
1852              ;; Translate obsolescent value.              ;; Translate obsolescent value.
1853              (when (eq element 'signature-file)              (cond
1854                 ((eq element 'signature-file)
1855                (setq element 'signature                (setq element 'signature
1856                      filep t))                      filep t))
1857                 ((eq element 'x-face-file)
1858                  (setq element 'x-face
1859                        filep t)))
1860              ;; Get the contents of file elems.              ;; Get the contents of file elems.
1861              (when (and filep v)              (when (and filep v)
1862                (setq v (with-temp-buffer                (setq v (with-temp-buffer
1863                          (insert-file-contents v)                          (insert-file-contents v)
1864                            (goto-char (point-max))
1865                            (while (bolp)
1866                              (delete-char -1))
1867                          (buffer-string))))                          (buffer-string))))
1868              (setq results (delq (assoc element results) results))              (setq results (delq (assoc element results) results))
1869              (push (cons element v) results))))              (push (cons element v) results))))
# Line 1259  this is a reply." Line 1871  this is a reply."
1871        (setq name (assq 'name results)        (setq name (assq 'name results)
1872              address (assq 'address results))              address (assq 'address results))
1873        (setq results (delq name (delq address results)))        (setq results (delq name (delq address results)))
1874        (make-local-variable 'message-setup-hook)        (gnus-make-local-hook 'message-setup-hook)
1875          (setq results (sort results (lambda (x y)
1876                                        (string-lessp (car x) (car y)))))
1877        (dolist (result results)        (dolist (result results)
1878          (add-hook 'message-setup-hook          (add-hook 'message-setup-hook
1879                    (cond                    (cond
# Line 1291  this is a reply." Line 1905  this is a reply."
1905                             (let ((value ,(cdr result)))                             (let ((value ,(cdr result)))
1906                               (when value                               (when value
1907                                 (message-goto-eoh)                                 (message-goto-eoh)
1908                                 (insert ,header ": " value "\n"))))))))))                                 (insert ,header ": " value)
1909                                   (unless (bolp)
1910                                     (insert "\n")))))))))
1911                      nil 'local))
1912        (when (or name address)        (when (or name address)
1913          (add-hook 'message-setup-hook          (add-hook 'message-setup-hook
1914                    `(lambda ()                    `(lambda ()
1915                       (set (make-local-variable 'user-mail-address)                       (set (make-local-variable 'user-mail-address)
1916                            ,(or (cdr address) user-mail-address))                            ,(or (cdr address) user-mail-address))
1917                       (let ((user-full-name ,(or (cdr name) (user-full-name)))                       (let ((user-full-name ,(or (cdr name) (user-full-name)))
1918                             (user-mail-address                             (user-mail-address
1919                              ,(or (cdr address) user-mail-address)))                              ,(or (cdr address) user-mail-address)))
1920                         (save-excursion                         (save-excursion
1921                           (message-remove-header "From")                           (message-remove-header "From")
1922                           (message-goto-eoh)                           (message-goto-eoh)
1923                           (insert "From: " (message-make-from) "\n")))))))))                           (insert "From: " (message-make-from) "\n"))))
1924                      nil 'local)))))
1925    
1926  ;;; Allow redefinition of functions.  ;;; Allow redefinition of functions.
1927    

Legend:
Removed from v.1.16.4.2  
changed lines
  Added in v.1.16.4.3

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