/[emacs]/emacs/lisp/gnus/message.el
ViewVC logotype

Diff of /emacs/lisp/gnus/message.el

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

revision 1.49.2.3 by miles, Fri Mar 19 23:27:35 2004 UTC revision 1.49.2.4 by miles, Thu Sep 16 00:12:16 2004 UTC
# Line 1  Line 1 
1  ;;; message.el --- composing mail and news messages  -*- coding: iso-latin-1 -*-  ;;; message.el --- composing mail and news messages
2  ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2004  ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
3  ;;        Free Software Foundation, Inc.  ;;        Free Software Foundation, Inc.
4    
5  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>  ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
# Line 32  Line 32 
32    
33  (eval-when-compile  (eval-when-compile
34    (require 'cl)    (require 'cl)
35    (defvar gnus-list-identifiers))       ; gnus-sum is required where necessary    (defvar gnus-message-group-art)
36      (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary
37    (require 'canlock)
38  (require 'mailheader)  (require 'mailheader)
39  (require 'nnheader)  (require 'nnheader)
40  ;; This is apparently necessary even though things are autoloaded:  ;; This is apparently necessary even though things are autoloaded.
41    ;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better
42    ;; require mailabbrev here.
43  (if (featurep 'xemacs)  (if (featurep 'xemacs)
44      (require 'mail-abbrevs))      (require 'mail-abbrevs)
45      (require 'mailabbrev))
46  (require 'mail-parse)  (require 'mail-parse)
47  (require 'mml)  (require 'mml)
48    (require 'rfc822)
49    (eval-and-compile
50      (autoload 'gnus-find-method-for-group "gnus")
51      (autoload 'nnvirtual-find-group-art "nnvirtual")
52      (autoload 'gnus-group-decoded-name "gnus-group"))
53    
54  (defgroup message '((user-mail-address custom-variable)  (defgroup message '((user-mail-address custom-variable)
55                      (user-full-name custom-variable))                      (user-full-name custom-variable))
# Line 123  mailbox format." Line 133  mailbox format."
133                  (function :tag "Other"))                  (function :tag "Other"))
134    :group 'message-sending)    :group 'message-sending)
135    
136    (defcustom message-fcc-externalize-attachments nil
137      "If non-nil, attachments are included as external parts in Fcc copies."
138      :type 'boolean
139      :group 'message-sending)
140    
141  (defcustom message-courtesy-message  (defcustom message-courtesy-message
142    "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n"    "The following message is a courtesy copy of an article\nthat has been posted to %s as well.\n\n"
143    "*This is inserted at the start of a mailed copy of a posted message.    "*This is inserted at the start of a mailed copy of a posted message.
# Line 130  If the string contains the format spec \ Line 145  If the string contains the format spec \
145  the article has been posted to will be inserted there.  the article has been posted to will be inserted there.
146  If this variable is nil, no such courtesy message will be added."  If this variable is nil, no such courtesy message will be added."
147    :group 'message-sending    :group 'message-sending
148    :type 'string)    :type '(radio (string :format "%t: %v\n" :size 0) (const nil)))
149    
150  (defcustom message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):"  (defcustom message-ignored-bounced-headers
151      "^\\(Received\\|Return-Path\\|Delivered-To\\):"
152    "*Regexp that matches headers to be removed in resent bounced mail."    "*Regexp that matches headers to be removed in resent bounced mail."
153    :group 'message-interface    :group 'message-interface
154    :type 'regexp)    :type 'regexp)
# Line 156  Otherwise, most addresses look like `ang Line 172  Otherwise, most addresses look like `ang
172                   (const default))                   (const default))
173    :group 'message-headers)    :group 'message-headers)
174    
175  (defcustom message-syntax-checks nil  (defcustom message-insert-canlock t
176      "Whether to insert a Cancel-Lock header in news postings."
177      :version "21.3"
178      :group 'message-headers
179      :type 'boolean)
180    
181    (defcustom message-syntax-checks
182      (if message-insert-canlock '((sender . disabled)) nil)
183    ;; Guess this one shouldn't be easy to customize...    ;; Guess this one shouldn't be easy to customize...
184    "*Controls what syntax checks should not be performed on outgoing posts.    "*Controls what syntax checks should not be performed on outgoing posts.
185  To disable checking of long signatures, for instance, add  To disable checking of long signatures, for instance, add
# Line 169  Checks include `subject-cmsg', `multiple Line 192  Checks include `subject-cmsg', `multiple
192  `new-text', `quoting-style', `redirected-followup', `signature',  `new-text', `quoting-style', `redirected-followup', `signature',
193  `approved', `sender', `empty', `empty-headers', `message-id', `from',  `approved', `sender', `empty', `empty-headers', `message-id', `from',
194  `subject', `shorten-followup-to', `existing-newsgroups',  `subject', `shorten-followup-to', `existing-newsgroups',
195  `buffer-file-name', `unchanged', `newsgroups'."  `buffer-file-name', `unchanged', `newsgroups', `reply-to',
196    `continuation-headers', `long-header-lines', `invisible-text' and
197    `illegible-text'."
198    :group 'message-news    :group 'message-news
199    :type '(repeat sexp))                 ; Fixme: improve this    :type '(repeat sexp))                 ; Fixme: improve this
200    
201    (defcustom message-required-headers '((optional . References)
202                                          From)
203      "*Headers to be generated or prompted for when sending a message.
204    Also see `message-required-news-headers' and
205    `message-required-mail-headers'."
206      :group 'message-news
207      :group 'message-headers
208      :link '(custom-manual "(message)Message Headers")
209      :type '(repeat sexp))
210    
211    (defcustom message-draft-headers '(References From)
212      "*Headers to be generated when saving a draft message."
213      :group 'message-news
214      :group 'message-headers
215      :link '(custom-manual "(message)Message Headers")
216      :type '(repeat sexp))
217    
218  (defcustom message-required-news-headers  (defcustom message-required-news-headers
219    '(From Newsgroups Subject Date Message-ID    '(From Newsgroups Subject Date Message-ID
220           (optional . Organization) Lines           (optional . Organization)
221           (optional . User-Agent))           (optional . User-Agent))
222    "*Headers to be generated or prompted for when posting an article.    "*Headers to be generated or prompted for when posting an article.
223  RFC977 and RFC1036 require From, Date, Newsgroups, Subject,  RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
# Line 184  User-Agent are optional.  If don't you w Line 226  User-Agent are optional.  If don't you w
226  header, remove it from this list."  header, remove it from this list."
227    :group 'message-news    :group 'message-news
228    :group 'message-headers    :group 'message-headers
229      :link '(custom-manual "(message)Message Headers")
230    :type '(repeat sexp))    :type '(repeat sexp))
231    
232  (defcustom message-required-mail-headers  (defcustom message-required-mail-headers
233    '(From Subject Date (optional . In-Reply-To) Message-ID Lines    '(From Subject Date (optional . In-Reply-To) Message-ID
234           (optional . User-Agent))           (optional . User-Agent))
235    "*Headers to be generated or prompted for when mailing a message.    "*Headers to be generated or prompted for when mailing a message.
236  RFC822 required that From, Date, To, Subject and Message-ID be  It is recommended that From, Date, To, Subject and Message-ID be
237  included.  Organization, Lines and User-Agent are optional."  included.  Organization and User-Agent are optional."
238    :group 'message-mail    :group 'message-mail
239    :group 'message-headers    :group 'message-headers
240      :link '(custom-manual "(message)Message Headers")
241    :type '(repeat sexp))    :type '(repeat sexp))
242    
243  (defcustom message-deletable-headers '(Message-ID Date Lines)  (defcustom message-deletable-headers '(Message-ID Date Lines)
244    "Headers to be deleted if they already exist and were generated by message previously."    "Headers to be deleted if they already exist and were generated by message previously."
245    :group 'message-headers    :group 'message-headers
246      :link '(custom-manual "(message)Message Headers")
247    :type 'sexp)    :type 'sexp)
248    
249  (defcustom message-ignored-news-headers  (defcustom message-ignored-news-headers
250    "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:"    "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:"
251    "*Regexp of headers to be removed unconditionally before posting."    "*Regexp of headers to be removed unconditionally before posting."
252    :group 'message-news    :group 'message-news
253    :group 'message-headers    :group 'message-headers
254      :link '(custom-manual "(message)Message Headers")
255    :type 'regexp)    :type 'regexp)
256    
257  (defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:"  (defcustom message-ignored-mail-headers
258      "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:"
259    "*Regexp of headers to be removed unconditionally before mailing."    "*Regexp of headers to be removed unconditionally before mailing."
260    :group 'message-mail    :group 'message-mail
261    :group 'message-headers    :group 'message-headers
262      :link '(custom-manual "(message)Mail Headers")
263    :type 'regexp)    :type 'regexp)
264    
265  (defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:"  (defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:"
266    "*Header lines matching this regexp will be deleted before posting.    "*Header lines matching this regexp will be deleted before posting.
267  It's best to delete old Path and Date headers before posting to avoid  It's best to delete old Path and Date headers before posting to avoid
268  any confusion."  any confusion."
269    :group 'message-interface    :group 'message-interface
270      :link '(custom-manual "(message)Superseding")
271    :type 'regexp)    :type 'regexp)
272    
273  (defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*"  (defcustom message-subject-re-regexp
274      "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*"
275    "*Regexp matching \"Re: \" in the subject line."    "*Regexp matching \"Re: \" in the subject line."
276    :group 'message-various    :group 'message-various
277      :link '(custom-manual "(message)Message Headers")
278      :type 'regexp)
279    
280    ;;; Start of variables adopted from `message-utils.el'.
281    
282    (defcustom message-subject-trailing-was-query 'ask
283      "*What to do with trailing \"(was: <old subject>)\" in subject lines.
284    If nil, leave the subject unchanged.  If it is the symbol `ask', query
285    the user what do do.  In this case, the subject is matched against
286    `message-subject-trailing-was-ask-regexp'.  If
287    `message-subject-trailing-was-query' is t, always strip the trailing
288    old subject.  In this case, `message-subject-trailing-was-regexp' is
289    used."
290      :type '(choice (const :tag "never" nil)
291                     (const :tag "always strip" t)
292                     (const ask))
293      :link '(custom-manual "(message)Message Headers")
294      :group 'message-various)
295    
296    (defcustom message-subject-trailing-was-ask-regexp
297      "[ \t]*\\([[(]+[Ww][Aa][Ss][ \t]*.*[\])]+\\)"
298      "*Regexp matching \"(was: <old subject>)\" in the subject line.
299    
300    The function `message-strip-subject-trailing-was' uses this regexp if
301    `message-subject-trailing-was-query' is set to the symbol `ask'.  If
302    the variable is t instead of `ask', use
303    `message-subject-trailing-was-regexp' instead.
304    
305    It is okay to create some false positives here, as the user is asked."
306      :group 'message-various
307      :link '(custom-manual "(message)Message Headers")
308    :type 'regexp)    :type 'regexp)
309    
310    (defcustom message-subject-trailing-was-regexp
311      "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)"
312      "*Regexp matching \"(was: <old subject>)\" in the subject line.
313    
314    If `message-subject-trailing-was-query' is set to t, the subject is
315    matched against `message-subject-trailing-was-regexp' in
316    `message-strip-subject-trailing-was'.  You should use a regexp creating very
317    few false positives here."
318      :group 'message-various
319      :link '(custom-manual "(message)Message Headers")
320      :type 'regexp)
321    
322    ;; Fixme: Why are all these things autoloaded?
323    
324    ;;; marking inserted text
325    
326    ;;;###autoload
327    (defcustom message-mark-insert-begin
328      "--8<---------------cut here---------------start------------->8---\n"
329      "How to mark the beginning of some inserted text."
330      :type 'string
331      :link '(custom-manual "(message)Insertion Variables")
332      :group 'message-various)
333    
334    ;;;###autoload
335    (defcustom message-mark-insert-end
336      "--8<---------------cut here---------------end--------------->8---\n"
337      "How to mark the end of some inserted text."
338      :type 'string
339      :link '(custom-manual "(message)Insertion Variables")
340      :group 'message-various)
341    
342    ;;;###autoload
343    (defcustom message-archive-header
344      "X-No-Archive: Yes\n"
345      "Header to insert when you don't want your article to be archived.
346    Archives \(such as groups.google.com\) respect this header."
347      :type 'string
348      :link '(custom-manual "(message)Header Commands")
349      :group 'message-various)
350    
351    ;;;###autoload
352    (defcustom message-archive-note
353      "X-No-Archive: Yes - save http://groups.google.com/"
354      "Note to insert why you wouldn't want this posting archived.
355    If nil, don't insert any text in the body."
356      :type '(radio (string :format "%t: %v\n" :size 0)
357                    (const nil))
358      :link '(custom-manual "(message)Header Commands")
359      :group 'message-various)
360    
361    ;;; Crossposts and Followups
362    ;; inspired by JoH-followup-to by Jochem Huhman <joh  at gmx.de>
363    ;; new suggestions by R. Weikusat <rw at another.de>
364    
365    (defvar message-cross-post-old-target nil
366      "Old target for cross-posts or follow-ups.")
367    (make-variable-buffer-local 'message-cross-post-old-target)
368    
369    ;;;###autoload
370    (defcustom message-cross-post-default t
371      "When non-nil `message-cross-post-followup-to' will perform a crosspost.
372    If nil, `message-cross-post-followup-to' will only do a followup.  Note that
373    you can explicitly override this setting by calling
374    `message-cross-post-followup-to' with a prefix."
375      :type 'boolean
376      :group 'message-various)
377    
378    ;;;###autoload
379    (defcustom message-cross-post-note
380      "Crosspost & Followup-To: "
381      "Note to insert before signature to notify of cross-post and follow-up."
382      :type 'string
383      :group 'message-various)
384    
385    ;;;###autoload
386    (defcustom message-followup-to-note
387      "Followup-To: "
388      "Note to insert before signature to notify of follow-up only."
389      :type 'string
390      :group 'message-various)
391    
392    ;;;###autoload
393    (defcustom message-cross-post-note-function
394      'message-cross-post-insert-note
395      "Function to use to insert note about Crosspost or Followup-To.
396    The function will be called with four arguments.  The function should not only
397    insert a note, but also ensure old notes are deleted.  See the documentation
398    for `message-cross-post-insert-note'."
399      :type 'function
400      :group 'message-various)
401    
402    ;;; End of variables adopted from `message-utils.el'.
403    
404  ;;;###autoload  ;;;###autoload
405  (defcustom message-signature-separator "^-- *$"  (defcustom message-signature-separator "^-- *$"
406    "Regexp matching the signature separator."    "Regexp matching the signature separator."
407    :type 'regexp    :type 'regexp
408      :link '(custom-manual "(message)Various Message Variables")
409    :group 'message-various)    :group 'message-various)
410    
411  (defcustom message-elide-ellipsis "\n[...]\n\n"  (defcustom message-elide-ellipsis "\n[...]\n\n"
412    "*The string which is inserted for elided text."    "*The string which is inserted for elided text."
413    :type 'string    :type 'string
414      :link '(custom-manual "(message)Various Commands")
415    :group 'message-various)    :group 'message-various)
416    
417  (defcustom message-interactive nil  (defcustom message-interactive t
418    "Non-nil means when sending a message wait for and display errors.    "Non-nil means when sending a message wait for and display errors.
419  nil means let mailer mail back a message to report errors."  nil means let mailer mail back a message to report errors."
420    :group 'message-sending    :group 'message-sending
421    :group 'message-mail    :group 'message-mail
422      :link '(custom-manual "(message)Sending Variables")
423    :type 'boolean)    :type 'boolean)
424    
425  (defcustom message-generate-new-buffers 'unique  (defcustom message-generate-new-buffers 'unique
# Line 250  If this is a function, call that functio Line 428  If this is a function, call that functio
428  the to address and the group name.  (Any of these may be nil.)  The function  the to address and the group name.  (Any of these may be nil.)  The function
429  should return the new buffer name."  should return the new buffer name."
430    :group 'message-buffers    :group 'message-buffers
431      :link '(custom-manual "(message)Message Buffers")
432    :type '(choice (const :tag "off" nil)    :type '(choice (const :tag "off" nil)
433                   (const :tag "unique" unique)                   (const :tag "unique" unique)
434                   (const :tag "unsent" unsent)                   (const :tag "unsent" unsent)
# Line 258  should return the new buffer name." Line 437  should return the new buffer name."
437  (defcustom message-kill-buffer-on-exit nil  (defcustom message-kill-buffer-on-exit nil
438    "*Non-nil means that the message buffer will be killed after sending a message."    "*Non-nil means that the message buffer will be killed after sending a message."
439    :group 'message-buffers    :group 'message-buffers
440      :link '(custom-manual "(message)Message Buffers")
441    :type 'boolean)    :type 'boolean)
442    
443  (eval-when-compile  (eval-when-compile
# Line 278  If t, use `message-user-organization-fil Line 458  If t, use `message-user-organization-fil
458  (defcustom message-user-organization-file "/usr/lib/news/organization"  (defcustom message-user-organization-file "/usr/lib/news/organization"
459    "*Local news organization file."    "*Local news organization file."
460    :type 'file    :type 'file
461      :link '(custom-manual "(message)News Headers")
462    :group 'message-headers)    :group 'message-headers)
463    
464  (defcustom message-make-forward-subject-function  (defcustom message-make-forward-subject-function
465    'message-forward-subject-author-subject    #'message-forward-subject-name-subject
466    "*List of functions called to generate subject headers for forwarded messages.    "*List of functions called to generate subject headers for forwarded messages.
467  The subject generated by the previous function is passed into each  The subject generated by the previous function is passed into each
468  successive function.  successive function.
469    
470  The provided functions are:  The provided functions are:
471    
472  * `message-forward-subject-author-subject' (Source of article (author or  * `message-forward-subject-author-subject' Source of article (author or
473        newsgroup)), in brackets followed by the subject        newsgroup), in brackets followed by the subject
474  * `message-forward-subject-fwd' (Subject of article with 'Fwd:' prepended  * `message-forward-subject-name-subject' Source of article (name of author
475          or newsgroup), in brackets followed by the subject
476    * `message-forward-subject-fwd' Subject of article with 'Fwd:' prepended
477        to it."        to it."
478    :group 'message-forwarding    :group 'message-forwarding
479      :link '(custom-manual "(message)Forwarding")
480    :type '(radio (function-item message-forward-subject-author-subject)    :type '(radio (function-item message-forward-subject-author-subject)
481                  (function-item message-forward-subject-fwd)                  (function-item message-forward-subject-fwd)
482                    (function-item message-forward-subject-name-subject)
483                  (repeat :tag "List of functions" function)))                  (repeat :tag "List of functions" function)))
484    
485  (defcustom message-forward-as-mime t  (defcustom message-forward-as-mime t
486    "*If non-nil, forward messages as an inline/rfc822 MIME section.  Otherwise, directly inline the old message in the forwarded message."    "*Non-nil means forward messages as an inline/rfc822 MIME section.
487    Otherwise, directly inline the old message in the forwarded message."
488    :version "21.1"    :version "21.1"
489    :group 'message-forwarding    :group 'message-forwarding
490      :link '(custom-manual "(message)Forwarding")
491    :type 'boolean)    :type 'boolean)
492    
493  (defcustom message-forward-show-mml t  (defcustom message-forward-show-mml 'best
494    "*If non-nil, forward messages are shown as mml.  Otherwise, forward messages are unchanged."    "*Non-nil means show forwarded messages as MML (decoded from MIME).
495    Otherwise, forwarded messages are unchanged.
496    Can also be the symbol `best' to indicate that MML should be
497    used, except when it is a bad idea to use MML.  One example where
498    it is a bad idea is when forwarding a signed or encrypted
499    message, because converting MIME to MML would invalidate the
500    digital signature."
501    :version "21.1"    :version "21.1"
502    :group 'message-forwarding    :group 'message-forwarding
503    :type 'boolean)    :type '(choice (const :tag "use MML" t)
504                     (const :tag "don't use MML " nil)
505                     (const :tag "use MML when appropriate" best)))
506    
507  (defcustom message-forward-before-signature t  (defcustom message-forward-before-signature t
508    "*If non-nil, put forwarded message before signature, else after."    "*Non-nil means put forwarded message before signature, else after."
509    :group 'message-forwarding    :group 'message-forwarding
510    :type 'boolean)    :type 'boolean)
511    
512  (defcustom message-wash-forwarded-subjects nil  (defcustom message-wash-forwarded-subjects nil
513    "*If non-nil, try to remove as much old cruft as possible from the subject of messages before generating the new subject of a forward."    "*Non-nil means try to remove as much cruft as possible from the subject.
514    Done before generating the new subject of a forward."
515    :group 'message-forwarding    :group 'message-forwarding
516      :link '(custom-manual "(message)Forwarding")
517    :type 'boolean)    :type 'boolean)
518    
519  (defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:"  (defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From "
520    "*All headers that match this regexp will be deleted when resending a message."    "*All headers that match this regexp will be deleted when resending a message."
521    :group 'message-interface    :group 'message-interface
522      :link '(custom-manual "(message)Resending")
523    :type 'regexp)    :type 'regexp)
524    
525  (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus"  (defcustom message-forward-ignored-headers "^Content-Transfer-Encoding:\\|^X-Gnus"
# Line 334  The provided functions are: Line 532  The provided functions are:
532  (defcustom message-ignored-cited-headers "."  (defcustom message-ignored-cited-headers "."
533    "*Delete these headers from the messages you yank."    "*Delete these headers from the messages you yank."
534    :group 'message-insertion    :group 'message-insertion
535      :link '(custom-manual "(message)Insertion Variables")
536      :type 'regexp)
537    
538    (defcustom message-cite-prefix-regexp
539      (if (string-match "[[:digit:]]" "1") ;; support POSIX?
540          "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+"
541        ;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
542        (let ((old-table (syntax-table))
543              non-word-constituents)
544          (set-syntax-table text-mode-syntax-table)
545          (setq non-word-constituents
546                (concat
547                 (if (string-match "\\w" "-")  "" "-")
548                 (if (string-match "\\w" "_")  "" "_")
549                 (if (string-match "\\w" ".")  "" ".")))
550          (set-syntax-table old-table)
551          (if (equal non-word-constituents "")
552              "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}+]\\)+"
553            (concat "\\([ \t]*\\(\\w\\|["
554                    non-word-constituents
555                    "]\\)+>+\\|[ \t]*[]>|}+]\\)+"))))
556      "*Regexp matching the longest possible citation prefix on a line."
557      :group 'message-insertion
558      :link '(custom-manual "(message)Insertion Variables")
559    :type 'regexp)    :type 'regexp)
560    
561  (defcustom message-cancel-message "I am canceling my own article.\n"  (defcustom message-cancel-message "I am canceling my own article.\n"
562    "Message to be inserted in the cancel message."    "Message to be inserted in the cancel message."
563    :group 'message-interface    :group 'message-interface
564      :link '(custom-manual "(message)Canceling News")
565    :type 'string)    :type 'string)
566    
567  ;; Useful to set in site-init.el  ;; Useful to set in site-init.el
# Line 350  variable `mail-header-separator'. Line 573  variable `mail-header-separator'.
573    
574  Valid values include `message-send-mail-with-sendmail' (the default),  Valid values include `message-send-mail-with-sendmail' (the default),
575  `message-send-mail-with-mh', `message-send-mail-with-qmail',  `message-send-mail-with-mh', `message-send-mail-with-qmail',
576  `smtpmail-send-it' and `feedmail-send-it'.  `message-smtpmail-send-it', `smtpmail-send-it' and `feedmail-send-it'.
577    
578  See also `send-mail-function'."  See also `send-mail-function'."
579    :type '(radio (function-item message-send-mail-with-sendmail)    :type '(radio (function-item message-send-mail-with-sendmail)
580                  (function-item message-send-mail-with-mh)                  (function-item message-send-mail-with-mh)
581                  (function-item message-send-mail-with-qmail)                  (function-item message-send-mail-with-qmail)
582                    (function-item message-smtpmail-send-it)
583                  (function-item smtpmail-send-it)                  (function-item smtpmail-send-it)
584                  (function-item feedmail-send-it)                  (function-item feedmail-send-it)
585                  (function :tag "Other"))                  (function :tag "Other"))
586    :group 'message-sending    :group 'message-sending
587      :link '(custom-manual "(message)Mail Variables")
588    :group 'message-mail)    :group 'message-mail)
589    
590  (defcustom message-send-news-function 'message-send-news  (defcustom message-send-news-function 'message-send-news
# Line 368  The headers should be delimited by a lin Line 593  The headers should be delimited by a lin
593  variable `mail-header-separator'."  variable `mail-header-separator'."
594    :group 'message-sending    :group 'message-sending
595    :group 'message-news    :group 'message-news
596      :link '(custom-manual "(message)News Variables")
597    :type 'function)    :type 'function)
598    
599  (defcustom message-reply-to-function nil  (defcustom message-reply-to-function nil
# Line 375  variable `mail-header-separator'." Line 601  variable `mail-header-separator'."
601  This function should pick out addresses from the To, Cc, and From headers  This function should pick out addresses from the To, Cc, and From headers
602  and respond with new To and Cc headers."  and respond with new To and Cc headers."
603    :group 'message-interface    :group 'message-interface
604      :link '(custom-manual "(message)Reply")
605    :type '(choice function (const nil)))    :type '(choice function (const nil)))
606    
607  (defcustom message-wide-reply-to-function nil  (defcustom message-wide-reply-to-function nil
# Line 382  and respond with new To and Cc headers." Line 609  and respond with new To and Cc headers."
609  This function should pick out addresses from the To, Cc, and From headers  This function should pick out addresses from the To, Cc, and From headers
610  and respond with new To and Cc headers."  and respond with new To and Cc headers."
611    :group 'message-interface    :group 'message-interface
612      :link '(custom-manual "(message)Wide Reply")
613    :type '(choice function (const nil)))    :type '(choice function (const nil)))
614    
615  (defcustom message-followup-to-function nil  (defcustom message-followup-to-function nil
# Line 389  and respond with new To and Cc headers." Line 617  and respond with new To and Cc headers."
617  This function should pick out addresses from the To, Cc, and From headers  This function should pick out addresses from the To, Cc, and From headers
618  and respond with new To and Cc headers."  and respond with new To and Cc headers."
619    :group 'message-interface    :group 'message-interface
620      :link '(custom-manual "(message)Followup")
621    :type '(choice function (const nil)))    :type '(choice function (const nil)))
622    
623  (defcustom message-use-followup-to 'ask  (defcustom message-use-followup-to 'ask
# Line 398  query before using the \"poster\" value. Line 627  query before using the \"poster\" value.
627  always query the user whether to use the value.  If it is the symbol  always query the user whether to use the value.  If it is the symbol
628  `use', always use the value."  `use', always use the value."
629    :group 'message-interface    :group 'message-interface
630      :link '(custom-manual "(message)Followup")
631    :type '(choice (const :tag "ignore" nil)    :type '(choice (const :tag "ignore" nil)
632                     (const :tag "use & query" t)
633                   (const use)                   (const use)
634                   (const ask)))                   (const ask)))
635    
636    (defcustom message-use-mail-followup-to 'use
637      "*Specifies what to do with Mail-Followup-To header.
638    If nil, always ignore the header.  If it is the symbol `ask', always
639    query the user whether to use the value.  If it is the symbol `use',
640    always use the value."
641      :group 'message-interface
642      :link '(custom-manual "(message)Mailing Lists")
643      :type '(choice (const :tag "ignore" nil)
644                     (const use)
645                     (const ask)))
646    
647    (defcustom message-subscribed-address-functions nil
648      "*Specifies functions for determining list subscription.
649    If nil, do not attempt to determine list subscription with functions.
650    If non-nil, this variable contains a list of functions which return
651    regular expressions to match lists.  These functions can be used in
652    conjunction with `message-subscribed-regexps' and
653    `message-subscribed-addresses'."
654      :group 'message-interface
655      :link '(custom-manual "(message)Mailing Lists")
656      :type '(repeat sexp))
657    
658    (defcustom message-subscribed-address-file nil
659      "*A file containing addresses the user is subscribed to.
660    If nil, do not look at any files to determine list subscriptions.  If
661    non-nil, each line of this file should be a mailing list address."
662      :group 'message-interface
663      :link '(custom-manual "(message)Mailing Lists")
664      :type '(radio (file :format "%t: %v\n" :size 0)
665                    (const nil)))
666    
667    (defcustom message-subscribed-addresses nil
668      "*Specifies a list of addresses the user is subscribed to.
669    If nil, do not use any predefined list subscriptions.  This list of
670    addresses can be used in conjunction with
671    `message-subscribed-address-functions' and `message-subscribed-regexps'."
672      :group 'message-interface
673      :link '(custom-manual "(message)Mailing Lists")
674      :type '(repeat string))
675    
676    (defcustom message-subscribed-regexps nil
677      "*Specifies a list of addresses the user is subscribed to.
678    If nil, do not use any predefined list subscriptions.  This list of
679    regular expressions can be used in conjunction with
680    `message-subscribed-address-functions' and `message-subscribed-addresses'."
681      :group 'message-interface
682      :link '(custom-manual "(message)Mailing Lists")
683      :type '(repeat regexp))
684    
685    (defcustom message-allow-no-recipients 'ask
686      "Specifies what to do when there are no recipients other than Gcc/Fcc.
687    If it is the symbol `always', the posting is allowed.  If it is the
688    symbol `never', the posting is not allowed.  If it is the symbol
689    `ask', you are prompted."
690      :group 'message-interface
691      :link '(custom-manual "(message)Message Headers")
692      :type '(choice (const always)
693                     (const never)
694                     (const ask)))
695    
696  (defcustom message-sendmail-f-is-evil nil  (defcustom message-sendmail-f-is-evil nil
697    "*Non-nil means don't add \"-f username\" to the sendmail command line.    "*Non-nil means don't add \"-f username\" to the sendmail command line.
698  Doing so would be even more evil than leaving it out."  Doing so would be even more evil than leaving it out."
699    :group 'message-sending    :group 'message-sending
700      :link '(custom-manual "(message)Mail Variables")
701    :type 'boolean)    :type 'boolean)
702    
703    (defcustom message-sendmail-envelope-from nil
704      "*Envelope-from when sending mail with sendmail.
705    If this is nil, use `user-mail-address'.  If it is the symbol
706    `header', use the From: header of the message."
707      :type '(choice (string :tag "From name")
708                     (const :tag "Use From: header from message" header)
709                     (const :tag "Use `user-mail-address'" nil))
710      :link '(custom-manual "(message)Mail Variables")
711      :group 'message-sending)
712    
713  ;; qmail-related stuff  ;; qmail-related stuff
714  (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"  (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"
715    "Location of the qmail-inject program."    "Location of the qmail-inject program."
716    :group 'message-sending    :group 'message-sending
717      :link '(custom-manual "(message)Mail Variables")
718    :type 'file)    :type 'file)
719    
720  (defcustom message-qmail-inject-args nil  (defcustom message-qmail-inject-args nil
721    "Arguments passed to qmail-inject programs.    "Arguments passed to qmail-inject programs.
722  This should be a list of strings, one string for each argument.  This should be a list of strings, one string for each argument.  It
723    may also be a function.
724    
725  For e.g., if you wish to set the envelope sender address so that bounces  For e.g., if you wish to set the envelope sender address so that bounces
726  go to the right place or to deal with listserv's usage of that address, you  go to the right place or to deal with listserv's usage of that address, you
727  might set this variable to '(\"-f\" \"you@some.where\")."  might set this variable to '(\"-f\" \"you@some.where\")."
728    :group 'message-sending    :group 'message-sending
729    :type '(repeat string))    :link '(custom-manual "(message)Mail Variables")
730      :type '(choice (function)
731                     (repeat string)))
732    
733  (defvar message-cater-to-broken-inn t  (defvar message-cater-to-broken-inn t
734    "Non-nil means Gnus should not fold the `References' header.    "Non-nil means Gnus should not fold the `References' header.
# Line 449  variable isn't used." Line 755  variable isn't used."
755    ;; create a dependence to `gnus.el'.    ;; create a dependence to `gnus.el'.
756    :type 'sexp)    :type 'sexp)
757    
758  (defcustom message-generate-headers-first nil  ;; FIXME: This should be a temporary workaround until someone implements a
759    "*If non-nil, generate all possible headers before composing."  ;; proper solution.  If a crash happens while replying, the auto-save file
760    ;; will *not* have a `References:' header if `message-generate-headers-first'
761    ;; is nil.  See: http://article.gmane.org/gmane.emacs.gnus.general/51138
762    (defcustom message-generate-headers-first '(references)
763      "Which headers should be generated before starting to compose a message.
764    If `t', generate all required headers.  This can also be a list of headers to
765    generate.  The variables `message-required-news-headers' and
766    `message-required-mail-headers' specify which headers to generate.
767    
768    Note that the variable `message-deletable-headers' specifies headers which
769    are to be deleted and then re-generated before sending, so this variable
770    will not have a visible effect for those headers."
771    :group 'message-headers    :group 'message-headers
772    :type 'boolean)    :link '(custom-manual "(message)Message Headers")
773      :type '(choice (const :tag "None" nil)
774                     (const :tag "References" '(references))
775                     (const :tag "All" t)
776                     (repeat (sexp :tag "Header"))))
777    
778  (defcustom message-setup-hook nil  (defcustom message-setup-hook nil
779    "Normal hook, run each time a new outgoing message is initialized.    "Normal hook, run each time a new outgoing message is initialized.
780  The function `message-setup' runs this hook."  The function `message-setup' runs this hook."
781    :group 'message-various    :group 'message-various
782      :link '(custom-manual "(message)Various Message Variables")
783    :type 'hook)    :type 'hook)
784    
785  (defcustom message-cancel-hook nil  (defcustom message-cancel-hook nil
786    "Hook run when cancelling articles."    "Hook run when cancelling articles."
787    :group 'message-various    :group 'message-various
788      :link '(custom-manual "(message)Various Message Variables")
789    :type 'hook)    :type 'hook)
790    
791  (defcustom message-signature-setup-hook nil  (defcustom message-signature-setup-hook nil
# Line 470  The function `message-setup' runs this h Line 793  The function `message-setup' runs this h
793  It is run after the headers have been inserted and before  It is run after the headers have been inserted and before
794  the signature is inserted."  the signature is inserted."
795    :group 'message-various    :group 'message-various
796      :link '(custom-manual "(message)Various Message Variables")
797    :type 'hook)    :type 'hook)
798    
799  (defcustom message-mode-hook nil  (defcustom message-mode-hook nil
# Line 485  the signature is inserted." Line 809  the signature is inserted."
809  (defcustom message-header-setup-hook nil  (defcustom message-header-setup-hook nil
810    "Hook called narrowed to the headers when setting up a message buffer."    "Hook called narrowed to the headers when setting up a message buffer."
811    :group 'message-various    :group 'message-various
812      :link '(custom-manual "(message)Various Message Variables")
813    :type 'hook)    :type 'hook)
814    
815    (defcustom message-minibuffer-local-map
816      (let ((map (make-sparse-keymap 'message-minibuffer-local-map)))
817        (set-keymap-parent map minibuffer-local-map)
818        map)
819      "Keymap for `message-read-from-minibuffer'.")
820    
821  ;;;###autoload  ;;;###autoload
822  (defcustom message-citation-line-function 'message-insert-citation-line  (defcustom message-citation-line-function 'message-insert-citation-line
823    "*Function called to insert the \"Whomever writes:\" line."    "*Function called to insert the \"Whomever writes:\" line.
824    
825    Note that Gnus provides a feature where the reader can click on
826    `writes:' to hide the cited text.  If you change this line too much,
827    people who read your message will have to change their Gnus
828    configuration.  See the variable `gnus-cite-attribution-suffix'."
829    :type 'function    :type 'function
830      :link '(custom-manual "(message)Insertion Variables")
831    :group 'message-insertion)    :group 'message-insertion)
832    
833  ;;;###autoload  ;;;###autoload
834  (defcustom message-yank-prefix "> "  (defcustom message-yank-prefix "> "
835    "*Prefix inserted on the lines of yanked messages."    "*Prefix inserted on the lines of yanked messages.
836    Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
837    See also `message-yank-cited-prefix'."
838      :type 'string
839      :link '(custom-manual "(message)Insertion Variables")
840      :group 'message-insertion)
841    
842    (defcustom message-yank-cited-prefix ">"
843      "*Prefix inserted on cited or empty lines of yanked messages.
844    Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
845    See also `message-yank-prefix'."
846    :type 'string    :type 'string
847      :link '(custom-manual "(message)Insertion Variables")
848    :group 'message-insertion)    :group 'message-insertion)
849    
850  (defcustom message-indentation-spaces 3  (defcustom message-indentation-spaces 3
851    "*Number of spaces to insert at the beginning of each cited line.    "*Number of spaces to insert at the beginning of each cited line.
852  Used by `message-yank-original' via `message-yank-cite'."  Used by `message-yank-original' via `message-yank-cite'."
853    :group 'message-insertion    :group 'message-insertion
854      :link '(custom-manual "(message)Insertion Variables")
855    :type 'integer)    :type 'integer)
856    
857  ;;;###autoload  ;;;###autoload
# Line 515  Note that `message-cite-original' uses ` Line 864  Note that `message-cite-original' uses `
864                  (function-item message-cite-original-without-signature)                  (function-item message-cite-original-without-signature)
865                  (function-item sc-cite-original)                  (function-item sc-cite-original)
866                  (function :tag "Other"))                  (function :tag "Other"))
867      :link '(custom-manual "(message)Insertion Variables")
868    :group 'message-insertion)    :group 'message-insertion)
869    
870  ;;;###autoload  ;;;###autoload
# Line 524  This can also be a list of functions.  E Line 874  This can also be a list of functions.  E
874  citation between (point) and (mark t).  And each function should leave  citation between (point) and (mark t).  And each function should leave
875  point and mark around the citation text as modified."  point and mark around the citation text as modified."
876    :type 'function    :type 'function
877      :link '(custom-manual "(message)Insertion Variables")
878    :group 'message-insertion)    :group 'message-insertion)
879    
 (defvar message-abbrevs-loaded nil)  
   
880  ;;;###autoload  ;;;###autoload
881  (defcustom message-signature t  (defcustom message-signature t
882    "*String to be inserted at the end of the message buffer.    "*String to be inserted at the end of the message buffer.
# Line 535  If t, the `message-signature-file' file Line 884  If t, the `message-signature-file' file
884  If a function, the result from the function will be used instead.  If a function, the result from the function will be used instead.
885  If a form, the result from the form will be used instead."  If a form, the result from the form will be used instead."
886    :type 'sexp    :type 'sexp
887      :link '(custom-manual "(message)Insertion Variables")
888    :group 'message-insertion)    :group 'message-insertion)
889    
890  ;;;###autoload  ;;;###autoload
# Line 543  If a form, the result from the form will Line 893  If a form, the result from the form will
893  Ignored if the named file doesn't exist.  Ignored if the named file doesn't exist.
894  If nil, don't insert a signature."  If nil, don't insert a signature."
895    :type '(choice file (const :tags "None" nil))    :type '(choice file (const :tags "None" nil))
896      :link '(custom-manual "(message)Insertion Variables")
897      :group 'message-insertion)
898    
899    ;;;###autoload
900    (defcustom message-signature-insert-empty-line t
901      "*If non-nil, insert an empty line before the signature separator."
902      :type 'boolean
903      :link '(custom-manual "(message)Insertion Variables")
904    :group 'message-insertion)    :group 'message-insertion)
905    
906  (defcustom message-distribution-function nil  (defcustom message-distribution-function nil
907    "*Function called to return a Distribution header."    "*Function called to return a Distribution header."
908    :group 'message-news    :group 'message-news
909    :group 'message-headers    :group 'message-headers
910      :link '(custom-manual "(message)News Headers")
911    :type '(choice function (const nil)))    :type '(choice function (const nil)))
912    
913  (defcustom message-expires 14  (defcustom message-expires 14
# Line 569  If stringp, use this; if non-nil, use no Line 928  If stringp, use this; if non-nil, use no
928                   (sexp :tag "none" :format "%t" t)))                   (sexp :tag "none" :format "%t" t)))
929    
930  (defvar message-reply-buffer nil)  (defvar message-reply-buffer nil)
931  (defvar message-reply-headers nil)  (defvar message-reply-headers nil
932      "The headers of the current replied article.
933    It is a vector of the following headers:
934    \[number subject from date id references chars lines xref extra].")
935  (defvar message-newsreader nil)  (defvar message-newsreader nil)
936  (defvar message-mailer nil)  (defvar message-mailer nil)
937  (defvar message-sent-message-via nil)  (defvar message-sent-message-via nil)
# Line 594  If stringp, use this; if non-nil, use no Line 956  If stringp, use this; if non-nil, use no
956  It is inserted before you edit the message, so you can edit or delete  It is inserted before you edit the message, so you can edit or delete
957  these lines."  these lines."
958    :group 'message-headers    :group 'message-headers
959      :link '(custom-manual "(message)Message Headers")
960    :type 'message-header-lines)    :type 'message-header-lines)
961    
962  (defcustom message-default-mail-headers ""  (defcustom message-default-mail-headers ""
963    "*A string of header lines to be inserted in outgoing mails."    "*A string of header lines to be inserted in outgoing mails."
964    :group 'message-headers    :group 'message-headers
965    :group 'message-mail    :group 'message-mail
966      :link '(custom-manual "(message)Mail Headers")
967    :type 'message-header-lines)    :type 'message-header-lines)
968    
969  (defcustom message-default-news-headers ""  (defcustom message-default-news-headers ""
970    "*A string of header lines to be inserted in outgoing news articles."    "*A string of header lines to be inserted in outgoing news articles."
971    :group 'message-headers    :group 'message-headers
972    :group 'message-news    :group 'message-news
973      :link '(custom-manual "(message)News Headers")
974    :type 'message-header-lines)    :type 'message-header-lines)
975    
976  ;; Note: could use /usr/ucb/mail instead of sendmail;  ;; Note: could use /usr/ucb/mail instead of sendmail;
# Line 633  these lines." Line 998  these lines."
998  The value should be an expression to test whether the problem will  The value should be an expression to test whether the problem will
999  actually occur."  actually occur."
1000    :group 'message-sending    :group 'message-sending
1001      :link '(custom-manual "(message)Mail Variables")
1002    :type 'sexp)    :type 'sexp)
1003    
1004  ;;;###autoload  ;;;###autoload
# Line 671  mail aliases off." Line 1037  mail aliases off."
1037    "*Directory where Message auto-saves buffers if Gnus isn't running.    "*Directory where Message auto-saves buffers if Gnus isn't running.
1038  If nil, Message won't auto-save."  If nil, Message won't auto-save."
1039    :group 'message-buffers    :group 'message-buffers
1040      :link '(custom-manual "(message)Various Message Variables")
1041    :type '(choice directory (const :tag "Don't auto-save" nil)))    :type '(choice directory (const :tag "Don't auto-save" nil)))
1042    
 (defcustom message-buffer-naming-style 'unique  
   "*The way new message buffers are named.  
 Valid values are `unique' and `unsent'."  
   :version "21.1"  
   :group 'message-buffers  
   :type '(choice (const :tag "unique" unique)  
                  (const :tag "unsent" unsent)))  
   
1043  (defcustom message-default-charset  (defcustom message-default-charset
1044    (and (not (mm-multibyte-p)) 'iso-8859-1)    (and (not (mm-multibyte-p)) 'iso-8859-1)
1045    "Default charset used in non-MULE Emacsen.    "Default charset used in non-MULE Emacsen.
1046  If nil, you might be asked to input the charset."  If nil, you might be asked to input the charset."
1047    :version "21.1"    :version "21.1"
1048    :group 'message    :group 'message
1049      :link '(custom-manual "(message)Various Message Variables")
1050    :type 'symbol)    :type 'symbol)
1051    
1052  (defcustom message-dont-reply-to-names  (defcustom message-dont-reply-to-names
1053    (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names)    (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names)
1054    "*A regexp specifying names to prune when doing wide replies.    "*A regexp specifying addresses to prune when doing wide replies.
1055  A value of nil means exclude your own name only."  A value of nil means exclude your own user name only."
1056    :version "21.1"    :version "21.1"
1057    :group 'message    :group 'message
1058      :link '(custom-manual "(message)Wide Reply")
1059    :type '(choice (const :tag "Yourself" nil)    :type '(choice (const :tag "Yourself" nil)
1060                   regexp))                   regexp))
1061    
1062    (defvar message-shoot-gnksa-feet nil
1063      "*A list of GNKSA feet you are allowed to shoot.
1064    Gnus gives you all the opportunity you could possibly want for
1065    shooting yourself in the foot.  Also, Gnus allows you to shoot the
1066    feet of Good Net-Keeping Seal of Approval.  The following are foot
1067    candidates:
1068    `empty-article'     Allow you to post an empty article;
1069    `quoted-text-only'  Allow you to post quoted text only;
1070    `multiple-copies'   Allow you to post multiple copies;
1071    `cancel-messages'   Allow you to cancel or supersede messages from
1072                        your other email addresses.")
1073    
1074    (defsubst message-gnksa-enable-p (feature)
1075      (or (not (listp message-shoot-gnksa-feet))
1076          (memq feature message-shoot-gnksa-feet)))
1077    
1078    (defcustom message-hidden-headers nil
1079      "Regexp of headers to be hidden when composing new messages.
1080    This can also be a list of regexps to match headers.  Or a list
1081    starting with `not' and followed by regexps."
1082      :group 'message
1083      :link '(custom-manual "(message)Message Headers")
1084      :type '(repeat regexp))
1085    
1086  ;;; Internal variables.  ;;; Internal variables.
1087  ;;; Well, not really internal.  ;;; Well, not really internal.
1088    
# Line 709  A value of nil means exclude your own na Line 1094  A value of nil means exclude your own na
1094      table)      table)
1095    "Syntax table used while in Message mode.")    "Syntax table used while in Message mode.")
1096    
 (defvar message-mode-abbrev-table text-mode-abbrev-table  
   "Abbrev table used in Message mode buffers.  
 Defaults to `text-mode-abbrev-table'.")  
   
1097  (defface message-header-to-face  (defface message-header-to-face
1098    '((((class color)    '((((class color)
1099        (background dark))        (background dark))
1100       (:foreground "green2" :weight bold))       (:foreground "green2" :bold t))
1101      (((class color)      (((class color)
1102        (background light))        (background light))
1103       (:foreground "MidnightBlue" :weight bold))       (:foreground "MidnightBlue" :bold t))
1104      (t      (t
1105       (:weight bold :slant italic)))       (:bold t :italic t)))
1106    "Face used for displaying From headers."    "Face used for displaying From headers."
1107    :group 'message-faces)    :group 'message-faces)
1108    
1109  (defface message-header-cc-face  (defface message-header-cc-face
1110    '((((class color)    '((((class color)
1111        (background dark))        (background dark))
1112       (:foreground "green4" :weight bold))       (:foreground "green4" :bold t))
1113      (((class color)      (((class color)
1114        (background light))        (background light))
1115       (:foreground "MidnightBlue"))       (:foreground "MidnightBlue"))
1116      (t      (t
1117       (:weight bold)))       (:bold t)))
1118    "Face used for displaying Cc headers."    "Face used for displaying Cc headers."
1119    :group 'message-faces)    :group 'message-faces)
1120    
# Line 743  Defaults to `text-mode-abbrev-table'.") Line 1124  Defaults to `text-mode-abbrev-table'.")
1124       (:foreground "green3"))       (:foreground "green3"))
1125      (((class color)      (((class color)
1126        (background light))        (background light))
1127       (:foreground "navy blue" :weight bold))       (:foreground "navy blue" :bold t))
1128      (t      (t
1129       (:weight bold)))       (:bold t)))
1130    "Face used for displaying subject headers."    "Face used for displaying subject headers."
1131    :group 'message-faces)    :group 'message-faces)
1132    
1133  (defface message-header-newsgroups-face  (defface message-header-newsgroups-face
1134    '((((class color)    '((((class color)
1135        (background dark))        (background dark))
1136       (:foreground "yellow" :weight bold :slant italic))       (:foreground "yellow" :bold t :italic t))
1137      (((class color)      (((class color)
1138        (background light))        (background light))
1139       (:foreground "blue4" :weight bold :slant italic))       (:foreground "blue4" :bold t :italic t))
1140      (t      (t
1141       (:weight bold :slant italic)))       (:bold t :italic t)))
1142    "Face used for displaying newsgroups headers."    "Face used for displaying newsgroups headers."
1143    :group 'message-faces)    :group 'message-faces)
1144    
# Line 769  Defaults to `text-mode-abbrev-table'.") Line 1150  Defaults to `text-mode-abbrev-table'.")
1150        (background light))        (background light))
1151       (:foreground "steel blue"))       (:foreground "steel blue"))
1152      (t      (t
1153       (:weight bold :slant italic)))       (:bold t :italic t)))
1154    "Face used for displaying newsgroups headers."    "Face used for displaying newsgroups headers."
1155    :group 'message-faces)    :group 'message-faces)
1156    
# Line 781  Defaults to `text-mode-abbrev-table'.") Line 1162  Defaults to `text-mode-abbrev-table'.")
1162        (background light))        (background light))
1163       (:foreground "cornflower blue"))       (:foreground "cornflower blue"))
1164      (t      (t
1165       (:weight bold)))       (:bold t)))
1166    "Face used for displaying header names."    "Face used for displaying header names."
1167    :group 'message-faces)    :group 'message-faces)
1168    
# Line 793  Defaults to `text-mode-abbrev-table'.") Line 1174  Defaults to `text-mode-abbrev-table'.")
1174        (background light))        (background light))
1175       (:foreground "blue"))       (:foreground "blue"))
1176      (t      (t
1177       (:weight bold)))       (:bold t)))
1178    "Face used for displaying X-Header headers."    "Face used for displaying X-Header headers."
1179    :group 'message-faces)    :group 'message-faces)
1180    
# Line 805  Defaults to `text-mode-abbrev-table'.") Line 1186  Defaults to `text-mode-abbrev-table'.")
1186        (background light))        (background light))
1187       (:foreground "brown"))       (:foreground "brown"))
1188      (t      (t
1189       (:weight bold)))       (:bold t)))
1190    "Face used for displaying the separator."    "Face used for displaying the separator."
1191    :group 'message-faces)    :group 'message-faces)
1192    
# Line 817  Defaults to `text-mode-abbrev-table'.") Line 1198  Defaults to `text-mode-abbrev-table'.")
1198        (background light))        (background light))
1199       (:foreground "red"))       (:foreground "red"))
1200      (t      (t
1201       (:weight bold)))       (:bold t)))
1202    "Face used for displaying cited text names."    "Face used for displaying cited text names."
1203    :group 'message-faces)    :group 'message-faces)
1204    
# Line 829  Defaults to `text-mode-abbrev-table'.") Line 1210  Defaults to `text-mode-abbrev-table'.")
1210        (background light))        (background light))
1211       (:foreground "ForestGreen"))       (:foreground "ForestGreen"))
1212      (t      (t
1213       (:weight bold)))       (:bold t)))
1214    "Face used for displaying MML."    "Face used for displaying MML."
1215    :group 'message-faces)    :group 'message-faces)
1216    
1217    (defun message-font-lock-make-header-matcher (regexp)
1218      (let ((form
1219             `(lambda (limit)
1220                (let ((start (point)))
1221                  (save-restriction
1222                    (widen)
1223                    (goto-char (point-min))
1224                    (if (re-search-forward
1225                         (concat "^" (regexp-quote mail-header-separator) "$")
1226                         nil t)
1227                        (setq limit (min limit (match-beginning 0))))
1228                    (goto-char start))
1229                  (and (< start limit)
1230                       (re-search-forward ,regexp limit t))))))
1231        (if (featurep 'bytecomp)
1232            (byte-compile form)
1233          form)))
1234    
1235  (defvar message-font-lock-keywords  (defvar message-font-lock-keywords
1236    (let* ((cite-prefix "[:alpha:]")    (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
1237           (cite-suffix (concat cite-prefix "0-9_.@-"))      `((,(message-font-lock-make-header-matcher
1238           (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))           (concat "^\\([Tt]o:\\)" content))
     `((,(concat "^\\([Tt]o:\\)" content)  
1239         (1 'message-header-name-face)         (1 'message-header-name-face)
1240         (2 'message-header-to-face nil t))         (2 'message-header-to-face nil t))
1241        (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)        (,(message-font-lock-make-header-matcher
1242             (concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content))
1243         (1 'message-header-name-face)         (1 'message-header-name-face)
1244         (2 'message-header-cc-face nil t))         (2 'message-header-cc-face nil t))
1245        (,(concat "^\\([Ss]ubject:\\)" content)        (,(message-font-lock-make-header-matcher
1246             (concat "^\\([Ss]ubject:\\)" content))
1247         (1 'message-header-name-face)         (1 'message-header-name-face)
1248         (2 'message-header-subject-face nil t))         (2 'message-header-subject-face nil t))
1249        (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)        (,(message-font-lock-make-header-matcher
1250             (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content))
1251         (1 'message-header-name-face)         (1 'message-header-name-face)
1252         (2 'message-header-newsgroups-face nil t))         (2 'message-header-newsgroups-face nil t))
1253        (,(concat "^\\([A-Z][^: \n\t]+:\\)" content)        (,(message-font-lock-make-header-matcher
1254             (concat "^\\([A-Z][^: \n\t]+:\\)" content))
1255         (1 'message-header-name-face)         (1 'message-header-name-face)
1256         (2 'message-header-other-face nil t))         (2 'message-header-other-face nil t))
1257        (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content)        (,(message-font-lock-make-header-matcher
1258             (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
1259         (1 'message-header-name-face)         (1 'message-header-name-face)
1260         (2 'message-header-name-face))         (2 'message-header-name-face))
1261        ,@(if (and mail-header-separator        ,@(if (and mail-header-separator
# Line 860  Defaults to `text-mode-abbrev-table'.") Line 1263  Defaults to `text-mode-abbrev-table'.")
1263              `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")              `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
1264                 1 'message-separator-face))                 1 'message-separator-face))
1265            nil)            nil)
1266        (,(concat "^[ \t]*"        ((lambda (limit)
1267                  "\\([" cite-prefix "]+[" cite-suffix "]*\\)?"           (re-search-forward (concat "^\\("
1268                  "[:>|}].*")                                      message-cite-prefix-regexp
1269                                        "\\).*")
1270                                limit t))
1271         (0 'message-cited-text-face))         (0 'message-cited-text-face))
1272        ("<#/?\\(multipart\\|part\\|external\\|mml\\).*>"        ("<#/?\\(multipart\\|part\\|external\\|mml\\|secure\\)[^>]*>"
1273         (0 'message-mml-face))))         (0 'message-mml-face))))
1274    "Additional expressions to highlight in Message mode.")    "Additional expressions to highlight in Message mode.")
1275    
1276    
1277  ;; XEmacs does it like this.  For Emacs, we have to set the  ;; XEmacs does it like this.  For Emacs, we have to set the
1278  ;; `font-lock-defaults' buffer-local variable.  ;; `font-lock-defaults' buffer-local variable.
1279  (put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t))  (put 'message-mode 'font-lock-defaults '(message-font-lock-keywords t))
# Line 882  Defaults to `text-mode-abbrev-table'.") Line 1288  Defaults to `text-mode-abbrev-table'.")
1288  The cdr of each entry is a function for applying the face to a region.")  The cdr of each entry is a function for applying the face to a region.")
1289    
1290  (defcustom message-send-hook nil  (defcustom message-send-hook nil
1291    "Hook run before sending messages."    "Hook run before sending messages.
1292    This hook is run quite early when sending."
1293    :group 'message-various    :group 'message-various
1294    :options '(ispell-message)    :options '(ispell-message)
1295      :link '(custom-manual "(message)Various Message Variables")
1296    :type 'hook)    :type 'hook)
1297    
1298  (defcustom message-send-mail-hook nil  (defcustom message-send-mail-hook nil
1299    "Hook run before sending mail messages."    "Hook run before sending mail messages.
1300    This hook is run very late -- just before the message is sent as
1301    mail."
1302    :group 'message-various    :group 'message-various
1303      :link '(custom-manual "(message)Various Message Variables")
1304    :type 'hook)    :type 'hook)
1305    
1306  (defcustom message-send-news-hook nil  (defcustom message-send-news-hook nil
1307    "Hook run before sending news messages."    "Hook run before sending news messages.
1308    This hook is run very late -- just before the message is sent as
1309    news."
1310    :group 'message-various    :group 'message-various
1311      :link '(custom-manual "(message)Various Message Variables")
1312    :type 'hook)    :type 'hook)
1313    
1314  (defcustom message-sent-hook nil  (defcustom message-sent-hook nil
# Line 907  The cdr of each entry is a function for Line 1321  The cdr of each entry is a function for
1321    
1322  (defvar message-draft-coding-system  (defvar message-draft-coding-system
1323    mm-auto-save-coding-system    mm-auto-save-coding-system
1324    "Coding system to compose mail.")    "*Coding system to compose mail.
1325    If you'd like to make it possible to share draft files between XEmacs
1326    and Emacs, you may use `iso-2022-7bit' for this value at your own risk.
1327    Note that the coding-system `iso-2022-7bit' isn't suitable to all data.")
1328    
1329  (defcustom message-send-mail-partially-limit 1000000  (defcustom message-send-mail-partially-limit 1000000
1330    "The limitation of messages sent as message/partial.    "The limitation of messages sent as message/partial.
# Line 915  The lower bound of message size in chara Line 1332  The lower bound of message size in chara
1332  should be sent in several parts.  If it is nil, the size is unlimited."  should be sent in several parts.  If it is nil, the size is unlimited."
1333    :version "21.1"    :version "21.1"
1334    :group 'message-buffers    :group 'message-buffers
1335      :link '(custom-manual "(message)Mail Variables")
1336    :type '(choice (const :tag "unlimited" nil)    :type '(choice (const :tag "unlimited" nil)
1337                   (integer 1000000)))                   (integer 1000000)))
1338    
# Line 922  should be sent in several parts.  If it Line 1340  should be sent in several parts.  If it
1340    "A regexp to match the alternative email addresses.    "A regexp to match the alternative email addresses.
1341  The first matched address (not primary one) is used in the From field."  The first matched address (not primary one) is used in the From field."
1342    :group 'message-headers    :group 'message-headers
1343      :link '(custom-manual "(message)Message Headers")
1344    :type '(choice (const :tag "Always use primary" nil)    :type '(choice (const :tag "Always use primary" nil)
1345                   regexp))                   regexp))
1346    
1347    (defcustom message-hierarchical-addresses nil
1348      "A list of hierarchical mail address definitions.
1349    
1350    Inside each entry, the first address is the \"top\" address, and
1351    subsequent addresses are subaddresses; this is used to indicate that
1352    mail sent to the first address will automatically be delivered to the
1353    subaddresses.  So if the first address appears in the recipient list
1354    for a message, the subaddresses will be removed (if present) before
1355    the mail is sent.  All addresses in this structure should be
1356    downcased."
1357      :group 'message-headers
1358      :type '(repeat (repeat string)))
1359    
1360  (defcustom message-mail-user-agent nil  (defcustom message-mail-user-agent nil
1361    "Like `mail-user-agent'.    "Like `mail-user-agent'.
1362  Except if it is nil, use Gnus native MUA; if it is t, use  Except if it is nil, use Gnus native MUA; if it is t, use
# Line 945  Except if it is nil, use Gnus native MUA Line 1377  Except if it is nil, use Gnus native MUA
1377    :version "21.1"    :version "21.1"
1378    :group 'message)    :group 'message)
1379    
1380    (defcustom message-wide-reply-confirm-recipients nil
1381      "Whether to confirm a wide reply to multiple email recipients.
1382    If this variable is nil, don't ask whether to reply to all recipients.
1383    If this variable is non-nil, pose the question \"Reply to all
1384    recipients?\" before a wide reply to multiple recipients.  If the user
1385    answers yes, reply to all recipients as usual.  If the user answers
1386    no, only reply back to the author."
1387      :version "21.3"
1388      :group 'message-headers
1389      :link '(custom-manual "(message)Wide Reply")
1390      :type 'boolean)
1391    
1392    (defcustom message-user-fqdn nil
1393      "*Domain part of Messsage-Ids."
1394      :group 'message-headers
1395      :link '(custom-manual "(message)News Headers")
1396      :type '(radio (const :format "%v  " nil)
1397                    (string :format "FQDN: %v\n" :size 0)))
1398    
1399    (defcustom message-use-idna (and (condition-case nil (require 'idna)
1400                                       (file-error))
1401                                     (mm-coding-system-p 'utf-8)
1402                                     (executable-find idna-program)
1403                                     'ask)
1404      "Whether to encode non-ASCII in domain names into ASCII according to IDNA."
1405      :group 'message-headers
1406      :link '(custom-manual "(message)IDNA")
1407      :type '(choice (const :tag "Ask" ask)
1408                     (const :tag "Never" nil)
1409                     (const :tag "Always" t)))
1410    
1411  ;;; Internal variables.  ;;; Internal variables.
1412    
1413  (defvar message-sending-message "Sending...")  (defvar message-sending-message "Sending...")
# Line 954  Except if it is nil, use Gnus native MUA Line 1417  Except if it is nil, use Gnus native MUA
1417  (defvar message-draft-article nil)  (defvar message-draft-article nil)
1418  (defvar message-mime-part nil)  (defvar message-mime-part nil)
1419  (defvar message-posting-charset nil)  (defvar message-posting-charset nil)
1420    (defvar message-inserted-headers nil)
1421    
1422  ;; Byte-compiler warning  ;; Byte-compiler warning
1423  (eval-when-compile  (eval-when-compile
# Line 979  Except if it is nil, use Gnus native MUA Line 1443  Except if it is nil, use Gnus native MUA
1443       ;; can be removed, e.g.       ;; can be removed, e.g.
1444       ;;         From: joe@y.z (Joe      K       ;;         From: joe@y.z (Joe      K
1445       ;;                 User)       ;;                 User)
1446       ;; can yield `From joe@y.z (Joe    K Fri Mar 22 08:11:15 1996', and       ;; can yield `From joe@y.z (Joe    K Fri Mar 22 08:11:15 1996', and
1447       ;;         From: Joe User       ;;         From: Joe User
1448       ;;                 <joe@y.z>       ;;                 <joe@y.z>
1449       ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'.       ;; can yield `From Joe User Fri Mar 22 08:11:15 1996'.
# Line 991  Except if it is nil, use Gnus native MUA Line 1455  Except if it is nil, use Gnus native MUA
1455       ;; We want to match the results of any of these manglings.       ;; We want to match the results of any of these manglings.
1456       ;; The following regexp rejects names whose first characters are       ;; The following regexp rejects names whose first characters are
1457       ;; obviously bogus, but after that anything goes.       ;; obviously bogus, but after that anything goes.
1458       "\\([^\0-\b\n-\r\^?].*\\)? "       "\\([^\0-\b\n-\r\^?].*\\)?"
1459    
1460       ;; The time the message was sent.       ;; The time the message was sent.
1461       "\\([^\0-\r \^?]+\\) +"            ; day of the week       "\\([^\0-\r \^?]+\\) +"            ; day of the week
# Line 1044  Except if it is nil, use Gnus native MUA Line 1508  Except if it is nil, use Gnus native MUA
1508      (User-Agent))      (User-Agent))
1509    "Alist used for formatting headers.")    "Alist used for formatting headers.")
1510    
1511    (defvar message-options nil
1512      "Some saved answers when sending message.")
1513    
1514    (defvar message-send-mail-real-function nil
1515      "Internal send mail function.")
1516    
1517    (defvar message-bogus-system-names "^localhost\\."
1518      "The regexp of bogus system names.")
1519    
1520    (defcustom message-valid-fqdn-regexp
1521      (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain.
1522              ;; valid TLDs:
1523              "\\([a-z][a-z]" ;; two letter country TDLs
1524              "\\|biz\\|com\\|edu\\|gov\\|int\\|mil\\|net\\|org"
1525              "\\|aero\\|coop\\|info\\|name\\|museum"
1526              "\\|arpa\\|pro\\|uucp\\|bitnet\\|bofh" ;; old style?
1527              "\\)")
1528      "Regular expression that matches a valid FQDN."
1529      ;; see also: gnus-button-valid-fqdn-regexp
1530      :group 'message-headers
1531      :type 'regexp)
1532    
1533  (eval-and-compile  (eval-and-compile
1534      (autoload 'idna-to-ascii "idna")
1535    (autoload 'message-setup-toolbar "messagexmas")    (autoload 'message-setup-toolbar "messagexmas")
1536    (autoload 'mh-new-draft-name "mh-comp")    (autoload 'mh-new-draft-name "mh-comp")
1537    (autoload 'mh-send-letter "mh-comp")    (autoload 'mh-send-letter "mh-comp")
# Line 1052  Except if it is nil, use Gnus native MUA Line 1539  Except if it is nil, use Gnus native MUA
1539    (autoload 'gnus-point-at-bol "gnus-util")    (autoload 'gnus-point-at-bol "gnus-util")
1540    (autoload 'gnus-output-to-rmail "gnus-util")    (autoload 'gnus-output-to-rmail "gnus-util")
1541    (autoload 'gnus-output-to-mail "gnus-util")    (autoload 'gnus-output-to-mail "gnus-util")
   (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev")  
1542    (autoload 'nndraft-request-associate-buffer "nndraft")    (autoload 'nndraft-request-associate-buffer "nndraft")
1543    (autoload 'nndraft-request-expire-articles "nndraft")    (autoload 'nndraft-request-expire-articles "nndraft")
1544    (autoload 'gnus-open-server "gnus-int")    (autoload 'gnus-open-server "gnus-int")
1545    (autoload 'gnus-request-post "gnus-int")    (autoload 'gnus-request-post "gnus-int")
1546    (autoload 'gnus-alive-p "gnus-util")    (autoload 'gnus-alive-p "gnus-util")
1547      (autoload 'gnus-server-string "gnus")
1548    (autoload 'gnus-group-name-charset "gnus-group")    (autoload 'gnus-group-name-charset "gnus-group")
1549    (autoload 'rmail-output "rmailout"))    (autoload 'gnus-group-name-decode "gnus-group")
1550      (autoload 'gnus-groups-from-server "gnus")
1551      (autoload 'rmail-output "rmailout")
1552      (autoload 'gnus-delay-article "gnus-delay")
1553      (autoload 'gnus-make-local-hook "gnus-util")
1554      (autoload 'gnus-extract-address-components "gnus-util"))
1555    
1556    
1557    
# Line 1076  Except if it is nil, use Gnus native MUA Line 1568  Except if it is nil, use Gnus native MUA
1568    `(delete-region (progn (beginning-of-line) (point))    `(delete-region (progn (beginning-of-line) (point))
1569                    (progn (forward-line ,(or n 1)) (point))))                    (progn (forward-line ,(or n 1)) (point))))
1570    
1571    (defun message-mark-active-p ()
1572      "Non-nil means the mark and region are currently active in this buffer."
1573      mark-active)
1574    
1575  (defun message-unquote-tokens (elems)  (defun message-unquote-tokens (elems)
1576    "Remove double quotes (\") from strings in list ELEMS."    "Remove double quotes (\") from strings in list ELEMS."
1577    (mapcar (lambda (item)    (mapcar (lambda (item)
1578              (while (string-match "^\\(.*\\)\"\\(.*\\)$" item)              (while (string-match "^\\(.*\\)\"\\(.*\\)$" item)
1579                (setq item (concat (match-string 1 item)                (setq item (concat (match-string 1 item)
1580                                   (match-string 2 item))))                                   (match-string 2 item))))
1581              item)              item)
1582            elems))            elems))
1583    
1584  (defun message-tokenize-header (header &optional separator)  (defun message-tokenize-header (header &optional separator)
1585    "Split HEADER into a list of header elements.    "Split HEADER into a list of header elements.
# Line 1092  is used by default." Line 1588  is used by default."
1588    (if (not header)    (if (not header)
1589        nil        nil
1590      (let ((regexp (format "[%s]+" (or separator ",")))      (let ((regexp (format "[%s]+" (or separator ",")))
1591            (beg 1)            (beg (point-min))
1592            (first t)            (first t)
1593            quoted elems paren)            quoted elems paren)
1594        (save-excursion        (with-temp-buffer
1595          (message-set-work-buffer)          (mm-enable-multibyte)
1596          (insert header)          (insert header)
1597          (goto-char (point-min))          (goto-char (point-min))
1598          (while (not (eobp))          (while (not (eobp))
# Line 1118  is used by default." Line 1614  is used by default."
1614                  ((and (eq (char-after) ?\))                  ((and (eq (char-after) ?\))
1615                        (not quoted))                        (not quoted))
1616                   (setq paren nil))))                   (setq paren nil))))
1617          (nreverse elems)))))          (nreverse elems)))))
1618    
1619  (defun message-mail-file-mbox-p (file)  (defun message-mail-file-mbox-p (file)
1620    "Say whether FILE looks like a Unix mbox file."    "Say whether FILE looks like a Unix mbox file."
# Line 1131  is used by default." Line 1627  is used by default."
1627        (looking-at message-unix-mail-delimiter))))        (looking-at message-unix-mail-delimiter))))
1628    
1629  (defun message-fetch-field (header &optional not-all)  (defun message-fetch-field (header &optional not-all)
1630    "The same as `mail-fetch-field', only remove all newlines."    "The same as `mail-fetch-field', only remove all newlines.
1631    The buffer is expected to be narrowed to just the header of the message;
1632    see `message-narrow-to-headers-or-head'."
1633    (let* ((inhibit-point-motion-hooks t)    (let* ((inhibit-point-motion-hooks t)
1634           (case-fold-search t)           (case-fold-search t)
1635           (value (mail-fetch-field header nil (not not-all))))           (value (mail-fetch-field header nil (not not-all))))
# Line 1141  is used by default." Line 1639  is used by default."
1639        (set-text-properties 0 (length value) nil value)        (set-text-properties 0 (length value) nil value)
1640        value)))        value)))
1641    
1642    (defun message-field-value (header &optional not-all)
1643      "The same as `message-fetch-field', only narrow to the headers first."
1644      (save-excursion
1645        (save-restriction
1646          (message-narrow-to-headers-or-head)
1647          (message-fetch-field header not-all))))
1648    
1649  (defun message-narrow-to-field ()  (defun message-narrow-to-field ()
1650    "Narrow the buffer to the header on the current line."    "Narrow the buffer to the header on the current line."
1651    (beginning-of-line)    (beginning-of-line)
# Line 1165  is used by default." Line 1670  is used by default."
1670        (save-restriction        (save-restriction
1671          (message-narrow-to-headers)          (message-narrow-to-headers)
1672          (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t)          (unless (re-search-forward (concat "^" (regexp-quote hclean) ":") nil t)
1673            (insert (car headers) ?\n))))            (goto-char (point-max))
1674              (if (string-match "\n$" (car headers))
1675                  (insert (car headers))
1676                (insert (car headers) ?\n)))))
1677      (setq headers (cdr headers))))      (setq headers (cdr headers))))
1678    
1679    (defmacro message-with-reply-buffer (&rest forms)
1680      "Evaluate FORMS in the reply buffer, if it exists."
1681      `(when (and message-reply-buffer
1682                  (buffer-name message-reply-buffer))
1683         (save-excursion
1684           (set-buffer message-reply-buffer)
1685           ,@forms)))
1686    
1687    (put 'message-with-reply-buffer 'lisp-indent-function 0)
1688    (put 'message-with-reply-buffer 'edebug-form-spec '(body))
1689    
1690  (defun message-fetch-reply-field (header)  (defun message-fetch-reply-field (header)
1691    "Fetch field HEADER from the message we're replying to."    "Fetch field HEADER from the message we're replying to."
1692    (when (and message-reply-buffer    (message-with-reply-buffer
1693               (buffer-name message-reply-buffer))      (save-restriction
1694      (save-excursion        (mail-narrow-to-head)
       (set-buffer message-reply-buffer)  
1695        (message-fetch-field header))))        (message-fetch-field header))))
1696    
 (defun message-set-work-buffer ()  
   (if (get-buffer " *message work*")  
       (progn  
         (set-buffer " *message work*")  
         (erase-buffer))  
     (set-buffer (get-buffer-create " *message work*"))  
     (kill-all-local-variables)  
     (mm-enable-multibyte)))  
   
 (defun message-functionp (form)  
   "Return non-nil if FORM is funcallable."  
   (or (and (symbolp form) (fboundp form))  
       (and (listp form) (eq (car form) 'lambda))  
       (byte-code-function-p form)))  
   
1697  (defun message-strip-list-identifiers (subject)  (defun message-strip-list-identifiers (subject)
1698    "Remove list identifiers in `gnus-list-identifiers' from string SUBJECT."    "Remove list identifiers in `gnus-list-identifiers' from string SUBJECT."
1699    (require 'gnus-sum)                   ; for gnus-list-identifiers    (require 'gnus-sum)                   ; for gnus-list-identifiers
# Line 1199  is used by default." Line 1701  is used by default."
1701                      gnus-list-identifiers                      gnus-list-identifiers
1702                    (mapconcat 'identity gnus-list-identifiers " *\\|"))))                    (mapconcat 'identity gnus-list-identifiers " *\\|"))))
1703      (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp      (if (string-match (concat "\\(\\(\\(Re: +\\)?\\(" regexp
1704                                  " *\\)\\)+\\(Re: +\\)?\\)") subject)                                " *\\)\\)+\\(Re: +\\)?\\)") subject)
1705          (concat (substring subject 0 (match-beginning 1))          (concat (substring subject 0 (match-beginning 1))
1706                  (or (match-string 3 subject)                  (or (match-string 3 subject)
1707                      (match-string 5 subject))                      (match-string 5 subject))
# Line 1213  is used by default." Line 1715  is used by default."
1715        (substring subject (match-end 0))        (substring subject (match-end 0))
1716      subject))      subject))
1717    
1718    ;;; Start of functions adopted from `message-utils.el'.
1719    
1720    (defun message-strip-subject-trailing-was (subject)
1721      "Remove trailing \"(Was: <old subject>)\" from SUBJECT lines.
1722    Leading \"Re: \" is not stripped by this function.  Use the function
1723    `message-strip-subject-re' for this."
1724      (let* ((query message-subject-trailing-was-query)
1725             (new) (found))
1726        (setq found
1727              (string-match
1728               (if (eq query 'ask)
1729                   message-subject-trailing-was-ask-regexp
1730                 message-subject-trailing-was-regexp)
1731               subject))
1732        (if found
1733            (setq new (substring subject 0 (match-beginning 0))))
1734        (if (or (not found) (eq query nil))
1735            subject
1736          (if (eq query 'ask)
1737              (if (message-y-or-n-p
1738                   "Strip `(was: <old subject>)' in subject? " t
1739                   (concat
1740                    "Strip `(was: <old subject>)' in subject "
1741                    "and use the new one instead?\n\n"
1742                    "Current subject is:   \""
1743                    subject "\"\n\n"
1744                    "New subject would be: \""
1745                    new "\"\n\n"
1746                    "See the variable `message-subject-trailing-was-query' "
1747                    "to get rid of this query."
1748                    ))
1749                  new subject)
1750            new))))
1751    
1752    ;;; Suggested by Jonas Steverud  @  www.dtek.chalmers.se/~d4jonas/
1753    
1754    ;;;###autoload
1755    (defun message-change-subject (new-subject)
1756      "Ask for NEW-SUBJECT header, append (was: <Old Subject>)."
1757      ;; <URL:http://www.landfield.com/usefor/drafts/draft-ietf-usefor-useage--1.02.unpaged>
1758      (interactive
1759       (list
1760        (read-from-minibuffer "New subject: ")))
1761      (cond ((and (not (or (null new-subject) ; new subject not empty
1762                           (zerop (string-width new-subject))
1763                           (string-match "^[ \t]*$" new-subject))))
1764             (save-excursion
1765               (let ((old-subject
1766                      (save-restriction
1767                        (message-narrow-to-headers)
1768                        (message-fetch-field "Subject"))))
1769                 (cond ((not old-subject)
1770                        (error "No current subject"))
1771                       ((not (string-match
1772                              (concat "^[ \t]*"
1773                                      (regexp-quote new-subject)
1774                                      " \t]*$")
1775                              old-subject))  ; yes, it really is a new subject
1776                        ;; delete eventual Re: prefix
1777                        (setq old-subject
1778                              (message-strip-subject-re old-subject))
1779                        (message-goto-subject)
1780                        (message-delete-line)
1781                        (insert (concat "Subject: "
1782                                        new-subject
1783                                        " (was: "
1784                                        old-subject ")\n")))))))))
1785    
1786    ;;;###autoload
1787    (defun message-mark-inserted-region (beg end)
1788      "Mark some region in the current article with enclosing tags.
1789    See `message-mark-insert-begin' and `message-mark-insert-end'."
1790      (interactive "r")
1791      (save-excursion
1792        ;; add to the end of the region first, otherwise end would be invalid
1793        (goto-char end)
1794        (insert message-mark-insert-end)
1795        (goto-char beg)
1796        (insert message-mark-insert-begin)))
1797    
1798    ;;;###autoload
1799    (defun message-mark-insert-file (file)
1800      "Insert FILE at point, marking it with enclosing tags.
1801    See `message-mark-insert-begin' and `message-mark-insert-end'."
1802      (interactive "fFile to insert: ")
1803        ;; reverse insertion to get correct result.
1804      (let ((p (point)))
1805        (insert message-mark-insert-end)
1806        (goto-char p)
1807        (insert-file-contents file)
1808        (goto-char p)
1809        (insert message-mark-insert-begin)))
1810    
1811    ;;;###autoload
1812    (defun message-add-archive-header ()
1813      "Insert \"X-No-Archive: Yes\" in the header and a note in the body.
1814    The note can be customized using `message-archive-note'.  When called with a
1815    prefix argument, ask for a text to insert.  If you don't want the note in the
1816    body, set  `message-archive-note' to nil."
1817      (interactive)
1818      (if current-prefix-arg
1819          (setq message-archive-note
1820                (read-from-minibuffer "Reason for No-Archive: "
1821                                      (cons message-archive-note 0))))
1822        (save-excursion
1823          (if (message-goto-signature)
1824              (re-search-backward message-signature-separator))
1825          (when message-archive-note
1826            (insert message-archive-note)
1827            (newline))
1828          (message-add-header message-archive-header)
1829          (message-sort-headers)))
1830    
1831    ;;;###autoload
1832    (defun message-cross-post-followup-to-header (target-group)
1833      "Mangles FollowUp-To and Newsgroups header to point to TARGET-GROUP.
1834    With prefix-argument just set Follow-Up, don't cross-post."
1835      (interactive
1836       (list ; Completion based on Gnus
1837        (completing-read "Followup To: "
1838                         (if (boundp 'gnus-newsrc-alist)
1839                             gnus-newsrc-alist)
1840                         nil nil '("poster" . 0)
1841                         (if (boundp 'gnus-group-history)
1842                             'gnus-group-history))))
1843      (message-remove-header "Follow[Uu]p-[Tt]o" t)
1844      (message-goto-newsgroups)
1845      (beginning-of-line)
1846      ;; if we already did a crosspost before, kill old target
1847      (if (and message-cross-post-old-target
1848               (re-search-forward
1849                (regexp-quote (concat "," message-cross-post-old-target))
1850                nil t))
1851          (replace-match ""))
1852      ;; unless (followup is to poster or user explicitly asked not
1853      ;; to cross-post, or target-group is already in Newsgroups)
1854      ;; add target-group to Newsgroups line.
1855      (cond ((and (or
1856                   ;; def: cross-post, req:no
1857                   (and message-cross-post-default (not current-prefix-arg))
1858                   ;; def: no-cross-post, req:yes
1859                   (and (not message-cross-post-default) current-prefix-arg))
1860                  (not (string-match "poster" target-group))
1861                  (not (string-match (regexp-quote target-group)
1862                                     (message-fetch-field "Newsgroups"))))
1863             (end-of-line)
1864             (insert (concat "," target-group))))
1865      (end-of-line) ; ensure Followup: comes after Newsgroups:
1866      ;; unless new followup would be identical to Newsgroups line
1867      ;; make a new Followup-To line
1868      (if (not (string-match (concat "^[ \t]*"
1869                                     target-group
1870                                     "[ \t]*$")
1871                             (message-fetch-field "Newsgroups")))
1872          (insert (concat "\nFollowup-To: " target-group)))
1873      (setq message-cross-post-old-target target-group))
1874    
1875    ;;;###autoload
1876    (defun message-cross-post-insert-note (target-group cross-post in-old
1877                                                        old-groups)
1878      "Insert a in message body note about a set Followup or Crosspost.
1879    If there have been previous notes, delete them.  TARGET-GROUP specifies the
1880    group to Followup-To.  When CROSS-POST is t, insert note about
1881    crossposting.  IN-OLD specifies whether TARGET-GROUP is a member of
1882    OLD-GROUPS.  OLD-GROUPS lists the old-groups the posting would have
1883    been made to before the user asked for a Crosspost."
1884      ;; start scanning body for previous uses
1885      (message-goto-signature)
1886      (let ((head (re-search-backward
1887                   (concat "^" mail-header-separator)
1888                   nil t))) ; just search in body
1889        (message-goto-signature)
1890        (while (re-search-backward
1891                (concat "^" (regexp-quote message-cross-post-note) ".*")
1892                head t)
1893          (message-delete-line))
1894        (message-goto-signature)
1895        (while (re-search-backward
1896                (concat "^" (regexp-quote message-followup-to-note) ".*")
1897                head t)
1898          (message-delete-line))
1899        ;; insert new note
1900        (if (message-goto-signature)
1901            (re-search-backward message-signature-separator))
1902        (if (or in-old
1903                (not cross-post)
1904                (string-match "^[ \t]*poster[ \t]*$" target-group))
1905            (insert (concat message-followup-to-note target-group "\n"))
1906          (insert (concat message-cross-post-note target-group "\n")))))
1907    
1908    ;;;###autoload
1909    (defun message-cross-post-followup-to (target-group)
1910      "Crossposts message and set Followup-To to TARGET-GROUP.
1911    With prefix-argument just set Follow-Up, don't cross-post."
1912      (interactive
1913       (list ; Completion based on Gnus
1914        (completing-read "Followup To: "
1915                         (if (boundp 'gnus-newsrc-alist)
1916                             gnus-newsrc-alist)
1917                         nil nil '("poster" . 0)
1918                         (if (boundp 'gnus-group-history)
1919                             'gnus-group-history))))
1920      (cond ((not (or (null target-group) ; new subject not empty
1921                      (zerop (string-width target-group))
1922                      (string-match "^[ \t]*$" target-group)))
1923             (save-excursion
1924               (let* ((old-groups (message-fetch-field "Newsgroups"))
1925                      (in-old (string-match
1926                               (regexp-quote target-group)
1927                               (or old-groups ""))))
1928                 ;; check whether target exactly matches old Newsgroups
1929                 (cond ((not old-groups)
1930                        (error "No current newsgroup"))
1931                       ((or (not in-old)
1932                            (not (string-match
1933                                  (concat "^[ \t]*"
1934                                          (regexp-quote target-group)
1935                                          "[ \t]*$")
1936                                  old-groups)))
1937                        ;; yes, Newsgroups line must change
1938                        (message-cross-post-followup-to-header target-group)
1939                        ;; insert note whether we do cross-post or followup-to
1940                        (funcall message-cross-post-note-function
1941                                 target-group
1942                                 (if (or (and message-cross-post-default
1943                                              (not current-prefix-arg))
1944                                         (and (not message-cross-post-default)
1945                                              current-prefix-arg)) t)
1946                                 in-old old-groups))))))))
1947    
1948    ;;; Reduce To: to Cc: or Bcc: header
1949    
1950    ;;;###autoload
1951    (defun message-reduce-to-to-cc ()
1952     "Replace contents of To: header with contents of Cc: or Bcc: header."
1953     (interactive)
1954     (let ((cc-content
1955            (save-restriction (message-narrow-to-headers)
1956                              (message-fetch-field "cc")))
1957           (bcc nil))
1958       (if (and (not cc-content)
1959                (setq cc-content
1960                      (save-restriction
1961                        (message-narrow-to-headers)
1962                        (message-fetch-field "bcc"))))
1963           (setq bcc t))
1964       (cond (cc-content
1965              (save-excursion
1966                (message-goto-to)
1967                (message-delete-line)
1968                (insert (concat "To: " cc-content "\n"))
1969                (save-restriction
1970                  (message-narrow-to-headers)
1971                  (message-remove-header (if bcc
1972                                             "bcc"
1973                                           "cc"))))))))
1974    
1975    ;;; End of functions adopted from `message-utils.el'.
1976    
1977  (defun message-remove-header (header &optional is-regexp first reverse)  (defun message-remove-header (header &optional is-regexp first reverse)
1978    "Remove HEADER in the narrowed buffer.    "Remove HEADER in the narrowed buffer.
1979  If IS-REGEXP, HEADER is a regular expression.  If IS-REGEXP, HEADER is a regular expression.
# Line 1321  Point is left at the beginning of the na Line 2082  Point is left at the beginning of the na
2082                     (message-fetch-field "cc")                     (message-fetch-field "cc")
2083                     (message-fetch-field "bcc")))))))                     (message-fetch-field "bcc")))))))
2084    
2085    (defun message-subscribed-p ()
2086      "Say whether we need to insert a MFT header."
2087      (or message-subscribed-regexps
2088          message-subscribed-addresses
2089          message-subscribed-address-file
2090          message-subscribed-address-functions))
2091    
2092  (defun message-next-header ()  (defun message-next-header ()
2093    "Go to the beginning of the next header."    "Go to the beginning of the next header."
2094    (beginning-of-line)    (beginning-of-line)
# Line 1364  Point is left at the beginning of the na Line 2132  Point is left at the beginning of the na
2132               (1+ max)))))               (1+ max)))))
2133        (message-sort-headers-1))))        (message-sort-headers-1))))
2134    
2135    
2136    
2137    
2138  ;;;  ;;;
# Line 1380  Point is left at the beginning of the na Line 2149  Point is left at the beginning of the na
2149    (define-key message-mode-map "\C-c?" 'describe-mode)    (define-key message-mode-map "\C-c?" 'describe-mode)
2150    
2151    (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)    (define-key message-mode-map "\C-c\C-f\C-t" 'message-goto-to)
2152      (define-key message-mode-map "\C-c\C-f\C-o" 'message-goto-from)
2153    (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc)    (define-key message-mode-map "\C-c\C-f\C-b" 'message-goto-bcc)
2154    (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc)    (define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc)
2155    (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)    (define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)
# Line 1388  Point is left at the beginning of the na Line 2158  Point is left at the beginning of the na
2158    (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)    (define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
2159    (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)    (define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
2160    (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)    (define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)
2161      (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to)
2162    (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)    (define-key message-mode-map "\C-c\C-f\C-k" 'message-goto-keywords)
2163    (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)    (define-key message-mode-map "\C-c\C-f\C-u" 'message-goto-summary)
2164      (define-key message-mode-map "\C-c\C-f\C-i"
2165        'message-insert-or-toggle-importance)
2166      (define-key message-mode-map "\C-c\C-f\C-a"
2167        'message-generate-unsubscribed-mail-followup-to)
2168    
2169      ;; modify headers (and insert notes in body)
2170      (define-key message-mode-map "\C-c\C-fs"    'message-change-subject)
2171      ;;
2172      (define-key message-mode-map "\C-c\C-fx"    'message-cross-post-followup-to)
2173      ;; prefix+message-cross-post-followup-to = same w/o cross-post
2174      (define-key message-mode-map "\C-c\C-ft"    'message-reduce-to-to-cc)
2175      (define-key message-mode-map "\C-c\C-fa"    'message-add-archive-header)
2176      ;; mark inserted text
2177      (define-key message-mode-map "\C-c\M-m" 'message-mark-inserted-region)
2178      (define-key message-mode-map "\C-c\M-f" 'message-mark-insert-file)
2179    
2180    (define-key message-mode-map "\C-c\C-b" 'message-goto-body)    (define-key message-mode-map "\C-c\C-b" 'message-goto-body)
2181    (define-key message-mode-map "\C-c\C-i" 'message-goto-signature)    (define-key message-mode-map "\C-c\C-i" 'message-goto-signature)
2182    
2183    (define-key message-mode-map "\C-c\C-t" 'message-insert-to)    (define-key message-mode-map "\C-c\C-t" 'message-insert-to)
2184      (define-key message-mode-map "\C-c\C-fw" 'message-insert-wide-reply)
2185    (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)    (define-key message-mode-map "\C-c\C-n" 'message-insert-newsgroups)
2186      (define-key message-mode-map "\C-c\C-l" 'message-to-list-only)
2187    
2188      (define-key message-mode-map "\C-c\C-u" 'message-insert-or-toggle-importance)
2189      (define-key message-mode-map "\C-c\M-n"
2190        'message-insert-disposition-notification-to)
2191    
2192    (define-key message-mode-map "\C-c\C-y" 'message-yank-original)    (define-key message-mode-map "\C-c\C-y" 'message-yank-original)
2193    (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer)    (define-key message-mode-map "\C-c\M-\C-y" 'message-yank-buffer)
# Line 1409  Point is left at the beginning of the na Line 2202  Point is left at the beginning of the na
2202    (define-key message-mode-map "\C-c\C-s" 'message-send)    (define-key message-mode-map "\C-c\C-s" 'message-send)
2203    (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer)    (define-key message-mode-map "\C-c\C-k" 'message-kill-buffer)
2204    (define-key message-mode-map "\C-c\C-d" 'message-dont-send)    (define-key message-mode-map "\C-c\C-d" 'message-dont-send)
2205      (define-key message-mode-map "\C-c\n" 'gnus-delay-article)
2206    
2207    (define-key message-mode-map "\C-c\C-e" 'message-elide-region)    (define-key message-mode-map "\C-c\C-e" 'message-elide-region)
2208    (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)    (define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
2209    (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)    (define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
2210    (define-key message-mode-map "\M-\r" 'message-newline-and-reformat)    (define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
2211      ;;(define-key message-mode-map "\M-q" 'message-fill-paragraph)
2212    (define-key message-mode-map [remap split-line]  'message-split-line)    (define-key message-mode-map [remap split-line]  'message-split-line)
2213    
2214    (define-key message-mode-map "\C-c\C-a" 'mml-attach-file)    (define-key message-mode-map "\C-c\C-a" 'mml-attach-file)
2215    
2216    (define-key message-mode-map "\t" 'message-tab))    (define-key message-mode-map "\C-a" 'message-beginning-of-line)
2217      (define-key message-mode-map "\t" 'message-tab)
2218      (define-key message-mode-map "\M-;" 'comment-region))
2219    
2220  (easy-menu-define  (easy-menu-define
2221   message-mode-menu message-mode-map "Message Menu."    message-mode-menu message-mode-map "Message Menu."
2222   '("Message"    `("Message"
2223     ["Sort Headers" message-sort-headers t]      ["Yank Original" message-yank-original message-reply-buffer]
2224     ["Yank Original" message-yank-original t]      ["Fill Yanked Message" message-fill-yanked-message t]
2225     ["Fill Yanked Message" message-fill-yanked-message t]      ["Insert Signature" message-insert-signature t]
2226     ["Insert Signature" message-insert-signature t]      ["Caesar (rot13) Message" message-caesar-buffer-body t]
2227     ["Caesar (rot13) Message" message-caesar-buffer-body t]      ["Caesar (rot13) Region" message-caesar-region (message-mark-active-p)]
2228     ["Caesar (rot13) Region" message-caesar-region (mark t)]      ["Elide Region" message-elide-region
2229     ["Elide Region" message-elide-region (mark t)]       :active (message-mark-active-p)
2230     ["Delete Outside Region" message-delete-not-region (mark t)]       ,@(if (featurep 'xemacs) nil
2231     ["Kill To Signature" message-kill-to-signature t]           '(:help "Replace text in region with an ellipsis"))]
2232     ["Newline and Reformat" message-newline-and-reformat t]      ["Delete Outside Region" message-delete-not-region
2233     ["Rename buffer" message-rename-buffer t]       :active (message-mark-active-p)
2234     ["Spellcheck" ispell-message       ,@(if (featurep 'xemacs) nil
2235      :help "Spellcheck this message"]           '(:help "Delete all quoted text outside region"))]
2236     ["Attach file as MIME" mml-attach-file      ["Kill To Signature" message-kill-to-signature t]
2237      :help "Attach a file at point"]      ["Newline and Reformat" message-newline-and-reformat t]
2238     "----"      ["Rename buffer" message-rename-buffer t]
2239     ["Send Message" message-send-and-exit      ["Spellcheck" ispell-message
2240      :help "Send this message"]       ,@(if (featurep 'xemacs) '(t)
2241     ["Abort Message" message-dont-send           '(:help "Spellcheck this message"))]
2242      :help "File this draft message and exit"]      "----"
2243     ["Kill Message" message-kill-buffer      ["Insert Region Marked" message-mark-inserted-region
2244      :help "Delete this message without sending"]))       :active (message-mark-active-p)
2245         ,@(if (featurep 'xemacs) nil
2246             '(:help "Mark region with enclosing tags"))]
2247        ["Insert File Marked..." message-mark-insert-file
2248         ,@(if (featurep 'xemacs) '(t)
2249             '(:help "Insert file at point marked with enclosing tags"))]
2250        "----"
2251        ["Send Message" message-send-and-exit
2252         ,@(if (featurep 'xemacs) '(t)
2253             '(:help "Send this message"))]
2254        ["Postpone Message" message-dont-send
2255         ,@(if (featurep 'xemacs) '(t)
2256             '(:help "File this draft message and exit"))]
2257        ["Send at Specific Time..." gnus-delay-article
2258         ,@(if (featurep 'xemacs) '(t)
2259             '(:help "Ask, then arrange to send message at that time"))]
2260        ["Kill Message" message-kill-buffer
2261         ,@(if (featurep 'xemacs) '(t)
2262             '(:help "Delete this message without sending"))]))
2263    
2264  (easy-menu-define  (easy-menu-define
2265   message-mode-field-menu message-mode-map ""    message-mode-field-menu message-mode-map ""
2266   '("Field"    `("Field"
2267     ["Fetch To" message-insert-to t]      ["To" message-goto-to t]
2268     ["Fetch Newsgroups" message-insert-newsgroups t]      ["From" message-goto-from t]
2269     "----"      ["Subject" message-goto-subject t]
2270     ["To" message-goto-to t]      ["Change subject..." message-change-subject t]
2271     ["Subject" message-goto-subject t]      ["Cc" message-goto-cc t]
2272     ["Cc" message-goto-cc t]      ["Bcc" message-goto-bcc t]
2273     ["Reply-To" message-goto-reply-to t]      ["Fcc" message-goto-fcc t]
2274     ["Summary" message-goto-summary t]      ["Reply-To" message-goto-reply-to t]
2275     ["Keywords" message-goto-keywords t]      ["Flag As Important" message-insert-importance-high
2276     ["Newsgroups" message-goto-newsgroups t]       ,@(if (featurep 'xemacs) '(t)
2277     ["Followup-To" message-goto-followup-to t]           '(:help "Mark this message as important"))]
2278     ["Distribution" message-goto-distribution t]      ["Flag As Unimportant" message-insert-importance-low
2279     ["Body" message-goto-body t]       ,@(if (featurep 'xemacs) '(t)
2280     ["Signature" message-goto-signature t]))           '(:help "Mark this message as unimportant"))]
2281        ["Request Receipt"
2282         message-insert-disposition-notification-to
2283         ,@(if (featurep 'xemacs) '(t)
2284             '(:help "Request a receipt notification"))]
2285        "----"
2286        ;; (typical) news stuff
2287        ["Summary" message-goto-summary t]
2288        ["Keywords" message-goto-keywords t]
2289        ["Newsgroups" message-goto-newsgroups t]
2290        ["Fetch Newsgroups" message-insert-newsgroups t]
2291        ["Followup-To" message-goto-followup-to t]
2292        ;; ["Followup-To (with note in body)" message-cross-post-followup-to t]
2293        ["Crosspost / Followup-To..." message-cross-post-followup-to t]
2294        ["Distribution" message-goto-distribution t]
2295        ["X-No-Archive:" message-add-archive-header t ]
2296        "----"
2297        ;; (typical) mailing-lists stuff
2298        ["Fetch To" message-insert-to
2299         ,@(if (featurep 'xemacs) '(t)
2300             '(:help "Insert a To header that points to the author."))]
2301        ["Fetch To and Cc" message-insert-wide-reply
2302         ,@(if (featurep 'xemacs) '(t)
2303             '(:help
2304               "Insert To and Cc headers as if you were doing a wide reply."))]
2305        "----"
2306        ["Send to list only" message-to-list-only t]
2307        ["Mail-Followup-To" message-goto-mail-followup-to t]
2308        ["Unsubscribed list post" message-generate-unsubscribed-mail-followup-to
2309         ,@(if (featurep 'xemacs) '(t)
2310             '(:help "Insert a reasonable `Mail-Followup-To:' header."))]
2311        ["Reduce To: to Cc:" message-reduce-to-to-cc t]
2312        "----"
2313        ["Sort Headers" message-sort-headers t]
2314        ["Encode non-ASCII domain names" message-idna-to-ascii-rhs t]
2315        ["Goto Body" message-goto-body t]
2316        ["Goto Signature" message-goto-signature t]))
2317    
2318    (defvar message-tool-bar-map nil)
2319    
2320  (eval-when-compile  (eval-when-compile
2321    (defvar facemenu-add-face-function)    (defvar facemenu-add-face-function)
2322    (defvar facemenu-remove-face-function))    (defvar facemenu-remove-face-function))
2323    
2324    ;;; Forbidden properties
2325    ;;
2326    ;; We use `after-change-functions' to keep special text properties
2327    ;; that interfer with the normal function of message mode out of the
2328    ;; buffer.
2329    
2330    (defcustom message-strip-special-text-properties t
2331      "Strip special properties from the message buffer.
2332    
2333    Emacs has a number of special text properties which can break message
2334    composing in various ways.  If this option is set, message will strip
2335    these properties from the message composition buffer.  However, some
2336    packages requires these properties to be present in order to work.
2337    If you use one of these packages, turn this option off, and hope the
2338    message composition doesn't break too bad."
2339      :group 'message-various
2340      :link '(custom-manual "(message)Various Message Variables")
2341      :type 'boolean)
2342    
2343    (defconst message-forbidden-properties
2344      ;; No reason this should be clutter up customize.  We make it a
2345      ;; property list (rather than a list of property symbols), to be
2346      ;; directly useful for `remove-text-properties'.
2347      '(field nil read-only nil invisible nil intangible nil
2348              mouse-face nil modification-hooks nil insert-in-front-hooks nil
2349              insert-behind-hooks nil point-entered nil point-left nil)
2350      ;; Other special properties:
2351      ;; category, face, display: probably doesn't do any harm.
2352      ;; fontified: is used by font-lock.
2353      ;; syntax-table, local-map: I dunno.
2354      ;; We need to add XEmacs names to the list.
2355      "Property list of with properties.forbidden in message buffers.
2356    The values of the properties are ignored, only the property names are used.")
2357    
2358    (defun message-tamago-not-in-use-p (pos)
2359      "Return t when tamago version 4 is not in use at the cursor position.
2360    Tamago version 4 is a popular input method for writing Japanese text.
2361    It uses the properties `intangible', `invisible', `modification-hooks'
2362    and `read-only' when translating ascii or kana text to kanji text.
2363    These properties are essential to work, so we should never strip them."
2364      (not (and (boundp 'egg-modefull-mode)
2365                (symbol-value 'egg-modefull-mode)
2366                (or (memq (get-text-property pos 'intangible)
2367                          '(its-part-1 its-part-2))
2368                    (get-text-property pos 'egg-end)
2369                    (get-text-property pos 'egg-lang)
2370                    (get-text-property pos 'egg-start)))))
2371    
2372    (defun message-strip-forbidden-properties (begin end &optional old-length)
2373      "Strip forbidden properties between BEGIN and END, ignoring the third arg.
2374    This function is intended to be called from `after-change-functions'.
2375    See also `message-forbidden-properties'."
2376      (when (and message-strip-special-text-properties
2377                 (message-tamago-not-in-use-p begin))
2378        (while (not (= begin end))
2379          (when (not (get-text-property begin 'message-hidden))
2380            (remove-text-properties begin (1+ begin)
2381                                    message-forbidden-properties))
2382          (incf begin))))
2383    
2384  ;;;###autoload  ;;;###autoload
2385  (defun message-mode ()  (define-derived-mode message-mode text-mode "Message"
2386    "Major mode for editing mail and news to be sent.    "Major mode for editing mail and news to be sent.
2387  Like Text Mode but with these additional commands:\\<message-mode-map>  Like Text Mode but with these additional commands:\\<message-mode-map>
2388  C-c C-s  `message-send' (send the message)  C-c C-c  `message-send-and-exit'  C-c C-s  `message-send' (send the message)  C-c C-c  `message-send-and-exit'
# Line 1480  C-c C-f  move to a header field (and cre Line 2393  C-c C-f  move to a header field (and cre
2393           C-c C-f C-w  move to Fcc       C-c C-f C-r  move to Reply-To           C-c C-f C-w  move to Fcc       C-c C-f C-r  move to Reply-To
2394           C-c C-f C-u  move to Summary   C-c C-f C-n  move to Newsgroups           C-c C-f C-u  move to Summary   C-c C-f C-n  move to Newsgroups
2395           C-c C-f C-k  move to Keywords  C-c C-f C-d  move to Distribution           C-c C-f C-k  move to Keywords  C-c C-f C-d  move to Distribution
2396             C-c C-f C-o  move to From (\"Originator\")
2397           C-c C-f C-f  move to Followup-To           C-c C-f C-f  move to Followup-To
2398             C-c C-f C-m  move to Mail-Followup-To
2399             C-c C-f C-i  cycle through Importance values
2400             C-c C-f s    change subject and append \"(was: <Old Subject>)\"
2401             C-c C-f x    crossposting with FollowUp-To header and note in body
2402             C-c C-f t    replace To: header with contents of Cc: or Bcc:
2403             C-c C-f a    Insert X-No-Archive: header and a note in the body
2404  C-c C-t  `message-insert-to' (add a To header to a news followup)  C-c C-t  `message-insert-to' (add a To header to a news followup)
2405    C-c C-l  `message-to-list-only' (removes all but list address in to/cc)
2406  C-c C-n  `message-insert-newsgroups' (add a Newsgroup header to a news reply)  C-c C-n  `message-insert-newsgroups' (add a Newsgroup header to a news reply)
2407  C-c C-b  `message-goto-body' (move to beginning of message text).  C-c C-b  `message-goto-body' (move to beginning of message text).
2408  C-c C-i  `message-goto-signature' (move to the beginning of the signature).  C-c C-i  `message-goto-signature' (move to the beginning of the signature).
# Line 1493  C-c C-v  `message-delete-not-region' (re Line 2414  C-c C-v  `message-delete-not-region' (re
2414  C-c C-z  `message-kill-to-signature' (kill the text up to the signature).  C-c C-z  `message-kill-to-signature' (kill the text up to the signature).
2415  C-c C-r  `message-caesar-buffer-body' (rot13 the message body).  C-c C-r  `message-caesar-buffer-body' (rot13 the message body).
2416  C-c C-a  `mml-attach-file' (attach a file as MIME).  C-c C-a  `mml-attach-file' (attach a file as MIME).
2417    C-c C-u  `message-insert-or-toggle-importance'  (insert or cycle importance).
2418    C-c M-n  `message-insert-disposition-notification-to'  (request receipt).
2419    C-c M-m  `message-mark-inserted-region' (mark region with enclosing tags).
2420    C-c M-f  `message-mark-insert-file' (insert file marked with enclosing tags).
2421  M-RET    `message-newline-and-reformat' (break the line and reformat)."  M-RET    `message-newline-and-reformat' (break the line and reformat)."
2422    (interactive)    (setq local-abbrev-table text-mode-abbrev-table)
   (if (local-variable-p 'mml-buffer-list (current-buffer))  
       (mml-destroy-buffers))  
   (kill-all-local-variables)  
2423    (set (make-local-variable 'message-reply-buffer) nil)    (set (make-local-variable 'message-reply-buffer) nil)
2424    (make-local-variable 'message-send-actions)    (set (make-local-variable 'message-inserted-headers) nil)
2425    (make-local-variable 'message-exit-actions)    (set (make-local-variable 'message-send-actions) nil)
2426    (make-local-variable 'message-kill-actions)    (set (make-local-variable 'message-exit-actions) nil)
2427    (make-local-variable 'message-postpone-actions)    (set (make-local-variable 'message-kill-actions) nil)
2428    (make-local-variable 'message-draft-article)    (set (make-local-variable 'message-postpone-actions) nil)
2429    (make-local-hook 'kill-buffer-hook)    (set (make-local-variable 'message-draft-article) nil)
   (set-syntax-table message-mode-syntax-table)  
   (use-local-map message-mode-map)  
   (setq local-abbrev-table message-mode-abbrev-table)  
   (setq major-mode 'message-mode)  
   (setq mode-name "Message")  
2430    (setq buffer-offer-save t)    (setq buffer-offer-save t)
2431    (make-local-variable 'facemenu-add-face-function)    (set (make-local-variable 'facemenu-add-face-function)
2432    (make-local-variable 'facemenu-remove-face-function)         (lambda (face end)
2433    (setq facemenu-add-face-function           (let ((face-fun (cdr (assq face message-face-alist))))
2434          (lambda (face end)             (if face-fun
2435            (let ((face-fun (cdr (assq face message-face-alist))))                 (funcall face-fun (point) end)
2436              (if face-fun               (error "Face %s not configured for %s mode" face mode-name)))
2437                  (funcall face-fun (point) end)           ""))
2438                (error "Face %s not configured for %s mode" face mode-name)))    (set (make-local-variable 'facemenu-remove-face-function) t)
2439            "")    (set (make-local-variable 'message-reply-headers) nil)
         facemenu-remove-face-function t)  
   (make-local-variable 'message-reply-headers)  
   (setq message-reply-headers nil)  
2440    (make-local-variable 'message-newsreader)    (make-local-variable 'message-newsreader)
2441    (make-local-variable 'message-mailer)    (make-local-variable 'message-mailer)
2442    (make-local-variable 'message-post-method)    (make-local-variable 'message-post-method)
# Line 1531  M-RET    `message-newline-and-reformat' Line 2445  M-RET    `message-newline-and-reformat'
2445    (set (make-local-variable 'message-mime-part) 0)    (set (make-local-variable 'message-mime-part) 0)
2446    (message-setup-fill-variables)    (message-setup-fill-variables)
2447    ;; Allow using comment commands to add/remove quoting.    ;; Allow using comment commands to add/remove quoting.
2448      ;; (set (make-local-variable 'comment-start) message-yank-prefix)
2449    (when message-yank-prefix    (when message-yank-prefix
2450      (set (make-local-variable 'comment-start) message-yank-prefix)      (set (make-local-variable 'comment-start) message-yank-prefix)
2451      (set (make-local-variable 'comment-start-skip)      (set (make-local-variable 'comment-start-skip)
2452           (concat "^" (regexp-quote message-yank-prefix) "[ \t]*")))           (concat "^" (regexp-quote message-yank-prefix) "[ \t]*")))
   ;;(when (fboundp 'mail-hist-define-keys)  
   ;;  (mail-hist-define-keys))  
2453    (if (featurep 'xemacs)    (if (featurep 'xemacs)
2454        (message-setup-toolbar)        (message-setup-toolbar)
2455      (set (make-local-variable 'font-lock-defaults)      (set (make-local-variable 'font-lock-defaults)
2456           '(message-font-lock-keywords t))           '(message-font-lock-keywords t))
2457      (if (boundp 'message-tool-bar-map)      (if (boundp 'tool-bar-map)
2458          (set (make-local-variable 'tool-bar-map) message-tool-bar-map)))          (set (make-local-variable 'tool-bar-map) (message-tool-bar-map))))
2459    (easy-menu-add message-mode-menu message-mode-map)    (easy-menu-add message-mode-menu message-mode-map)
2460    (easy-menu-add message-mode-field-menu message-mode-map)    (easy-menu-add message-mode-field-menu message-mode-map)
2461      (gnus-make-local-hook 'after-change-functions)
2462      ;; Mmmm... Forbidden properties...
2463      (add-hook 'after-change-functions 'message-strip-forbidden-properties
2464                nil 'local)
2465    ;; Allow mail alias things.    ;; Allow mail alias things.
2466    (when (eq message-mail-alias-type 'abbrev)    (when (eq message-mail-alias-type 'abbrev)
2467      (if (fboundp 'mail-abbrevs-setup)      (if (fboundp 'mail-abbrevs-setup)
2468          (mail-abbrevs-setup)          (mail-abbrevs-setup)
2469        (mail-aliases-setup)))        (if (fboundp 'mail-aliases-setup) ; warning avoidance
2470              (mail-aliases-setup))))
2471    (unless buffer-file-name    (unless buffer-file-name
2472      (message-set-auto-save-file-name))      (message-set-auto-save-file-name))
2473    (mm-enable-multibyte)    (unless (buffer-base-buffer)
2474    (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation.      ;; Don't enable multibyte on an indirect buffer.  Maybe enabling
2475    (setq indent-tabs-mode nil)      ;; multibyte is not necessary at all. -- zsh
2476    (mml-mode)      (mm-enable-multibyte))
2477    (run-hooks 'text-mode-hook 'message-mode-hook))    (set (make-local-variable 'indent-tabs-mode) nil) ;No tabs for indentation.
2478      (mml-mode))
2479    
2480  (defun message-setup-fill-variables ()  (defun message-setup-fill-variables ()
2481    "Setup message fill variables."    "Setup message fill variables."
2482      (set (make-local-variable 'fill-paragraph-function)
2483           'message-fill-paragraph)
2484    (make-local-variable 'paragraph-separate)    (make-local-variable 'paragraph-separate)
2485    (make-local-variable 'paragraph-start)    (make-local-variable 'paragraph-start)
2486    (make-local-variable 'adaptive-fill-regexp)    (make-local-variable 'adaptive-fill-regexp)
2487    (unless (boundp 'adaptive-fill-first-line-regexp)    (unless (boundp 'adaptive-fill-first-line-regexp)
2488      (setq adaptive-fill-first-line-regexp nil))      (setq adaptive-fill-first-line-regexp nil))
2489    (make-local-variable 'adaptive-fill-first-line-regexp)    (make-local-variable 'adaptive-fill-first-line-regexp)
   (make-local-variable 'auto-fill-inhibit-regexp)  
2490    (let ((quote-prefix-regexp    (let ((quote-prefix-regexp
2491           (concat           ;; User should change message-cite-prefix-regexp if
2492            "[ \t]*"                      ; possible initial space           ;; message-yank-prefix is set to an abnormal value.
2493            "\\(\\(" (regexp-quote message-yank-prefix) "\\|" ; user's prefix           (concat "\\(" message-cite-prefix-regexp "\\)[ \t]*")))
           "\\w+>\\|"                    ; supercite-style prefix  
           "[|:>]"                       ; standard prefix  
           "\\)[ \t]*\\)+")))            ; possible space after each prefix  
2494      (setq paragraph-start      (setq paragraph-start
2495            (concat            (concat
2496             (regexp-quote mail-header-separator) "$\\|"             (regexp-quote mail-header-separator) "$\\|"
2497             "[ \t]*$\\|"                 ; blank lines             "[ \t]*$\\|"                 ; blank lines
2498             "-- $\\|"                    ; signature delimiter             "-- $\\|"                    ; signature delimiter
2499             "---+$\\|"                   ; delimiters for forwarded messages             "---+$\\|"              ; delimiters for forwarded messages
2500             page-delimiter "$\\|"        ; spoiler warnings             page-delimiter "$\\|"        ; spoiler warnings
2501             ".*wrote:$\\|"               ; attribution lines             ".*wrote:$\\|"               ; attribution lines
2502             quote-prefix-regexp "$"))    ; empty lines in quoted text             quote-prefix-regexp "$\\|"   ; empty lines in quoted text
2503                                            ; mml tags
2504               "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))
2505      (setq paragraph-separate paragraph-start)      (setq paragraph-separate paragraph-start)
2506      (setq adaptive-fill-regexp      (setq adaptive-fill-regexp
2507            (concat quote-prefix-regexp "\\|" adaptive-fill-regexp))            (concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
2508      (setq adaptive-fill-first-line-regexp      (setq adaptive-fill-first-line-regexp
2509            (concat quote-prefix-regexp "\\|"            (concat quote-prefix-regexp "\\|"
2510                    adaptive-fill-first-line-regexp))                    adaptive-fill-first-line-regexp)))
2511      (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")))    (make-local-variable 'auto-fill-inhibit-regexp)
2512      ;;(setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")
2513      (setq auto-fill-inhibit-regexp nil)
2514      (make-local-variable 'normal-auto-fill-function)
2515      (setq normal-auto-fill-function 'message-do-auto-fill)
2516      ;; KLUDGE: auto fill might already be turned on in `text-mode-hook'.
2517      ;; In that case, ensure that it uses the right function.  The real
2518      ;; solution would be not to use `define-derived-mode', and run
2519      ;; `text-mode-hook' ourself at the end of the mode.
2520      ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-19.
2521      (when auto-fill-function
2522        (setq auto-fill-function normal-auto-fill-function)))
2523    
2524    
2525    
# Line 1604  M-RET    `message-newline-and-reformat' Line 2534  M-RET    `message-newline-and-reformat'
2534    (interactive)    (interactive)
2535    (message-position-on-field "To"))    (message-position-on-field "To"))
2536    
2537    (defun message-goto-from ()
2538      "Move point to the From header."
2539      (interactive)
2540      (message-position-on-field "From"))
2541    
2542  (defun message-goto-subject ()  (defun message-goto-subject ()
2543    "Move point to the Subject header."    "Move point to the Subject header."
2544    (interactive)    (interactive)
# Line 1644  M-RET    `message-newline-and-reformat' Line 2579  M-RET    `message-newline-and-reformat'
2579    (interactive)    (interactive)
2580    (message-position-on-field "Followup-To" "Newsgroups"))    (message-position-on-field "Followup-To" "Newsgroups"))
2581    
2582    (defun message-goto-mail-followup-to ()
2583      "Move point to the Mail-Followup-To header."
2584      (interactive)
2585      (message-position-on-field "Mail-Followup-To" "From"))
2586    
2587  (defun message-goto-keywords ()  (defun message-goto-keywords ()
2588    "Move point to the Keywords header."    "Move point to the Keywords header."
2589    (interactive)    (interactive)
# Line 1654  M-RET    `message-newline-and-reformat' Line 2594  M-RET    `message-newline-and-reformat'
2594    (interactive)    (interactive)
2595    (message-position-on-field "Summary" "Subject"))    (message-position-on-field "Summary" "Subject"))
2596    
2597  (defun message-goto-body ()  (defun message-goto-body (&optional interactivep)
2598    "Move point to the beginning of the message body."    "Move point to the beginning of the message body."
2599    (interactive)    (interactive (list t))
2600    (if (looking-at "[ \t]*\n") (expand-abbrev))    (when (and interactivep
2601                 (looking-at "[ \t]*\n"))
2602        (expand-abbrev))
2603    (goto-char (point-min))    (goto-char (point-min))
2604    (or (search-forward (concat "\n" mail-header-separator "\n") nil t)    (or (search-forward (concat "\n" mail-header-separator "\n") nil t)
2605        (search-forward "\n\n" nil t)))        (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t)))
2606    
2607  (defun message-goto-eoh ()  (defun message-goto-eoh ()
2608    "Move point to the end of the headers."    "Move point to the end of the headers."
# Line 1679  return nil." Line 2621  return nil."
2621      (goto-char (point-max))      (goto-char (point-max))
2622      nil))      nil))
2623    
2624    (defun message-generate-unsubscribed-mail-followup-to (&optional include-cc)
2625      "Insert a reasonable MFT header in a post to an unsubscribed list.
2626    When making original posts to a mailing list you are not subscribed to,
2627    you have to type in a MFT header by hand.  The contents, usually, are
2628    the addresses of the list and your own address.  This function inserts
2629    such a header automatically.  It fetches the contents of the To: header
2630    in the current mail buffer, and appends the current `user-mail-address'.
2631    
2632    If the optional argument INCLUDE-CC is non-nil, the addresses in the
2633    Cc: header are also put into the MFT."
2634    
2635      (interactive "P")
2636      (let* (cc tos)
2637        (save-restriction
2638          (message-narrow-to-headers)
2639          (message-remove-header "Mail-Followup-To")
2640          (setq cc (and include-cc (message-fetch-field "Cc")))
2641          (setq tos (if cc
2642                        (concat (message-fetch-field "To") "," cc)
2643                      (message-fetch-field "To"))))
2644        (message-goto-mail-followup-to)
2645        (insert (concat tos ", " user-mail-address))))
2646    
2647    
2648    
2649  (defun message-insert-to (&optional force)  (defun message-insert-to (&optional force)
2650    "Insert a To header that points to the author of the article being replied to.    "Insert a To header that points to the author of the article being replied to.
2651  If the original author requested not to be sent mail, the function signals  If the original author requested not to be sent mail, don't insert unless the
2652  an error.  prefix FORCE is given."
 With the prefix argument FORCE, insert the header anyway."  
2653    (interactive "P")    (interactive "P")
2654    (let ((co (message-fetch-reply-field "mail-copies-to")))    (let* ((mct (message-fetch-reply-field "mail-copies-to"))
2655      (when (and (null force)           (dont (and mct (or (equal (downcase mct) "never")
2656                 co                              (equal (downcase mct) "nobody"))))
2657                 (or (equal (downcase co) "never")           (to (or (message-fetch-reply-field "mail-reply-to")
2658                     (equal (downcase co) "nobody")))                   (message-fetch-reply-field "reply-to")
2659        (error "The user has requested not to have copies sent via mail")))                   (message-fetch-reply-field "from"))))
2660    (when (and (message-position-on-field "To")      (when (and dont to)
2661               (mail-fetch-field "to")        (message
2662               (not (string-match "\\` *\\'" (mail-fetch-field "to"))))         (if force
2663      (insert ", "))             "Ignoring the user request not to have copies sent via mail"
2664    (insert (or (message-fetch-reply-field "reply-to")           "Complying with the user request not to have copies sent via mail")))
2665                (message-fetch-reply-field "from") "")))      (when (and force (not to))
2666          (error "No mail address in the article"))
2667        (when (and to (or force (not dont)))
2668          (message-carefully-insert-headers (list (cons 'To to))))))
2669    
2670    (defun message-insert-wide-reply ()
2671      "Insert To and Cc headers as if you were doing a wide reply."
2672      (interactive)
2673      (let ((headers (message-with-reply-buffer
2674                       (message-get-reply-headers t))))
2675        (message-carefully-insert-headers headers)))
2676    
2677    (defcustom message-header-synonyms
2678      '((To Cc Bcc))
2679      "List of lists of header synonyms.
2680    E.g., if this list contains a member list with elements `Cc' and `To',
2681    then `message-carefully-insert-headers' will not insert a `To' header
2682    when the message is already `Cc'ed to the recipient."
2683      :group 'message-headers
2684      :link '(custom-manual "(message)Message Headers")
2685      :type '(repeat sexp))
2686    
2687    (defun message-carefully-insert-headers (headers)
2688      "Insert the HEADERS, an alist, into the message buffer.
2689    Does not insert the headers when they are already present there
2690    or in the synonym headers, defined by `message-header-synonyms'."
2691      ;; FIXME: Should compare only the address and not the full name.  Comparison
2692      ;; should be done case-folded (and with `string=' rather than
2693      ;; `string-match').
2694      (dolist (header headers)
2695        (let* ((header-name (symbol-name (car header)))
2696               (new-header (cdr header))
2697               (synonyms (loop for synonym in message-header-synonyms
2698                               when (memq (car header) synonym) return synonym))
2699               (old-header
2700                (loop for synonym in synonyms
2701                      for old-header = (mail-fetch-field (symbol-name synonym))
2702                      when (and old-header (string-match new-header old-header))
2703                      return synonym)))
2704          (if old-header
2705              (message "already have `%s' in `%s'" new-header old-header)
2706            (when (and (message-position-on-field header-name)
2707                       (setq old-header (mail-fetch-field header-name))
2708                       (not (string-match "\\` *\\'" old-header)))
2709              (insert ", "))
2710            (insert new-header)))))
2711    
2712  (defun message-widen-reply ()  (defun message-widen-reply ()
2713    "Widen the reply to include maximum recipients."    "Widen the reply to include maximum recipients."
# Line 1734  With the prefix argument FORCE, insert t Line 2743  With the prefix argument FORCE, insert t
2743  (defun message-delete-not-region (beg end)  (defun message-delete-not-region (beg end)
2744    "Delete everything in the body of the current message outside of the region."    "Delete everything in the body of the current message outside of the region."
2745    (interactive "r")    (interactive "r")
2746    (save-excursion    (let (citeprefix)
2747      (goto-char end)      (save-excursion
2748      (delete-region (point) (if (not (message-goto-signature))        (goto-char beg)
2749                                 (point)        ;; snarf citation prefix, if appropriate
2750                               (forward-line -2)        (unless (eq (point) (progn (beginning-of-line) (point)))
2751                               (point)))          (when (looking-at message-cite-prefix-regexp)
2752      (insert "\n")            (setq citeprefix (match-string 0))))
2753      (goto-char beg)        (goto-char end)
2754      (delete-region beg (progn (message-goto-body)        (delete-region (point) (if (not (message-goto-signature))
2755                                (forward-line 2)                                   (point)
2756                                (point))))                                 (forward-line -2)
2757                                   (point)))
2758          (insert "\n")
2759          (goto-char beg)
2760          (delete-region beg (progn (message-goto-body)
2761                                    (forward-line 2)
2762                                    (point)))
2763          (when citeprefix
2764            (insert citeprefix))))
2765    (when (message-goto-signature)    (when (message-goto-signature)
2766      (forward-line -2)))      (forward-line -2)))
2767    
# Line 1754  With the prefix argument FORCE, insert t Line 2771  With the prefix argument FORCE, insert t
2771    (let ((point (point)))    (let ((point (point)))
2772      (message-goto-signature)      (message-goto-signature)
2773      (unless (eobp)      (unless (eobp)
2774        (forward-line -2))        (end-of-line -1))
2775      (kill-region point (point))      (kill-region point (point))
2776      (unless (bolp)      (unless (bolp)
2777        (insert "\n"))))        (insert "\n"))))
2778    
2779  (defun message-newline-and-reformat ()  (defun message-newline-and-reformat (&optional arg not-break)
2780    "Insert four newlines, and then reformat if inside quoted text."    "Insert four newlines, and then reformat if inside quoted text.
2781    (interactive)  Prefix arg means justify as well."
2782    ;; The Latin-1 angle quote looks pretty dubious.  -- fx    (interactive (list (if current-prefix-arg 'full)))
2783    (let ((prefix "[]>»|:}+ \t]*")    (let (quoted point beg end leading-space bolp)
         (supercite-thing "[-._[:alnum:]]*[>]+[ \t]*")  
         quoted point)  
     (unless (bolp)  
       (save-excursion  
         (beginning-of-line)  
         (when (looking-at (concat prefix  
                                   supercite-thing))  
           (setq quoted (match-string 0))))  
       (insert "\n"))  
2784      (setq point (point))      (setq point (point))
2785      (insert "\n\n\n")      (beginning-of-line)
2786      (delete-region (point) (re-search-forward "[ \t]*"))      (setq beg (point))
2787      (when quoted      (setq bolp (= beg point))
2788        (insert quoted))      ;; Find first line of the paragraph.
2789      (fill-paragraph nil)      (if not-break
2790            (while (and (not (eobp))
2791                        (not (looking-at message-cite-prefix-regexp))
2792                        (looking-at paragraph-start))
2793              (forward-line 1)))
2794        ;; Find the prefix
2795        (when (looking-at message-cite-prefix-regexp)
2796          (setq quoted (match-string 0))
2797          (goto-char (match-end 0))
2798          (looking-at "[ \t]*")
2799          (setq leading-space (match-string 0)))
2800        (if (and quoted
2801                 (not not-break)
2802                 (not bolp)
2803                 (< (- point beg) (length quoted)))
2804            ;; break inside the cite prefix.
2805            (setq quoted nil
2806                  end nil))
2807        (if quoted
2808            (progn
2809              (forward-line 1)
2810              (while (and (not (eobp))
2811                          (not (looking-at paragraph-separate))
2812                          (looking-at message-cite-prefix-regexp)
2813                          (equal quoted (match-string 0)))
2814                (goto-char (match-end 0))
2815                (looking-at "[ \t]*")
2816                (if (> (length leading-space) (length (match-string 0)))
2817                    (setq leading-space (match-string 0)))
2818                (forward-line 1))
2819              (setq end (point))
2820              (goto-char beg)
2821              (while (and (if (bobp) nil (forward-line -1) t)
2822                          (not (looking-at paragraph-start))
2823                          (looking-at message-cite-prefix-regexp)
2824                          (equal quoted (match-string 0)))
2825                (setq beg (point))
2826                (goto-char (match-end 0))
2827                (looking-at "[ \t]*")
2828                (if (> (length leading-space) (length (match-string 0)))
2829                    (setq leading-space (match-string 0)))))
2830          (while (and (not (eobp))
2831                      (not (looking-at paragraph-separate))
2832                      (not (looking-at message-cite-prefix-regexp)))
2833            (forward-line 1))
2834          (setq end (point))
2835          (goto-char beg)
2836          (while (and (if (bobp) nil (forward-line -1) t)
2837                      (not (looking-at paragraph-start))
2838                      (not (looking-at message-cite-prefix-regexp)))
2839            (setq beg (point))))
2840      (goto-char point)      (goto-char point)
2841      (forward-line 1)))      (save-restriction
2842          (narrow-to-region beg end)
2843          (if not-break
2844              (setq point nil)
2845            (if bolp
2846                (newline)
2847              (newline)
2848              (newline))
2849            (setq point (point))
2850            ;; (newline 2) doesn't mark both newline's as hard, so call
2851            ;; newline twice. -jas
2852            (newline)
2853            (newline)
2854            (delete-region (point) (re-search-forward "[ \t]*"))
2855            (when (and quoted (not bolp))
2856              (insert quoted leading-space)))
2857          (undo-boundary)
2858          (if quoted
2859              (let* ((adaptive-fill-regexp
2860                      (regexp-quote (concat quoted leading-space)))
2861                     (adaptive-fill-first-line-regexp
2862                      adaptive-fill-regexp ))
2863                (fill-paragraph arg))
2864            (fill-paragraph arg))
2865          (if point (goto-char point)))))
2866    
2867    (defun message-fill-paragraph (&optional arg)
2868      "Like `fill-paragraph'."
2869      (interactive (list (if current-prefix-arg 'full)))
2870      (if (if (boundp 'filladapt-mode) filladapt-mode)
2871          nil
2872        (message-newline-and-reformat arg t)
2873        t))
2874    
2875  (defun message-split-line ()  ;; Is it better to use `mail-header-end'?
2876    "Split current line, moving portion beyond point vertically down.  (defun message-point-in-header-p ()
2877  If the current line has `message-yank-prefix', insert it on the new line."    "Return t if point is in the header."
2878    (interactive "*")    (save-excursion
2879    (split-line message-yank-prefix))      (let ((p (point)))
2880          (goto-char (point-min))
2881          (not (re-search-forward
2882                (concat "^" (regexp-quote mail-header-separator) "\n")
2883                p t)))))
2884    
2885    (defun message-do-auto-fill ()
2886      "Like `do-auto-fill', but don't fill in message header."
2887      (unless (message-point-in-header-p)
2888        (do-auto-fill)))
2889    
2890  (defun message-insert-signature (&optional force)  (defun message-insert-signature (&optional force)
2891    "Insert a signature.  See documentation for variable `message-signature'."    "Insert a signature.  See documentation for variable `message-signature'."
# Line 1801  If the current line has `message-yank-pr Line 2900  If the current line has `message-yank-pr
2900             ((and (null message-signature)             ((and (null message-signature)
2901                   force)                   force)
2902              t)              t)
2903             ((message-functionp message-signature)             ((functionp message-signature)
2904              (funcall message-signature))              (funcall message-signature))
2905             ((listp message-signature)             ((listp message-signature)
2906              (eval message-signature))              (eval message-signature))
# Line 1818  If the current line has `message-yank-pr Line 2917  If the current line has `message-yank-pr
2917        ;; Insert the signature.        ;; Insert the signature.
2918        (unless (bolp)        (unless (bolp)
2919          (insert "\n"))          (insert "\n"))
2920        (insert "\n-- \n")        (when message-signature-insert-empty-line
2921            (insert "\n"))
2922          (insert "-- \n")
2923        (if (eq signature t)        (if (eq signature t)
2924            (insert-file-contents message-signature-file)            (insert-file-contents message-signature-file)
2925          (insert signature))          (insert signature))
2926        (goto-char (point-max))        (goto-char (point-max))
2927        (or (bolp) (insert "\n")))))        (or (bolp) (insert "\n")))))
2928    
2929    (defun message-insert-importance-high ()
2930      "Insert header to mark message as important."
2931      (interactive)
2932      (save-excursion
2933        (save-restriction
2934          (message-narrow-to-headers)
2935          (message-remove-header "Importance"))
2936        (message-goto-eoh)
2937        (insert "Importance: high\n")))
2938    
2939    (defun message-insert-importance-low ()
2940      "Insert header to mark message as unimportant."
2941      (interactive)
2942      (save-excursion
2943        (save-restriction
2944          (message-narrow-to-headers)
2945          (message-remove-header "Importance"))
2946        (message-goto-eoh)
2947        (insert "Importance: low\n")))
2948    
2949    (defun message-insert-or-toggle-importance ()
2950      "Insert a \"Importance: high\" header, or cycle through the header values.
2951    The three allowed values according to RFC 1327 are `high', `normal'
2952    and `low'."
2953      (interactive)
2954      (save-excursion
2955        (let ((valid '("high" "normal" "low"))
2956              (new "high")
2957              cur)
2958          (save-restriction
2959            (message-narrow-to-headers)
2960            (when (setq cur (message-fetch-field "Importance"))
2961              (message-remove-header "Importance")
2962              (setq new (cond ((string= cur "high")
2963                               "low")
2964                              ((string= cur "low")
2965                               "normal")
2966                              (t
2967                               "high")))))
2968          (message-goto-eoh)
2969          (insert (format "Importance: %s\n" new)))))
2970    
2971    (defun message-insert-disposition-notification-to ()
2972      "Request a disposition notification (return receipt) to this message.
2973    Note that this should not be used in newsgroups."
2974      (interactive)
2975      (save-excursion
2976        (save-restriction
2977          (message-narrow-to-headers)
2978          (message-remove-header "Disposition-Notification-To"))
2979        (message-goto-eoh)
2980        (insert (format "Disposition-Notification-To: %s\n"
2981                        (or (message-field-value "Reply-to")
2982                            (message-field-value "From")
2983                            (message-make-from))))))
2984    
2985  (defun message-elide-region (b e)  (defun message-elide-region (b e)
2986    "Elide the text in the region.    "Elide the text in the region.
2987  An ellipsis (from `message-elide-ellipsis') will be inserted where the  An ellipsis (from `message-elide-ellipsis') will be inserted where the
# Line 1845  text was killed." Line 3002  text was killed."
3002        (prefix-numeric-value current-prefix-arg))))        (prefix-numeric-value current-prefix-arg))))
3003    
3004    (setq n (if (numberp n) (mod n 26) 13)) ;canonize N    (setq n (if (numberp n) (mod n 26) 13)) ;canonize N
3005    (unless (or (zerop n)                 ; no action needed for a rot of 0    (unless (or (zerop n)                 ; no action needed for a rot of 0
3006                (= b e))                  ; no region to rotate                (= b e))                  ; no region to rotate
3007      ;; We build the table, if necessary.      ;; We build the table, if necessary.
3008      (when (or (not message-caesar-translation-table)      (when (or (not message-caesar-translation-table)
# Line 1888  Mail and USENET news headers are not rot Line 3045  Mail and USENET news headers are not rot
3045    (save-excursion    (save-excursion
3046      (save-restriction      (save-restriction
3047        (when (message-goto-body)        (when (message-goto-body)
3048          (narrow-to-region (point) (point-max)))          (narrow-to-region (point) (point-max)))
3049        (shell-command-on-region        (shell-command-on-region
3050         (point-min) (point-max) program nil t))))         (point-min) (point-max) program nil t))))
3051    
# Line 1968  However, if `message-yank-prefix' is non Line 3125  However, if `message-yank-prefix' is non
3125        (save-excursion        (save-excursion
3126          (goto-char start)          (goto-char start)
3127          (while (< (point) (mark t))          (while (< (point) (mark t))
3128            (insert message-yank-prefix)            (if (or (looking-at ">") (looking-at "^$"))
3129                  (insert message-yank-cited-prefix)
3130                (insert message-yank-prefix))
3131            (forward-line 1))))            (forward-line 1))))
3132      (goto-char start)))      (goto-char start)))
3133    
# Line 1999  prefix, and don't delete any headers." Line 3158  prefix, and don't delete any headers."
3158  (defun message-yank-buffer (buffer)  (defun message-yank-buffer (buffer)
3159    "Insert BUFFER into the current buffer and quote it."    "Insert BUFFER into the current buffer and quote it."
3160    (interactive "bYank buffer: ")    (interactive "bYank buffer: ")
3161    (let ((message-reply-buffer buffer))    (let ((message-reply-buffer (get-buffer buffer)))
3162      (save-window-excursion      (save-window-excursion
3163        (message-yank-original))))        (message-yank-original))))
3164    
# Line 2016  prefix, and don't delete any headers." Line 3175  prefix, and don't delete any headers."
3175    
3176  (defun message-cite-original-without-signature ()  (defun message-cite-original-without-signature ()
3177    "Cite function in the standard Message manner."    "Cite function in the standard Message manner."
3178    (let ((start (point))    (let* ((start (point))
3179          (end (mark t))           (end (mark t))
3180          (functions           (functions
3181           (when message-indent-citation-function            (when message-indent-citation-function
3182             (if (listp message-indent-citation-function)              (if (listp message-indent-citation-function)
3183                 message-indent-citation-function                  message-indent-citation-function
3184               (list message-indent-citation-function)))))                (list message-indent-citation-function))))
3185             ;; This function may be called by `gnus-summary-yank-message' and
3186             ;; may insert a different article from the original.  So, we will
3187             ;; modify the value of `message-reply-headers' with that article.
3188             (message-reply-headers
3189              (save-restriction
3190                (narrow-to-region start end)
3191                (message-narrow-to-head-1)
3192                (vector 0
3193                        (or (message-fetch-field "subject") "none")
3194                        (message-fetch-field "from")
3195                        (message-fetch-field "date")
3196                        (message-fetch-field "message-id" t)
3197                        (message-fetch-field "references")
3198                        0 0 ""))))
3199      (mml-quote-region start end)      (mml-quote-region start end)
3200      ;; Allow undoing.      ;; Allow undoing.
3201      (undo-boundary)      (undo-boundary)
# Line 2045  prefix, and don't delete any headers." Line 3218  prefix, and don't delete any headers."
3218          (insert "\n"))          (insert "\n"))
3219        (funcall message-citation-line-function))))        (funcall message-citation-line-function))))
3220    
3221  (eval-when-compile (defvar mail-citation-hook))         ;Compiler directive  (eval-when-compile (defvar mail-citation-hook)) ;Compiler directive
3222  (defun message-cite-original ()  (defun message-cite-original ()
3223    "Cite function in the standard Message manner."    "Cite function in the standard Message manner."
3224    (if (and (boundp 'mail-citation-hook)    (if (and (boundp 'mail-citation-hook)
3225             mail-citation-hook)             mail-citation-hook)
3226        (run-hooks 'mail-citation-hook)        (run-hooks 'mail-citation-hook)
3227      (let ((start (point))      (let* ((start (point))
3228            (end (mark t))             (end (mark t))
3229            (functions             (functions
3230             (when message-indent-citation-function              (when message-indent-citation-function
3231               (if (listp message-indent-citation-function)                (if (listp message-indent-citation-function)
3232                   message-indent-citation-function                    message-indent-citation-function
3233                 (list message-indent-citation-function)))))                  (list message-indent-citation-function))))
3234               ;; This function may be called by `gnus-summary-yank-message' and
3235               ;; may insert a different article from the original.  So, we will
3236               ;; modify the value of `message-reply-headers' with that article.
3237               (message-reply-headers
3238                (save-restriction
3239                  (narrow-to-region start end)
3240                  (message-narrow-to-head-1)
3241                  (vector 0
3242                          (or (message-fetch-field "subject") "none")
3243                          (message-fetch-field "from")
3244                          (message-fetch-field "date")
3245                          (message-fetch-field "message-id" t)
3246                          (message-fetch-field "references")
3247                          0 0 ""))))
3248        (mml-quote-region start end)        (mml-quote-region start end)
3249        (goto-char start)        (goto-char start)
3250        (while functions        (while functions
# Line 2144  The text will also be indented the norma Line 3331  The text will also be indented the norma
3331        t)))        t)))
3332    
3333  (defun message-dont-send ()  (defun message-dont-send ()
3334    "Don't send the message you have been editing."    "Don't send the message you have been editing.
3335    Instead, just auto-save the buffer and then bury it."
3336    (interactive)    (interactive)
3337    (set-buffer-modified-p t)    (set-buffer-modified-p t)
3338    (save-buffer)    (save-buffer)
# Line 2157  The text will also be indented the norma Line 3345  The text will also be indented the norma
3345    (interactive)    (interactive)
3346    (when (or (not (buffer-modified-p))    (when (or (not (buffer-modified-p))
3347              (yes-or-no-p "Message modified; kill anyway? "))              (yes-or-no-p "Message modified; kill anyway? "))
3348      (let ((actions message-kill-actions))      (let ((actions message-kill-actions)
3349              (draft-article message-draft-article)
3350              (auto-save-file-name buffer-auto-save-file-name)
3351              (file-name buffer-file-name)
3352              (modified (buffer-modified-p)))
3353        (setq buffer-file-name nil)        (setq buffer-file-name nil)
3354        (kill-buffer (current-buffer))        (kill-buffer (current-buffer))
3355          (when (and (or (and auto-save-file-name
3356                              (file-exists-p auto-save-file-name))
3357                         (and file-name
3358                              (file-exists-p file-name)))
3359                   (yes-or-no-p (format "Remove the backup file%s? "
3360                                        (if modified " too" ""))))
3361            (ignore-errors
3362              (delete-file auto-save-file-name))
3363            (let ((message-draft-article draft-article))
3364              (message-disassociate-draft)))
3365        (message-do-actions actions))))        (message-do-actions actions))))
3366    
3367  (defun message-bury (buffer)  (defun message-bury (buffer)
# Line 2190  It should typically alter the sending me Line 3392  It should typically alter the sending me
3392    (message message-sending-message)    (message message-sending-message)
3393    (let ((alist message-send-method-alist)    (let ((alist message-send-method-alist)
3394          (success t)          (success t)
3395          elem sent)          elem sent dont-barf-on-no-method
3396            (message-options message-options))
3397        (message-options-set-recipient)
3398      (while (and success      (while (and success
3399                  (setq elem (pop alist)))                  (setq elem (pop alist)))
3400        (when (funcall (cadr elem))        (when (funcall (cadr elem))
3401          (when (and (or (not (memq (car elem)          (when (and (or (not (memq (car elem)
3402                                    message-sent-message-via))                                    message-sent-message-via))
3403                         (y-or-n-p                         (message-fetch-field "supersedes")
3404                          (format                         (if (or (message-gnksa-enable-p 'multiple-copies)
3405                           "Already sent message via %s; resend? "                                 (not (eq (car elem) 'news)))
3406                           (car elem))))                             (y-or-n-p
3407                                (format
3408                                 "Already sent message via %s; resend? "
3409                                 (car elem)))
3410                             (error "Denied posting -- multiple copies")))
3411                     (setq success (funcall (caddr elem) arg)))                     (setq success (funcall (caddr elem) arg)))
3412            (setq sent t))))            (setq sent t))))
3413      (unless (or sent (not success))      (unless (or sent
3414                    (not success)
3415                    (let ((fcc (message-fetch-field "Fcc"))
3416                          (gcc (message-fetch-field "Gcc")))
3417                      (when (or fcc gcc)
3418                        (or (eq message-allow-no-recipients 'always)
3419                            (and (not (eq message-allow-no-recipients 'never))
3420                                 (setq dont-barf-on-no-method
3421                                       (gnus-y-or-n-p
3422                                        (format "No receiver, perform %s anyway? "
3423                                                (cond ((and fcc gcc) "Fcc and Gcc")
3424                                                      (fcc "Fcc")
3425                                                      (t "Gcc"))))))))))
3426        (error "No methods specified to send by"))        (error "No methods specified to send by"))
3427      (when (and success sent)      (when (or dont-barf-on-no-method
3428                  (and success sent))
3429        (message-do-fcc)        (message-do-fcc)
3430        (save-excursion        (save-excursion
3431          (run-hooks 'message-sent-hook))          (run-hooks 'message-sent-hook))
# Line 2236  It should typically alter the sending me Line 3457  It should typically alter the sending me
3457  (put 'message-check 'lisp-indent-function 1)  (put 'message-check 'lisp-indent-function 1)
3458  (put 'message-check 'edebug-form-spec '(form body))  (put 'message-check 'edebug-form-spec '(form body))
3459    
3460    (defun message-text-with-property (prop)
3461      "Return a list of all points where the text has PROP."
3462      (let ((points nil)
3463            (point (point-min)))
3464        (save-excursion
3465          (while (< point (point-max))
3466            (when (get-text-property point prop)
3467              (push point points))
3468            (incf point)))
3469        (nreverse points)))
3470    
3471  (defun message-fix-before-sending ()  (defun message-fix-before-sending ()
3472    "Do various things to make the message nice before sending it."    "Do various things to make the message nice before sending it."
3473    ;; Make sure there's a newline at the end of the message.    ;; Make sure there's a newline at the end of the message.
3474    (goto-char (point-max))    (goto-char (point-max))
3475    (unless (bolp)    (unless (bolp)
3476      (insert "\n"))      (insert "\n"))
3477    ;; Delete all invisible text.    ;; Make the hidden headers visible.
3478      (let ((points (message-text-with-property 'message-hidden)))
3479        (when points
3480          (goto-char (car points))
3481          (dolist (point points)
3482            (add-text-properties point (1+ point)
3483                                 '(invisible nil intangible nil)))))
3484      ;; Make invisible text visible.
3485      ;; It doesn't seem as if this is useful, since the invisible property
3486      ;; is clobbered by an after-change hook anyhow.
3487    (message-check 'invisible-text    (message-check 'invisible-text
3488      (when (text-property-any (point-min) (point-max) 'invisible t)      (let ((points (message-text-with-property 'invisible)))
3489        (put-text-property (point-min) (point-max) 'invisible nil)        (when points
3490        (unless (yes-or-no-p          (goto-char (car points))
3491                 "Invisible text found and made visible; continue posting? ")          (dolist (point points)
3492          (error "Invisible text found and made visible")))))            (put-text-property point (1+ point) 'invisible nil)
3493              (message-overlay-put (message-make-overlay point (1+ point))
3494                                   'face 'highlight))
3495            (unless (yes-or-no-p
3496                     "Invisible text found and made visible; continue sending? ")
3497              (error "Invisible text found and made visible")))))
3498      (message-check 'illegible-text
3499        (let (found choice)
3500          (message-goto-body)
3501          (skip-chars-forward mm-7bit-chars)
3502          (while (not (eobp))
3503            (when (let ((char (char-after)))
3504                    (or (< (mm-char-int char) 128)
3505                        (and (mm-multibyte-p)
3506                             (memq (char-charset char)
3507                                   '(eight-bit-control eight-bit-graphic
3508                                                       control-1))
3509                             (not (get-text-property
3510                                   (point) 'untranslated-utf-8)))))
3511              (message-overlay-put (message-make-overlay (point) (1+ (point)))
3512                                   'face 'highlight)
3513              (setq found t))
3514            (forward-char)
3515            (skip-chars-forward mm-7bit-chars))
3516          (when found
3517            (setq choice
3518                  (gnus-multiple-choice
3519                   "Non-printable characters found.  Continue sending?"
3520                   '((?d "Remove non-printable characters and send")
3521                     (?r "Replace non-printable characters with dots and send")
3522                     (?i "Ignore non-printable characters and send")
3523                     (?e "Continue editing"))))
3524            (if (eq choice ?e)
3525              (error "Non-printable characters"))
3526            (message-goto-body)
3527            (skip-chars-forward mm-7bit-chars)
3528            (while (not (eobp))
3529              (when (let ((char (char-after)))
3530                      (or (< (mm-char-int char) 128)
3531                          (and (mm-multibyte-p)
3532                               ;; Fixme: Wrong for Emacs 22 and for things
3533                               ;; like undecable utf-8.  Should at least
3534                               ;; use find-coding-systems-region.
3535                               (memq (char-charset char)
3536                                     '(eight-bit-control eight-bit-graphic
3537                                                         control-1))
3538                               (not (get-text-property
3539                                     (point) 'untranslated-utf-8)))))
3540                (if (eq choice ?i)
3541                    (message-kill-all-overlays)
3542                  (delete-char 1)
3543                  (when (eq choice ?r)
3544                    (insert "."))))
3545              (forward-char)
3546              (skip-chars-forward mm-7bit-chars))))))
3547    
3548  (defun message-add-action (action &rest types)  (defun message-add-action (action &rest types)
3549    "Add ACTION to be performed when doing an exit of type TYPES."    "Add ACTION to be performed when doing an exit of type TYPES."
3550      (while types
3551        (add-to-list (intern (format "message-%s-actions" (pop types)))
3552                     action)))
3553    
3554    (defun message-delete-action (action &rest types)
3555      "Delete ACTION from lists of actions performed when doing an exit of type TYPES."
3556    (let (var)    (let (var)
3557      (while types      (while types
3558        (set (setq var (intern (format "message-%s-actions" (pop types))))        (set (setq var (intern (format "message-%s-actions" (pop types))))
3559             (nconc (symbol-value var) (list action))))))             (delq action (symbol-value var))))))
3560    
3561  (defun message-do-actions (actions)  (defun message-do-actions (actions)
3562    "Perform all actions in ACTIONS."    "Perform all actions in ACTIONS."
# Line 2264  It should typically alter the sending me Line 3565  It should typically alter the sending me
3565      (ignore-errors      (ignore-errors
3566        (cond        (cond
3567         ;; A simple function.         ;; A simple function.
3568         ((message-functionp (car actions))         ((functionp (car actions))
3569          (funcall (car actions)))          (funcall (car actions)))
3570         ;; Something to be evaled.         ;; Something to be evaled.
3571         (t         (t
# Line 2272  It should typically alter the sending me Line 3573  It should typically alter the sending me
3573      (pop actions)))      (pop actions)))
3574    
3575  (defun message-send-mail-partially ()  (defun message-send-mail-partially ()
3576    "Sendmail as message/partial."    "Send mail as message/partial."
3577    ;; replace the header delimiter with a blank line    ;; replace the header delimiter with a blank line
3578    (goto-char (point-min))    (goto-char (point-min))
3579    (re-search-forward    (re-search-forward
# Line 2320  It should typically alter the sending me Line 3621  It should typically alter the sending me
3621                (message-remove-header "Lines")                (message-remove-header "Lines")
3622                (goto-char (point-max))                (goto-char (point-max))
3623                (insert "Mime-Version: 1.0\n")                (insert "Mime-Version: 1.0\n")
3624                (setq header (buffer-substring (point-min) (point-max))))                (setq header (buffer-string)))
3625              (goto-char (point-max))              (goto-char (point-max))
3626              (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n"              (insert (format "Content-Type: message/partial; id=\"%s\"; number=%d; total=%d\n\n"
3627                              id n total))                              id n total))
3628                (forward-char -1)
3629              (let ((mail-header-separator ""))              (let ((mail-header-separator ""))
3630                (when (memq 'Message-ID message-required-mail-headers)                (when (memq 'Message-ID message-required-mail-headers)
3631                  (insert "Message-ID: " (message-make-message-id) "\n"))                  (insert "Message-ID: " (message-make-message-id) "\n"))
3632                (when (memq 'Lines message-required-mail-headers)                (when (memq 'Lines message-required-mail-headers)
3633                  (let ((mail-header-separator ""))                  (insert "Lines: " (message-make-lines) "\n"))
                   (insert "Lines: " (message-make-lines) "\n")))  
3634                (message-goto-subject)                (message-goto-subject)
3635                (end-of-line)                (end-of-line)
3636                (insert (format " (%d/%d)" n total))                (insert (format " (%d/%d)" n total))
               (goto-char (point-max))  
               (insert "\n")  
3637                (widen)                (widen)
3638                (mm-with-unibyte-current-buffer                (mm-with-unibyte-current-buffer
3639                  (funcall message-send-mail-function)))                  (funcall (or message-send-mail-real-function
3640                                 message-send-mail-function))))
3641              (setq n (+ n 1))              (setq n (+ n 1))
3642              (setq p (pop plist))              (setq p (pop plist))
3643              (erase-buffer)))              (erase-buffer)))
# Line 2353  It should typically alter the sending me Line 3653  It should typically alter the sending me
3653           (message-posting-charset           (message-posting-charset
3654            (if (fboundp 'gnus-setup-posting-charset)            (if (fboundp 'gnus-setup-posting-charset)
3655                (gnus-setup-posting-charset nil)                (gnus-setup-posting-charset nil)
3656              message-posting-charset)))              message-posting-charset))
3657             (headers message-required-mail-headers))
3658      (save-restriction      (save-restriction
3659        (message-narrow-to-headers)        (message-narrow-to-headers)
3660          ;; Generate the Mail-Followup-To header if the header is not there...
3661          (if (and (message-subscribed-p)
3662                   (not (mail-fetch-field "mail-followup-to")))
3663              (setq headers
3664                    (cons
3665                     (cons "Mail-Followup-To" (message-make-mail-followup-to))
3666                     message-required-mail-headers))
3667            ;; otherwise, delete the MFT header if the field is empty
3668            (when (equal "" (mail-fetch-field "mail-followup-to"))
3669              (message-remove-header "^Mail-Followup-To:")))
3670        ;; Insert some headers.        ;; Insert some headers.
3671        (let ((message-deletable-headers        (let ((message-deletable-headers
3672               (if news nil message-deletable-headers)))               (if news nil message-deletable-headers)))
3673          (message-generate-headers message-required-mail-headers))          (message-generate-headers headers))
3674        ;; Let the user do all of the above.        ;; Let the user do all of the above.
3675        (run-hooks 'message-header-hook))        (run-hooks 'message-header-hook))
3676      (unwind-protect      (unwind-protect
3677          (save-excursion          (save-excursion
3678            (set-buffer tembuf)            (set-buffer tembuf)
3679            (erase-buffer)            (erase-buffer)
3680            ;; Avoid copying text props.            ;; Avoid copying text props (except hard newlines).
3681            (insert (with-current-buffer mailbuf            (insert (with-current-buffer mailbuf
3682                      (buffer-substring-no-properties (point-min) (point-max))))                      (mml-buffer-substring-no-properties-except-hard-newlines
3683                         (point-min) (point-max))))
3684            ;; Remove some headers.            ;; Remove some headers.
3685            (message-encode-message-body)            (message-encode-message-body)
3686            (save-restriction            (save-restriction
# Line 2384  It should typically alter the sending me Line 3696  It should typically alter the sending me
3696            ;; require one newline at the end.            ;; require one newline at the end.
3697            (or (= (preceding-char) ?\n)            (or (= (preceding-char) ?\n)
3698                (insert ?\n))                (insert ?\n))
3699              (message-cleanup-headers)
3700              ;; FIXME: we're inserting the courtesy copy after encoding.
3701              ;; This is wrong if the courtesy copy string contains
3702              ;; non-ASCII characters. -- jh
3703            (when            (when
3704                (save-restriction                (save-restriction
3705                  (message-narrow-to-headers)                  (message-narrow-to-headers)
3706                  (and news                  (and news
3707                       (or (message-fetch-field "cc")                       (or (message-fetch-field "cc")
3708                             (message-fetch-field "bcc")
3709                           (message-fetch-field "to"))                           (message-fetch-field "to"))
3710                       (let ((content-type (message-fetch-field "content-type")))                       (let ((content-type (message-fetch-field
3711                         (or                                            "content-type")))
3712                          (not content-type)                         (and
3713                          (string= "text/plain"                          (or
3714                                   (car                           (not content-type)
3715                                    (mail-header-parse-content-type                           (string= "text/plain"
3716                                     content-type)))))))                                    (car
3717                                       (mail-header-parse-content-type
3718                                        content-type))))
3719                            (not
3720                             (string= "base64"
3721                                      (message-fetch-field
3722                                       "content-transfer-encoding")))))))
3723              (message-insert-courtesy-copy))              (message-insert-courtesy-copy))
3724            (if (or (not message-send-mail-partially-limit)            (if (or (not message-send-mail-partially-limit)
3725                    (< (point-max) message-send-mail-partially-limit)                    (< (buffer-size) message-send-mail-partially-limit)
3726                    (not (y-or-n-p "The message size is too large, should it be sent partially? ")))                    (not (message-y-or-n-p
3727                            "The message size is too large, split? "
3728                            t
3729                            "\
3730    The message size, "
3731                            (/ (buffer-size) 1000) "KB, is too large.
3732    
3733    Some mail gateways (MTA's) bounce large messages.  To avoid the
3734    problem, answer `y', and the message will be split into several
3735    smaller pieces, the size of each is about "
3736                            (/ message-send-mail-partially-limit 1000)
3737                            "KB except the last
3738    one.
3739    
3740    However, some mail readers (MUA's) can't read split messages, i.e.,
3741    mails in message/partially format. Answer `n', and the message will be
3742    sent in one piece.
3743    
3744    The size limit is controlled by `message-send-mail-partially-limit'.
3745    If you always want Gnus to send messages in one piece, set
3746    `message-send-mail-partially-limit' to nil.
3747    ")))
3748                (mm-with-unibyte-current-buffer                (mm-with-unibyte-current-buffer
3749                  (funcall message-send-mail-function))                  (message "Sending via mail...")
3750                    (funcall (or message-send-mail-real-function
3751                                 message-send-mail-function)))
3752              (message-send-mail-partially)))              (message-send-mail-partially)))
3753        (kill-buffer tembuf))        (kill-buffer tembuf))
3754      (set-buffer mailbuf)      (set-buffer mailbuf)
# Line 2415  It should typically alter the sending me Line 3761  It should typically alter the sending me
3761                       " sendmail errors")                       " sendmail errors")
3762                    0))                    0))
3763          resend-to-addresses delimline)          resend-to-addresses delimline)
3764      (let ((case-fold-search t))      (unwind-protect
3765        (save-restriction          (progn
3766          (message-narrow-to-headers)            (let ((case-fold-search t))
3767          (setq resend-to-addresses (message-fetch-field "resent-to")))              (save-restriction
3768        ;; Change header-delimiter to be what sendmail expects.                (message-narrow-to-headers)
3769        (goto-char (point-min))                (setq resend-to-addresses (message-fetch-field "resent-to")))
3770        (re-search-forward              ;; Change header-delimiter to be what sendmail expects.
3771         (concat "^" (regexp-quote mail-header-separator) "\n"))              (goto-char (point-min))
3772        (replace-match "\n")              (re-search-forward
3773        (backward-char 1)               (concat "^" (regexp-quote mail-header-separator) "\n"))
3774        (setq delimline (point-marker))              (replace-match "\n")
3775        (run-hooks 'message-send-mail-hook)              (backward-char 1)
3776        ;; Insert an extra newline if we need it to work around              (setq delimline (point-marker))
3777        ;; Sun's bug that swallows newlines.              (run-hooks 'message-send-mail-hook)
3778        (goto-char (1+ delimline))              ;; Insert an extra newline if we need it to work around
3779        (when (eval message-mailer-swallows-blank-line)              ;; Sun's bug that swallows newlines.
3780          (newline))              (goto-char (1+ delimline))
3781        (when message-interactive              (when (eval message-mailer-swallows-blank-line)
3782          (save-excursion                (newline))
3783            (set-buffer errbuf)              (when message-interactive
3784            (erase-buffer))))                (save-excursion
3785      (let ((default-directory "/")                  (set-buffer errbuf)
3786            (coding-system-for-write message-send-coding-system))                  (erase-buffer))))
3787        (apply 'call-process-region            (let* ((default-directory "/")
3788               (append (list (point-min) (point-max)                   (coding-system-for-write message-send-coding-system)
3789                             (if (boundp 'sendmail-program)                   (cpr (apply
3790                                 sendmail-program                         'call-process-region
3791                               "/usr/lib/sendmail")                         (append
3792                             nil errbuf nil "-oi")                          (list (point-min) (point-max)
3793                       ;; Always specify who from,                                (if (boundp 'sendmail-program)
3794                       ;; since some systems have broken sendmails.                                    sendmail-program
3795                       ;; But some systems are more broken with -f, so                                  "/usr/lib/sendmail")
3796                       ;; we'll let users override this.                                nil errbuf nil "-oi")
3797                       (if (null message-sendmail-f-is-evil)                          ;; Always specify who from,
3798                           (list "-f" (message-make-address)))                          ;; since some systems have broken sendmails.
3799                       ;; These mean "report errors by mail"                          ;; But some systems are more broken with -f, so
3800                       ;; and "deliver in background".                          ;; we'll let users override this.
3801                       (if (null message-interactive) '("-oem" "-odb"))                          (if (null message-sendmail-f-is-evil)
3802                       ;; Get the addresses from the message                              (list "-f" (message-sendmail-envelope-from)))
3803                       ;; unless this is a resend.                          ;; These mean "report errors by mail"
3804                       ;; We must not do that for a resend                          ;; and "deliver in background".
3805                       ;; because we would find the original addresses.                          (if (null message-interactive) '("-oem" "-odb"))
3806                       ;; For a resend, include the specific addresses.                          ;; Get the addresses from the message
3807                       (if resend-to-addresses                          ;; unless this is a resend.
3808                           (list resend-to-addresses)                          ;; We must not do that for a resend
3809                         '("-t")))))                          ;; because we would find the original addresses.
3810      (when message-interactive                          ;; For a resend, include the specific addresses.
3811        (save-excursion                          (if resend-to-addresses
3812          (set-buffer errbuf)                              (list resend-to-addresses)
3813          (goto-char (point-min))                            '("-t"))))))
3814          (while (re-search-forward "\n\n* *" nil t)              (unless (or (null cpr) (and (numberp cpr) (zerop cpr)))
3815            (replace-match "; "))                (error "Sending...failed with exit value %d" cpr)))
3816          (if (not (zerop (buffer-size)))            (when message-interactive
3817              (error "Sending...failed to %s"              (save-excursion
3818                     (buffer-substring (point-min) (point-max)))))                (set-buffer errbuf)
3819                  (goto-char (point-min))
3820                  (while (re-search-forward "\n\n* *" nil t)
3821                    (replace-match "; "))
3822                  (if (not (zerop (buffer-size)))
3823                      (error "Sending...failed to %s"
3824                             (buffer-string))))))
3825        (when (bufferp errbuf)        (when (bufferp errbuf)
3826          (kill-buffer errbuf)))))          (kill-buffer errbuf)))))
3827    
# Line 2487  to find out how to use this." Line 3839  to find out how to use this."
3839    (case    (case
3840        (let ((coding-system-for-write message-send-coding-system))        (let ((coding-system-for-write message-send-coding-system))
3841          (apply          (apply
3842           'call-process-region 1 (point-max) message-qmail-inject-program           'call-process-region (point-min) (point-max)
3843           nil nil nil           message-qmail-inject-program nil nil nil
3844           ;; qmail-inject's default behaviour is to look for addresses on the           ;; qmail-inject's default behaviour is to look for addresses on the
3845           ;; command line; if there're none, it scans the headers.           ;; command line; if there're none, it scans the headers.
3846           ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.           ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin.
# Line 2506  to find out how to use this." Line 3858  to find out how to use this."
3858           ;; free for -inject-arguments -- a big win for the user and for us           ;; free for -inject-arguments -- a big win for the user and for us
3859           ;; since we don't have to play that double-guessing game and the user           ;; since we don't have to play that double-guessing game and the user
3860           ;; gets full control (no gestapo'ish -f's, for instance).  --sj           ;; gets full control (no gestapo'ish -f's, for instance).  --sj
3861           message-qmail-inject-args))           (if (functionp message-qmail-inject-args)
3862                 (funcall message-qmail-inject-args)
3863               message-qmail-inject-args)))
3864      ;; qmail-inject doesn't say anything on it's stdout/stderr,      ;; qmail-inject doesn't say anything on it's stdout/stderr,
3865      ;; we have to look at the retval instead      ;; we have to look at the retval instead
3866      (0 nil)      (0 nil)
3867      (1   (error "qmail-inject reported permanent failure"))      (100 (error "qmail-inject reported permanent failure"))
3868      (111 (error "qmail-inject reported transient failure"))      (111 (error "qmail-inject reported transient failure"))
3869      ;; should never happen      ;; should never happen
3870      (t   (error "qmail-inject reported unknown failure"))))      (t   (error "qmail-inject reported unknown failure"))))
# Line 2533  to find out how to use this." Line 3887  to find out how to use this."
3887      ;; Pass it on to mh.      ;; Pass it on to mh.
3888      (mh-send-letter)))      (mh-send-letter)))
3889    
3890    (defun message-smtpmail-send-it ()
3891      "Send the prepared message buffer with `smtpmail-send-it'.
3892    This only differs from `smtpmail-send-it' that this command evaluates
3893    `message-send-mail-hook' just before sending a message.  It is useful
3894    if your ISP requires the POP-before-SMTP authentication.  See the Gnus
3895    manual for details."
3896      (run-hooks 'message-send-mail-hook)
3897      (smtpmail-send-it))
3898    
3899    (defun message-canlock-generate ()
3900      "Return a string that is non-trivial to guess.
3901    Do not use this for anything important, it is cryptographically weak."
3902      (require 'sha1)
3903      (let (sha1-maximum-internal-length)
3904        (sha1 (concat (message-unique-id)
3905                      (format "%x%x%x" (random) (random t) (random))
3906                      (prin1-to-string (recent-keys))
3907                      (prin1-to-string (garbage-collect))))))
3908    
3909    (defun message-canlock-password ()
3910      "The password used by message for cancel locks.
3911    This is the value of `canlock-password', if that option is non-nil.
3912    Otherwise, generate and save a value for `canlock-password' first."
3913      (unless canlock-password
3914        (customize-save-variable 'canlock-password (message-canlock-generate))
3915        (setq canlock-password-for-verify canlock-password))
3916      canlock-password)
3917    
3918    (defun message-insert-canlock ()
3919      (when message-insert-canlock
3920        (message-canlock-password)
3921        (canlock-insert-header)))
3922    
3923  (defun message-send-news (&optional arg)  (defun message-send-news (&optional arg)
3924    (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))    (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
3925           (case-fold-search nil)           (case-fold-search nil)
3926           (method (if (message-functionp message-post-method)           (method (if (functionp message-post-method)
3927                       (funcall message-post-method arg)                       (funcall message-post-method arg)
3928                     message-post-method))                     message-post-method))
3929           (group-name-charset (gnus-group-name-charset method ""))           (newsgroups-field (save-restriction
3930                                (message-narrow-to-headers-or-head)
3931                                (message-fetch-field "Newsgroups")))
3932             (followup-field (save-restriction
3933                               (message-narrow-to-headers-or-head)
3934                               (message-fetch-field "Followup-To")))
3935             ;; BUG: We really need to get the charset for each name in the
3936             ;; Newsgroups and Followup-To lines to allow crossposting
3937             ;; between group namess with incompatible character sets.
3938             ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08.
3939             (group-field-charset
3940              (gnus-group-name-charset method newsgroups-field))
3941             (followup-field-charset
3942              (gnus-group-name-charset method (or followup-field "")))
3943           (rfc2047-header-encoding-alist           (rfc2047-header-encoding-alist
3944            (if group-name-charset            (append (when group-field-charset
3945                (cons (cons "Newsgroups" group-name-charset)                      (list (cons "Newsgroups" group-field-charset)))
3946                      rfc2047-header-encoding-alist)                    (when followup-field-charset
3947              rfc2047-header-encoding-alist))                      (list (cons "Followup-To" followup-field-charset)))
3948                      rfc2047-header-encoding-alist))
3949           (messbuf (current-buffer))           (messbuf (current-buffer))
3950           (message-syntax-checks           (message-syntax-checks
3951            (if arg            (if (and arg
3952                       (listp message-syntax-checks))
3953                (cons '(existing-newsgroups . disabled)                (cons '(existing-newsgroups . disabled)
3954                      message-syntax-checks)                      message-syntax-checks)
3955              message-syntax-checks))              message-syntax-checks))
3956           (message-this-is-news t)           (message-this-is-news t)
3957           (message-posting-charset (gnus-setup-posting-charset           (message-posting-charset
3958                                     (save-restriction            (gnus-setup-posting-charset newsgroups-field))
                                      (message-narrow-to-headers-or-head)  
                                      (message-fetch-field "Newsgroups"))))  
3959           result)           result)
3960      (if (not (message-check-news-body-syntax))      (if (not (message-check-news-body-syntax))
3961          nil          nil
# Line 2563  to find out how to use this." Line 3963  to find out how to use this."
3963          (message-narrow-to-headers)          (message-narrow-to-headers)
3964          ;; Insert some headers.          ;; Insert some headers.
3965          (message-generate-headers message-required-news-headers)          (message-generate-headers message-required-news-headers)
3966            (message-insert-canlock)
3967          ;; Let the user do all of the above.          ;; Let the user do all of the above.
3968          (run-hooks 'message-header-hook))          (run-hooks 'message-header-hook))
3969        (if group-name-charset        ;; Note: This check will be disabled by the ".*" default value for
3970            (setq message-syntax-checks        ;; gnus-group-name-charset-group-alist. -- Pa 2001-10-07.
3971          (when (and group-field-charset
3972                     (listp message-syntax-checks))
3973            (setq message-syntax-checks
3974                (cons '(valid-newsgroups . disabled)                (cons '(valid-newsgroups . disabled)
3975                      message-syntax-checks)))                      message-syntax-checks)))
3976        (message-cleanup-headers)        (message-cleanup-headers)
3977        (if (not (message-check-news-syntax))        (if (not (let ((message-post-method method))
3978                     (message-check-news-syntax)))
3979            nil            nil
3980          (unwind-protect          (unwind-protect
3981              (save-excursion              (save-excursion
3982                (set-buffer tembuf)                (set-buffer tembuf)
3983                (buffer-disable-undo)                (buffer-disable-undo)
3984                (erase-buffer)                (erase-buffer)
3985                ;; Avoid copying text props.                ;; Avoid copying text props (except hard newlines).
3986                (insert (with-current-buffer messbuf                (insert
3987                          (buffer-substring-no-properties                 (with-current-buffer messbuf
3988                           (point-min) (point-max))))                   (mml-buffer-substring-no-properties-except-hard-newlines
3989                      (point-min) (point-max))))
3990                (message-encode-message-body)                (message-encode-message-body)
3991                ;; Remove some headers.                ;; Remove some headers.
3992                (save-restriction                (save-restriction
# Line 2605  to find out how to use this." Line 4011  to find out how to use this."
4011                  (backward-char 1))                  (backward-char 1))
4012                (run-hooks 'message-send-news-hook)                (run-hooks 'message-send-news-hook)
4013                (gnus-open-server method)                (gnus-open-server method)
4014                  (message "Sending news via %s..." (gnus-server-string method))
4015                (setq result (let ((mail-header-separator ""))                (setq result (let ((mail-header-separator ""))
4016                               (gnus-request-post method))))                               (gnus-request-post method))))
4017            (kill-buffer tembuf))            (kill-buffer tembuf))
# Line 2665  to find out how to use this." Line 4072  to find out how to use this."
4072           (y-or-n-p           (y-or-n-p
4073            "The control code \"cmsg\" is in the subject.  Really post? ")            "The control code \"cmsg\" is in the subject.  Really post? ")
4074         t))         t))
4075       ;; Check long header lines.
4076       (message-check 'long-header-lines
4077         (let ((start (point))
4078               (header nil)
4079               (length 0)
4080               found)
4081           (while (and (not found)
4082                       (re-search-forward "^\\([^ \t:]+\\): " nil t))
4083             (if (> (- (point) (match-beginning 0)) 998)
4084                 (setq found t
4085                       length (- (point) (match-beginning 0)))
4086               (setq header (match-string-no-properties 1)))
4087             (setq start (match-beginning 0))
4088             (forward-line 1))
4089           (if found
4090               (y-or-n-p (format "Your %s header is too long (%d).  Really post? "
4091                                 header length))
4092             t)))
4093     ;; Check for multiple identical headers.     ;; Check for multiple identical headers.
4094     (message-check 'multiple-headers     (message-check 'multiple-headers
4095       (let (found)       (let (found)
# Line 2703  to find out how to use this." Line 4128  to find out how to use this."
4128                     (zerop                     (zerop
4129                      (length                      (length
4130                       (setq to (completing-read                       (setq to (completing-read
4131                                 "Followups to: (default all groups) "                                 "Followups to (default: no Followup-To header) "
4132                                 (mapcar (lambda (g) (list g))                                 (mapcar #'list
4133                                         (cons "poster"                                         (cons "poster"
4134                                               (message-tokenize-header                                               (message-tokenize-header
4135                                                newsgroups)))))))))                                                newsgroups)))))))))
# Line 2714  to find out how to use this." Line 4139  to find out how to use this."
4139     ;; Check "Shoot me".     ;; Check "Shoot me".
4140     (message-check 'shoot     (message-check 'shoot
4141       (if (re-search-forward       (if (re-search-forward
4142            "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t)            "Message-ID.*.i-did-not-set--mail-host-address--so-tickle-me" nil t)
4143           (y-or-n-p "You appear to have a misconfigured system.  Really post? ")           (y-or-n-p "You appear to have a misconfigured system.  Really post? ")
4144         t))         t))
4145     ;; Check for Approved.     ;; Check for Approved.
# Line 2745  to find out how to use this." Line 4170  to find out how to use this."
4170                       (if followup-to                       (if followup-to
4171                           (concat newsgroups "," followup-to)                           (concat newsgroups "," followup-to)
4172                         newsgroups)))                         newsgroups)))
4173              (hashtb (and (boundp 'gnus-active-hashtb)              (post-method (if (functionp message-post-method)
4174                           gnus-active-hashtb))                               (funcall message-post-method)
4175                               message-post-method))
4176                ;; KLUDGE to handle nnvirtual groups.  Doing this right
4177                ;; would probably involve a new nnoo function.
4178                ;; -- Per Abrahamsen <abraham@dina.kvl.dk>, 2001-10-17.
4179                (method (if (and (consp post-method)
4180                                 (eq (car post-method) 'nnvirtual)
4181                                 gnus-message-group-art)
4182                            (let ((group (car (nnvirtual-find-group-art
4183                                               (car gnus-message-group-art)
4184                                               (cdr gnus-message-group-art)))))
4185                              (gnus-find-method-for-group group))
4186                          post-method))
4187                (known-groups
4188                 (mapcar (lambda (n)
4189                           (gnus-group-name-decode
4190                            (gnus-group-real-name n)
4191                            (gnus-group-name-charset method n)))
4192                         (gnus-groups-from-server method)))
4193              errors)              errors)
4194         (if (or (not hashtb)         (while groups
4195                 (not (boundp 'gnus-read-active-file))           (when (and (not (equal (car groups) "poster"))
4196                 (not gnus-read-active-file)                      (not (member (car groups) known-groups))
4197                 (eq gnus-read-active-file 'some))                      (not (member (car groups) errors)))
4198             t             (push (car groups) errors))
4199           (while groups           (pop groups))
4200             (when (and (not (boundp (intern (car groups) hashtb)))         (cond
4201                        (not (equal (car groups) "poster")))          ;; Gnus is not running.
4202               (push (car groups) errors))          ((or (not (and (boundp 'gnus-active-hashtb)
4203             (pop groups))                         gnus-active-hashtb))
4204           (if (not errors)               (not (boundp 'gnus-read-active-file)))
4205               t           t)
4206             (y-or-n-p          ;; We don't have all the group names.
4207              (format          ((and (or (not gnus-read-active-file)
4208               "Really post to %s unknown group%s: %s? "                    (eq gnus-read-active-file 'some))
4209               (if (= (length errors) 1) "this" "these")                errors)
4210               (if (= (length errors) 1) "" "s")           (y-or-n-p
4211               (mapconcat 'identity errors ", ")))))))            (format
4212               "Really use %s possibly unknown group%s: %s? "
4213               (if (= (length errors) 1) "this" "these")
4214               (if (= (length errors) 1) "" "s")
4215               (mapconcat 'identity errors ", "))))
4216            ;; There were no errors.
4217            ((not errors)
4218             t)
4219            ;; There are unknown groups.
4220            (t
4221             (y-or-n-p
4222              (format
4223               "Really post to %s unknown group%s: %s? "
4224               (if (= (length errors) 1) "this" "these")
4225               (if (= (length errors) 1) "" "s")
4226               (mapconcat 'identity errors ", ")))))))
4227       ;; Check continuation headers.
4228       (message-check 'continuation-headers
4229         (goto-char (point-min))
4230         (let ((do-posting t))
4231           (while (re-search-forward "^[^ \t\n][^:\n]*$" nil t)
4232             (if (y-or-n-p "Fix continuation lines? ")
4233                 (progn
4234                   (goto-char (match-beginning 0))
4235                   (insert " "))
4236               (unless (y-or-n-p "Send anyway? ")
4237                 (setq do-posting nil))))
4238           do-posting))
4239     ;; Check the Newsgroups & Followup-To headers for syntax errors.     ;; Check the Newsgroups & Followup-To headers for syntax errors.
4240     (message-check 'valid-newsgroups     (message-check 'valid-newsgroups
4241       (let ((case-fold-search t)       (let ((case-fold-search t)
# Line 2820  to find out how to use this." Line 4290  to find out how to use this."
4290                     "@[^\\.]*\\."                     "@[^\\.]*\\."
4291                     (setq ad (nth 1 (mail-extract-address-components                     (setq ad (nth 1 (mail-extract-address-components
4292                                      from))))) ;larsi@ifi                                      from))))) ;larsi@ifi
4293               (string-match "\\.\\." ad) ;larsi@ifi..uio               (string-match "\\.\\." ad) ;larsi@ifi..uio
4294               (string-match "@\\." ad)   ;larsi@.ifi.uio               (string-match "@\\." ad)   ;larsi@.ifi.uio
4295               (string-match "\\.$" ad)   ;larsi@ifi.uio.               (string-match "\\.$" ad)   ;larsi@ifi.uio.
4296               (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio               (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
# Line 2828  to find out how to use this." Line 4298  to find out how to use this."
4298           (message           (message
4299            "Denied posting -- the From looks strange: \"%s\"." from)            "Denied posting -- the From looks strange: \"%s\"." from)
4300           nil)           nil)
4301            ((let ((addresses (rfc822-addresses from)))
4302               (while (and addresses
4303                           (not (eq (string-to-char (car addresses)) ?\()))
4304                 (setq addresses (cdr addresses)))
4305               addresses)
4306             (message
4307              "Denied posting -- bad From address: \"%s\"." from)
4308             nil)
4309            (t t))))
4310       ;; Check the Reply-To header.
4311       (message-check 'reply-to
4312         (let* ((case-fold-search t)
4313                (reply-to (message-fetch-field "reply-to"))
4314                ad)
4315           (cond
4316            ((not reply-to)
4317             t)
4318            ((string-match "," reply-to)
4319             (y-or-n-p
4320              (format "Multiple Reply-To addresses: \"%s\". Really post? "
4321                      reply-to)))
4322            ((or (not (string-match
4323                       "@[^\\.]*\\."
4324                       (setq ad (nth 1 (mail-extract-address-components
4325                                        reply-to))))) ;larsi@ifi
4326                 (string-match "\\.\\." ad) ;larsi@ifi..uio
4327                 (string-match "@\\." ad)   ;larsi@.ifi.uio
4328                 (string-match "\\.$" ad)   ;larsi@ifi.uio.
4329                 (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
4330                 (string-match "(.*).*(.*)" reply-to)) ;(lars) (lars)
4331             (y-or-n-p
4332              (format
4333               "The Reply-To looks strange: \"%s\". Really post? "
4334               reply-to)))
4335          (t t))))))          (t t))))))
4336    
4337  (defun message-check-news-body-syntax ()  (defun message-check-news-body-syntax ()
# Line 2837  to find out how to use this." Line 4341  to find out how to use this."
4341       (goto-char (point-min))       (goto-char (point-min))
4342       (re-search-forward       (re-search-forward
4343        (concat "^" (regexp-quote mail-header-separator) "$"))        (concat "^" (regexp-quote mail-header-separator) "$"))
4344         (forward-line 1)
4345       (while (and       (while (and
4346               (progn               (or (looking-at
4347                 (end-of-line)                    "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)")
4348                 (< (current-column) 80))                   (let ((p (point)))
4349                       (end-of-line)
4350                       (< (- (point) p) 80)))
4351               (zerop (forward-line 1))))               (zerop (forward-line 1))))
4352       (or (bolp)       (or (bolp)
4353           (eobp)           (eobp)
# Line 2857  to find out how to use this." Line 4364  to find out how to use this."
4364         (re-search-backward message-signature-separator nil t)         (re-search-backward message-signature-separator nil t)
4365         (beginning-of-line)         (beginning-of-line)
4366         (or (re-search-backward "[^ \n\t]" b t)         (or (re-search-backward "[^ \n\t]" b t)
4367             (y-or-n-p "Empty article.  Really post? "))))             (if (message-gnksa-enable-p 'empty-article)
4368                   (y-or-n-p "Empty article.  Really post? ")
4369                 (message "Denied posting -- Empty article.")
4370                 nil))))
4371     ;; Check for control characters.     ;; Check for control characters.
4372     (message-check 'control-chars     (message-check 'control-chars
4373       (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t)       (if (re-search-forward "[\000-\007\013\015-\032\034-\037\200-\237]" nil t)
# Line 2876  to find out how to use this." Line 4386  to find out how to use this."
4386       (or       (or
4387        (not message-checksum)        (not message-checksum)
4388        (not (eq (message-checksum) message-checksum))        (not (eq (message-checksum) message-checksum))
4389        (y-or-n-p        (if (message-gnksa-enable-p 'quoted-text-only)
4390         "It looks like no new text has been added.  Really post? ")))            (y-or-n-p
4391               "It looks like no new text has been added.  Really post? ")
4392            (message "Denied posting -- no new text has been added.")
4393            nil)))
4394     ;; Check the length of the signature.     ;; Check the length of the signature.
4395     (message-check 'signature     (message-check 'signature
4396       (goto-char (point-max))       (goto-char (point-max))
# Line 2891  to find out how to use this." Line 4404  to find out how to use this."
4404     (message-check 'quoting-style     (message-check 'quoting-style
4405       (goto-char (point-max))       (goto-char (point-max))
4406       (let ((no-problem t))       (let ((no-problem t))
4407         (when (search-backward-regexp "^>[^\n]*\n>" nil t)         (when (search-backward-regexp "^>[^\n]*\n" nil t)
4408           (setq no-problem nil)           (setq no-problem (search-forward-regexp "^[ \t]*[^>\n]" nil t)))
          (while (not (eobp))  
            (when (and (not (eolp)) (looking-at "[^> \t]"))  
              (setq no-problem t))  
            (forward-line)))  
4409         (if no-problem         (if no-problem
4410             t             t
4411           (y-or-n-p "Your text should follow quoted text.  Really post? "))))))           (if (message-gnksa-enable-p 'quoted-text-only)
4412                 (y-or-n-p "Your text should follow quoted text.  Really post? ")
4413               ;; Ensure that
4414               (goto-char (point-min))
4415               (re-search-forward
4416                (concat "^" (regexp-quote mail-header-separator) "$"))
4417               (if (search-forward-regexp "^[ \t]*[^>\n]" nil t)
4418                   (y-or-n-p "Your text should follow quoted text.  Really post? ")
4419                 (message "Denied posting -- only quoted text.")
4420                 nil)))))))
4421    
4422  (defun message-checksum ()  (defun message-checksum ()
4423    "Return a \"checksum\" for the current buffer."    "Return a \"checksum\" for the current buffer."
# Line 2910  to find out how to use this." Line 4428  to find out how to use this."
4428         (concat "^" (regexp-quote mail-header-separator) "$"))         (concat "^" (regexp-quote mail-header-separator) "$"))
4429        (while (not (eobp))        (while (not (eobp))
4430          (when (not (looking-at "[ \t\n]"))          (when (not (looking-at "[ \t\n]"))
4431            (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)            (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
4432                              (char-after))))                              (char-after))))
4433          (forward-char 1)))          (forward-char 1)))
4434      sum))      sum))
4435    
# Line 2919  to find out how to use this." Line 4437  to find out how to use this."
4437    "Process Fcc headers in the current buffer."    "Process Fcc headers in the current buffer."
4438    (let ((case-fold-search t)    (let ((case-fold-search t)
4439          (buf (current-buffer))          (buf (current-buffer))
4440          list file)          list file
4441            (mml-externalize-attachments message-fcc-externalize-attachments))
4442      (save-excursion      (save-excursion
       (set-buffer (get-buffer-create " *message temp*"))  
       (erase-buffer)  
       (insert-buffer-substring buf)  
       (save-restriction  
         (message-narrow-to-headers)  
         (while (setq file (message-fetch-field "fcc"))  
           (push file list)  
           (message-remove-header "fcc" nil t)))  
       (message-encode-message-body)  
4443        (save-restriction        (save-restriction
4444          (message-narrow-to-headers)          (message-narrow-to-headers)
4445          (let ((mail-parse-charset message-default-charset)          (setq file (message-fetch-field "fcc" t)))
4446                (rfc2047-header-encoding-alist        (when file
4447                 (cons '("Newsgroups" . default)          (set-buffer (get-buffer-create " *message temp*"))
4448                       rfc2047-header-encoding-alist)))          (erase-buffer)
4449            (mail-encode-encoded-word-buffer)))          (insert-buffer-substring buf)
4450        (goto-char (point-min))          (message-encode-message-body)
4451        (when (re-search-forward          (save-restriction
4452               (concat "^" (regexp-quote mail-header-separator) "$")            (message-narrow-to-headers)
4453               nil t)            (while (setq file (message-fetch-field "fcc" t))
4454          (replace-match "" t t ))              (push file list)
4455        ;; Process FCC operations.              (message-remove-header "fcc" nil t))
4456        (while list            (let ((mail-parse-charset message-default-charset)
4457          (setq file (pop list))                  (rfc2047-header-encoding-alist
4458          (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)                   (cons '("Newsgroups" . default)
4459              ;; Pipe the article to the program in question.                         rfc2047-header-encoding-alist)))
4460              (call-process-region (point-min) (point-max) shell-file-name              (mail-encode-encoded-word-buffer)))
4461                                   nil nil nil shell-command-switch          (goto-char (point-min))
4462                                   (match-string 1 file))          (when (re-search-forward
4463            ;; Save the article.                 (concat "^" (regexp-quote mail-header-separator) "$")
4464            (setq file (expand-file-name file))                 nil t)
4465            (unless (file-exists-p (file-name-directory file))            (replace-match "" t t ))
4466              (make-directory (file-name-directory file) t))          ;; Process FCC operations.
4467            (if (and message-fcc-handler-function          (while list
4468                     (not (eq message-fcc-handler-function 'rmail-output)))            (setq file (pop list))
4469                (funcall message-fcc-handler-function file)            (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
4470              (if (and (file-readable-p file) (mail-file-babyl-p file))                ;; Pipe the article to the program in question.
4471                  (rmail-output file 1 nil t)                (call-process-region (point-min) (point-max) shell-file-name
4472                (let ((mail-use-rfc822 t))                                     nil nil nil shell-command-switch
4473                  (rmail-output file 1 t t))))))                                     (match-string 1 file))
4474        (kill-buffer (current-buffer)))))              ;; Save the article.
4475                (setq file (expand-file-name file))
4476                (unless (file-exists-p (file-name-directory file))
4477                  (make-directory (file-name-directory file) t))
4478                (if (and message-fcc-handler-function
4479                         (not (eq message-fcc-handler-function 'rmail-output)))
4480                    (funcall message-fcc-handler-function file)
4481                  (if (and (file-readable-p file) (mail-file-babyl-p file))
4482                      (rmail-output file 1 nil t)
4483                    (let ((mail-use-rfc822 t))
4484                      (rmail-output file 1 t t))))))
4485            (kill-buffer (current-buffer))))))
4486    
4487  (defun message-output (filename)  (defun message-output (filename)
4488    "Append this article to Unix/babyl mail file FILENAME."    "Append this article to Unix/babyl mail file FILENAME."
# Line 2993  to find out how to use this." Line 4514  to find out how to use this."
4514             (point)))             (point)))
4515          (goto-char (point-min))          (goto-char (point-min))
4516          (while (re-search-forward "\n[ \t]+" nil t)          (while (re-search-forward "\n[ \t]+" nil t)
4517            (replace-match " " t t))      ;No line breaks (too confusing)            (replace-match " " t t))     ;No line breaks (too confusing)
4518          (goto-char (point-min))          (goto-char (point-min))
4519          (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)          (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
4520            (replace-match "," t t))            (replace-match "," t t))
# Line 3012  If NOW, use that time instead." Line 4533  If NOW, use that time instead."
4533        (setq sign "-")        (setq sign "-")
4534        (setq zone (- zone)))        (setq zone (- zone)))
4535      (concat      (concat
4536         ;; The day name of the %a spec is locale-specific.  Pfff.
4537         (format "%s, " (capitalize (car (rassoc (nth 6 (decode-time now))
4538                                                 parse-time-weekdays))))
4539       (format-time-string "%d" now)       (format-time-string "%d" now)
4540       ;; The month name of the %b spec is locale-specific.  Pfff.       ;; The month name of the %b spec is locale-specific.  Pfff.
4541       (format " %s "       (format " %s "
# Line 3063  If NOW, use that time instead." Line 4587  If NOW, use that time instead."
4587               (aset user (match-beginning 0) ?_))               (aset user (match-beginning 0) ?_))
4588             user)             user)
4589         (message-number-base36 (user-uid) -1))         (message-number-base36 (user-uid) -1))
4590       (message-number-base36 (+ (car   tm)       (message-number-base36 (+ (car tm)
4591                                 (lsh (% message-unique-id-char 25) 16)) 4)                                 (lsh (% message-unique-id-char 25) 16)) 4)
4592       (message-number-base36 (+ (nth 1 tm)       (message-number-base36 (+ (nth 1 tm)
4593                                 (lsh (/ message-unique-id-char 25) 16)) 4)                                 (lsh (/ message-unique-id-char 25) 16)) 4)
4594       ;; Append the newsreader name, because while the generated       ;; Append a given name, because while the generated ID is unique
4595       ;; ID is unique to this newsreader, other newsreaders might       ;; to this newsreader, other newsreaders might otherwise generate
4596       ;; otherwise generate the same ID via another algorithm.       ;; the same ID via another algorithm.
4597       ".fsf")))       ".fsf")))
4598    
4599  (defun message-number-base36 (num len)  (defun message-number-base36 (num len)
# Line 3085  If NOW, use that time instead." Line 4609  If NOW, use that time instead."
4609    "Make an Organization header."    "Make an Organization header."
4610    (let* ((organization    (let* ((organization
4611            (when message-user-organization            (when message-user-organization
4612              (if (message-functionp message-user-organization)              (if (functionp message-user-organization)
4613                  (funcall message-user-organization)                  (funcall message-user-organization)
4614                message-user-organization))))                message-user-organization))))
4615      (save-excursion      (with-temp-buffer
4616        (message-set-work-buffer)        (mm-enable-multibyte)
4617        (cond ((stringp organization)        (cond ((stringp organization)
4618               (insert organization))               (insert organization))
4619              ((and (eq t organization)              ((and (eq t organization)
# Line 3107  If NOW, use that time instead." Line 4631  If NOW, use that time instead."
4631    (save-excursion    (save-excursion
4632      (save-restriction      (save-restriction
4633        (widen)        (widen)
4634        (goto-char (point-min))        (message-goto-body)
       (re-search-forward  
        (concat "^" (regexp-quote mail-header-separator) "$"))  
       (forward-line 1)  
4635        (int-to-string (count-lines (point) (point-max))))))        (int-to-string (count-lines (point) (point-max))))))
4636    
4637    (defun message-make-references ()
4638      "Return the References header for this message."
4639      (when message-reply-headers
4640        (let ((message-id (mail-header-message-id message-reply-headers))
4641              (references (mail-header-references message-reply-headers))
4642              new-references)
4643          (if (or references message-id)
4644              (concat (or references "") (and references " ")
4645                      (or message-id ""))
4646            nil))))
4647    
4648  (defun message-make-in-reply-to ()  (defun message-make-in-reply-to ()
4649    "Return the In-Reply-To header for this message."    "Return the In-Reply-To header for this message."
4650    (when message-reply-headers    (when message-reply-headers
4651      (mail-header-message-id message-reply-headers)))      (let ((from (mail-header-from message-reply-headers))
4652              (date (mail-header-date message-reply-headers))
4653              (msg-id (mail-header-message-id message-reply-headers)))
4654          (when from
4655            (let ((name (mail-extract-address-components from)))
4656              (concat msg-id (if msg-id " (")
4657                      (or (car name)
4658                          (nth 1 name))
4659                      "'s message of \""
4660                      (if (or (not date) (string= date ""))
4661                          "(unknown date)" date)
4662                      "\"" (if msg-id ")")))))))
4663    
4664  (defun message-make-distribution ()  (defun message-make-distribution ()
4665    "Make a Distribution header."    "Make a Distribution header."
4666    (let ((orig-distribution (message-fetch-reply-field "distribution")))    (let ((orig-distribution (message-fetch-reply-field "distribution")))
4667      (cond ((message-functionp message-distribution-function)      (cond ((functionp message-distribution-function)
4668             (funcall message-distribution-function))             (funcall message-distribution-function))
4669            (t orig-distribution))))            (t orig-distribution))))
4670    
# Line 3154  If NOW, use that time instead." Line 4697  If NOW, use that time instead."
4697                (user-full-name))))                (user-full-name))))
4698      (when (string= fullname "&")      (when (string= fullname "&")
4699        (setq fullname (user-login-name)))        (setq fullname (user-login-name)))
4700      (save-excursion      (with-temp-buffer
4701        (message-set-work-buffer)        (mm-enable-multibyte)
4702        (cond        (cond
4703         ((or (null style)         ((or (null style)
4704              (equal fullname ""))              (equal fullname ""))
# Line 3172  If NOW, use that time instead." Line 4715  If NOW, use that time instead."
4715                         (string-match "[\\()]" tmp)))))                         (string-match "[\\()]" tmp)))))
4716          (insert fullname)          (insert fullname)
4717          (goto-char (point-min))          (goto-char (point-min))
4718          ;; Look for a character that cannot appear unquoted          ;; Look for a character that cannot appear unquoted
4719          ;; according to RFC 822.          ;; according to RFC 822.
4720          (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)          (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
4721            ;; Quote fullname, escaping specials.            ;; Quote fullname, escaping specials.
4722            (goto-char (point-min))            (goto-char (point-min))
4723            (insert "\"")            (insert "\"")
4724            (while (re-search-forward "[\"\\]" nil 1)            (while (re-search-forward "[\"\\]" nil 1)
4725              (replace-match "\\\\\\&" t))              (replace-match "\\\\\\&" t))
4726            (insert "\""))            (insert "\""))
4727          (insert " <" login ">"))          (insert " <" login ">"))
4728         (t                               ; 'parens or default         (t                               ; 'parens or default
4729          (insert login " (")          (insert login " (")
# Line 3216  give as trustworthy answer as possible." Line 4759  give as trustworthy answer as possible."
4759    
4760  (defun message-user-mail-address ()  (defun message-user-mail-address ()
4761    "Return the pertinent part of `user-mail-address'."    "Return the pertinent part of `user-mail-address'."
4762    (when user-mail-address    (when (and user-mail-address
4763                 (string-match "@.*\\." user-mail-address))
4764      (if (string-match " " user-mail-address)      (if (string-match " " user-mail-address)
4765          (nth 1 (mail-extract-address-components user-mail-address))          (nth 1 (mail-extract-address-components user-mail-address))
4766        user-mail-address)))        user-mail-address)))
4767    
4768    (defun message-sendmail-envelope-from ()
4769      "Return the envelope from."
4770      (cond ((eq message-sendmail-envelope-from 'header)
4771             (nth 1 (mail-extract-address-components
4772                     (message-fetch-field "from"))))
4773            ((stringp message-sendmail-envelope-from)
4774             message-sendmail-envelope-from)
4775            (t
4776             (message-make-address))))
4777    
4778  (defun message-make-fqdn ()  (defun message-make-fqdn ()
4779    "Return user's fully qualified domain name."    "Return user's fully qualified domain name."
4780    (let ((system-name (system-name))    (let* ((system-name (system-name))
4781          (user-mail (message-user-mail-address)))           (user-mail (message-user-mail-address))
4782             (user-domain
4783              (if (and user-mail
4784                       (string-match "@\\(.*\\)\\'" user-mail))
4785                  (match-string 1 user-mail)))
4786             (case-fold-search t))
4787      (cond      (cond
4788       ((string-match "[^.]\\.[^.]" system-name)       ((and message-user-fqdn
4789               (stringp message-user-fqdn)
4790               (string-match message-valid-fqdn-regexp message-user-fqdn)
4791               (not (string-match message-bogus-system-names message-user-fqdn)))
4792          message-user-fqdn)
4793         ;; `message-user-fqdn' seems to be valid
4794         ((and (string-match message-valid-fqdn-regexp system-name)
4795               (not (string-match message-bogus-system-names system-name)))
4796        ;; `system-name' returned the right result.        ;; `system-name' returned the right result.
4797        system-name)        system-name)
4798       ;; Try `mail-host-address'.       ;; Try `mail-host-address'.
4799       ((and (boundp 'mail-host-address)       ((and (boundp 'mail-host-address)
4800             (stringp mail-host-address)             (stringp mail-host-address)
4801             (string-match "\\." mail-host-address))             (string-match message-valid-fqdn-regexp mail-host-address)
4802               (not (string-match message-bogus-system-names mail-host-address)))
4803        mail-host-address)        mail-host-address)
4804       ;; We try `user-mail-address' as a backup.       ;; We try `user-mail-address' as a backup.
4805       ((and user-mail       ((and user-domain
4806             (string-match "\\." user-mail)             (stringp user-domain)
4807             (string-match "@\\(.*\\)\\'" user-mail))             (string-match message-valid-fqdn-regexp user-domain)
4808        (match-string 1 user-mail))             (not (string-match message-bogus-system-names user-domain)))
4809          user-domain)
4810       ;; Default to this bogus thing.       ;; Default to this bogus thing.
4811       (t       (t
4812        (concat system-name ".i-did-not-set--mail-host-address--so-shoot-me")))))        (concat system-name
4813                  ".i-did-not-set--mail-host-address--so-tickle-me")))))
4814    
4815  (defun message-make-host-name ()  (defun message-make-host-name ()
4816    "Return the name of the host."    "Return the name of the host."
# Line 3254  give as trustworthy answer as possible." Line 4823  give as trustworthy answer as possible."
4823    (or mail-host-address    (or mail-host-address
4824        (message-make-fqdn)))        (message-make-fqdn)))
4825    
4826    (defun message-to-list-only ()
4827      "Send a message to the list only.
4828    Remove all addresses but the list address from To and Cc headers."
4829      (interactive)
4830      (let ((listaddr (message-make-mail-followup-to t)))
4831        (when listaddr
4832          (save-excursion
4833            (message-remove-header "to")
4834            (message-remove-header "cc")
4835            (message-position-on-field "To" "X-Draft-From")
4836            (insert listaddr)))))
4837    
4838    (defun message-make-mail-followup-to (&optional only-show-subscribed)
4839      "Return the Mail-Followup-To header.
4840    If passed the optional argument ONLY-SHOW-SUBSCRIBED only return the
4841    subscribed address (and not the additional To and Cc header contents)."
4842      (let* ((case-fold-search t)
4843             (to (message-fetch-field "To"))
4844             (cc (message-fetch-field "cc"))
4845             (msg-recipients (concat to (and to cc ", ") cc))
4846             (recipients
4847              (mapcar 'mail-strip-quoted-names
4848                      (message-tokenize-header msg-recipients)))
4849             (file-regexps
4850              (if message-subscribed-address-file
4851                  (let (begin end item re)
4852                    (save-excursion
4853                      (with-temp-buffer
4854                        (insert-file-contents message-subscribed-address-file)
4855                        (while (not (eobp))
4856                          (setq begin (point))
4857                          (forward-line 1)
4858                          (setq end (point))
4859                          (if (bolp) (setq end (1- end)))
4860                          (setq item (regexp-quote (buffer-substring begin end)))
4861                          (if re (setq re (concat re "\\|" item))
4862                            (setq re (concat "\\`\\(" item))))
4863                        (and re (list (concat re "\\)\\'"))))))))
4864             (mft-regexps (apply 'append message-subscribed-regexps
4865                                 (mapcar 'regexp-quote
4866                                         message-subscribed-addresses)
4867                                 file-regexps
4868                                 (mapcar 'funcall
4869                                         message-subscribed-address-functions))))
4870        (save-match-data
4871          (let ((subscribed-lists nil)
4872                (list
4873                 (loop for recipient in recipients
4874                   when (loop for regexp in mft-regexps
4875                          when (string-match regexp recipient) return t)
4876                   return recipient)))
4877            (when list
4878              (if only-show-subscribed
4879                  list
4880                msg-recipients))))))
4881    
4882    (defun message-idna-to-ascii-rhs-1 (header)
4883      "Interactively potentially IDNA encode domain names in HEADER."
4884      (let ((field (message-fetch-field header))
4885            rhs ace  address)
4886        (when field
4887          (dolist (address (mail-header-parse-addresses field))
4888            (setq address (car address)
4889                  rhs (downcase (or (cadr (split-string address "@")) ""))
4890                  ace (downcase (idna-to-ascii rhs)))
4891            (when (and (not (equal rhs ace))
4892                       (or (not (eq message-use-idna 'ask))
4893                           (y-or-n-p (format "Replace %s with %s? " rhs ace))))
4894              (goto-char (point-min))
4895              (while (re-search-forward (concat "^" header ":") nil t)
4896                (message-narrow-to-field)
4897                (while (search-forward (concat "@" rhs) nil t)
4898                  (replace-match (concat "@" ace) t t))
4899                (goto-char (point-max))
4900                (widen)))))))
4901    
4902    (defun message-idna-to-ascii-rhs ()
4903      "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers.
4904    See `message-idna-encode'."
4905      (interactive)
4906      (when message-use-idna
4907        (save-excursion
4908          (save-restriction
4909            (message-narrow-to-head)
4910            (message-idna-to-ascii-rhs-1 "From")
4911            (message-idna-to-ascii-rhs-1 "To")
4912            (message-idna-to-ascii-rhs-1 "Cc")))))
4913    
4914  (defun message-generate-headers (headers)  (defun message-generate-headers (headers)
4915    "Prepare article HEADERS.    "Prepare article HEADERS.
4916  Headers already prepared in the buffer are not modified."  Headers already prepared in the buffer are not modified."
4917      (setq headers (append headers message-required-headers))
4918    (save-restriction    (save-restriction
4919      (message-narrow-to-headers)      (message-narrow-to-headers)
4920      (let* ((Date (message-make-date))      (let* ((Date (message-make-date))
# Line 3267  Headers already prepared in the buffer a Line 4925  Headers already prepared in the buffer a
4925             (Subject nil)             (Subject nil)
4926             (Newsgroups nil)             (Newsgroups nil)
4927             (In-Reply-To (message-make-in-reply-to))             (In-Reply-To (message-make-in-reply-to))
4928               (References (message-make-references))
4929             (To nil)             (To nil)
4930             (Distribution (message-make-distribution))             (Distribution (message-make-distribution))
4931             (Lines (message-make-lines))             (Lines (message-make-lines))
4932             (User-Agent message-newsreader)             (User-Agent message-newsreader)
4933             (Expires (message-make-expires))             (Expires (message-make-expires))
4934             (case-fold-search t)             (case-fold-search t)
4935             header value elem)             (optionalp nil)
4936               header value elem header-string)
4937        ;; First we remove any old generated headers.        ;; First we remove any old generated headers.
4938        (let ((headers message-deletable-headers))        (let ((headers message-deletable-headers))
4939          (unless (buffer-modified-p)          (unless (buffer-modified-p)
# Line 3294  Headers already prepared in the buffer a Line 4954  Headers already prepared in the buffer a
4954          (setq elem (pop headers))          (setq elem (pop headers))
4955          (if (consp elem)          (if (consp elem)
4956              (if (eq (car elem) 'optional)              (if (eq (car elem) 'optional)
4957                  (setq header (cdr elem))                  (setq header (cdr elem)
4958                          optionalp t)
4959                (setq header (car elem)))                (setq header (car elem)))
4960            (setq header elem))            (setq header elem))
4961            (setq header-string  (if (stringp header)
4962                                     header
4963                                   (symbol-name header)))
4964          (when (or (not (re-search-forward          (when (or (not (re-search-forward
4965                          (concat "^"                          (concat "^"
4966                                  (regexp-quote                                  (regexp-quote (downcase header-string))
                                  (downcase  
                                   (if (stringp header)  
                                       header  
                                     (symbol-name header))))  
4967                                  ":")                                  ":")
4968                          nil t))                          nil t))
4969                    (progn                    (progn
4970                      ;; The header was found.  We insert a space after the                      ;; The header was found.  We insert a space after the
4971                      ;; colon, if there is none.                      ;; colon, if there is none.
4972                      (if (/= (char-after) ? ) (insert " ") (forward-char 1))                      (if (/= (char-after) ? ) (insert " ") (forward-char 1))
4973                      ;; Find out whether the header is empty...                      ;; Find out whether the header is empty.
4974                      (looking-at "[ \t]*\n[^ \t]")))                      (looking-at "[ \t]*\n[^ \t]")))
4975            ;; So we find out what value we should insert.            ;; So we find out what value we should insert.
4976            (setq value            (setq value
4977                  (cond                  (cond
4978                   ((and (consp elem) (eq (car elem) 'optional))                   ((and (consp elem)
4979                           (eq (car elem) 'optional)
4980                           (not (member header-string message-inserted-headers)))
4981                    ;; This is an optional header.  If the cdr of this                    ;; This is an optional header.  If the cdr of this
4982                    ;; is something that is nil, then we do not insert                    ;; is something that is nil, then we do not insert
4983                    ;; this header.                    ;; this header.
4984                    (setq header (cdr elem))                    (setq header (cdr elem))
4985                    (or (and (fboundp (cdr elem)) (funcall (cdr elem)))                    (or (and (functionp (cdr elem))
4986                        (and (boundp (cdr elem)) (symbol-value (cdr elem)))))                             (funcall (cdr elem)))
4987                          (and (boundp (cdr elem))
4988                               (symbol-value (cdr elem)))))
4989                   ((consp elem)                   ((consp elem)
4990                    ;; The element is a cons.  Either the cdr is a                    ;; The element is a cons.  Either the cdr is a
4991                    ;; string to be inserted verbatim, or it is a                    ;; string to be inserted verbatim, or it is a
4992                    ;; function, and we insert the value returned from                    ;; function, and we insert the value returned from
4993                    ;; this function.                    ;; this function.
4994                    (or (and (stringp (cdr elem)) (cdr elem))                    (or (and (stringp (cdr elem))
4995                        (and (fboundp (cdr elem)) (funcall (cdr elem)))))                             (cdr elem))
4996                   ((and (boundp header) (symbol-value header))                        (and (functionp (cdr elem))
4997                               (funcall (cdr elem)))))
4998                     ((and (boundp header)
4999                           (symbol-value header))
5000                    ;; The element is a symbol.  We insert the value                    ;; The element is a symbol.  We insert the value
5001                    ;; of this symbol, if any.                    ;; of this symbol, if any.
5002                    (symbol-value header))                    (symbol-value header))
# Line 3346  Headers already prepared in the buffer a Line 5013  Headers already prepared in the buffer a
5013                    (progn                    (progn
5014                      ;; This header didn't exist, so we insert it.                      ;; This header didn't exist, so we insert it.
5015                      (goto-char (point-max))                      (goto-char (point-max))
5016                      (insert (if (stringp header) header (symbol-name header))                      (let ((formatter
5017                              ": " value "\n")                             (cdr (assq header message-header-format-alist))))
5018                      (forward-line -1))                        (if formatter
5019                              (funcall formatter header value)
5020                            (insert header-string ": " value))
5021                          ;; We check whether the value was ended by a
5022                          ;; newline.  If now, we insert one.
5023                          (unless (bolp)
5024                            (insert "\n"))
5025                          (forward-line -1)))
5026                  ;; The value of this header was empty, so we clear                  ;; The value of this header was empty, so we clear
5027                  ;; totally and insert the new value.                  ;; totally and insert the new value.
5028                  (delete-region (point) (gnus-point-at-eol))                  (delete-region (point) (gnus-point-at-eol))
5029                  (insert value))                  ;; If the header is optional, and the header was
5030                    ;; empty, we con't insert it anyway.
5031                    (unless optionalp
5032                      (push header-string message-inserted-headers)
5033                      (insert value)))
5034                ;; Add the deletable property to the headers that require it.                ;; Add the deletable property to the headers that require it.
5035                (and (memq header message-deletable-headers)                (and (memq header message-deletable-headers)
5036                     (progn (beginning-of-line) (looking-at "[^:]+: "))                     (progn (beginning-of-line) (looking-at "[^:]+: "))
# Line 3383  Headers already prepared in the buffer a Line 5061  Headers already prepared in the buffer a
5061              (beginning-of-line))              (beginning-of-line))
5062            (when (or (message-news-p)            (when (or (message-news-p)
5063                      (string-match "@.+\\.." secure-sender))                      (string-match "@.+\\.." secure-sender))
5064              (insert "Sender: " secure-sender "\n")))))))              (insert "Sender: " secure-sender "\n"))))
5065          ;; Check for IDNA
5066          (message-idna-to-ascii-rhs))))
5067    
5068  (defun message-insert-courtesy-copy ()  (defun message-insert-courtesy-copy ()
5069    "Insert a courtesy message in mail copies of combined messages."    "Insert a courtesy message in mail copies of combined messages."
# Line 3436  Headers already prepared in the buffer a Line 5116  Headers already prepared in the buffer a
5116      (widen)      (widen)
5117      (forward-line 1)))      (forward-line 1)))
5118    
5119    (defun message-split-line ()
5120      "Split current line, moving portion beyond point vertically down.
5121    If the current line has `message-yank-prefix', insert it on the new line."
5122      (interactive "*")
5123      (condition-case nil
5124          (split-line message-yank-prefix) ;; Emacs 21.3.50+ supports arg.
5125        (error
5126         (split-line))))
5127        
5128  (defun message-fill-header (header value)  (defun message-fill-header (header value)
5129    (let ((begin (point))    (let ((begin (point))
5130          (fill-column 78)          (fill-column 78)
# Line 3463  Headers already prepared in the buffer a Line 5152  Headers already prepared in the buffer a
5152            (nthcdr (+ (- cut 2) surplus 1) list)))            (nthcdr (+ (- cut 2) surplus 1) list)))
5153    
5154  (defun message-shorten-references (header references)  (defun message-shorten-references (header references)
5155    "Trim REFERENCES to be less than 31 Message-ID long, and fold them.    "Trim REFERENCES to be 21 Message-ID long or less, and fold them.
5156  If folding is disallowed, also check that the REFERENCES are less  If folding is disallowed, also check that the REFERENCES are less
5157  than 988 characters long, and if they are not, trim them until they are."  than 988 characters long, and if they are not, trim them until they are."
5158    (let ((maxcount 31)    (let ((maxcount 21)
5159          (count 0)          (count 0)
5160          (cut 6)          (cut 2)
5161          refs)          refs)
5162      (with-temp-buffer      (with-temp-buffer
5163        (insert references)        (insert references)
# Line 3534  than 988 characters long, and if they ar Line 5223  than 988 characters long, and if they ar
5223        (forward-line 2)))        (forward-line 2)))
5224     (sit-for 0)))     (sit-for 0)))
5225    
5226    (defcustom message-beginning-of-line t
5227      "Whether \\<message-mode-map>\\[message-beginning-of-line]\
5228     goes to beginning of header values."
5229      :group 'message-buffers
5230      :link '(custom-manual "(message)Movement")
5231      :type 'boolean)
5232    
5233    (defun message-beginning-of-line (&optional n)
5234      "Move point to beginning of header value or to beginning of line.
5235    The prefix argument N is passed directly to `beginning-of-line'.
5236    
5237    This command is identical to `beginning-of-line' if point is
5238    outside the message header or if the option `message-beginning-of-line'
5239    is nil.
5240    
5241    If point is in the message header and on a (non-continued) header
5242    line, move point to the beginning of the header value.  If point
5243    is already there, move point to beginning of line.  Therefore,
5244    repeated calls will toggle point between beginning of field and
5245    beginning of line."
5246      (interactive "p")
5247      (let ((zrs 'zmacs-region-stays))
5248        (when (and (interactive-p) (boundp zrs))
5249          (set zrs t)))
5250      (if (and message-beginning-of-line
5251               (message-point-in-header-p))
5252          (let* ((here (point))
5253                 (bol (progn (beginning-of-line n) (point)))
5254                 (eol (gnus-point-at-eol))
5255                 (eoh (re-search-forward ": *" eol t)))
5256            (if (or (not eoh) (equal here eoh))
5257                (goto-char bol)
5258              (goto-char eoh)))
5259        (beginning-of-line n)))
5260    
5261  (defun message-buffer-name (type &optional to group)  (defun message-buffer-name (type &optional to group)
5262    "Return a new (unique) buffer name based on TYPE and TO."    "Return a new (unique) buffer name based on TYPE and TO."
5263    (cond    (cond
# Line 3550  than 988 characters long, and if they ar Line 5274  than 988 characters long, and if they ar
5274               "*")))               "*")))
5275     ;; Check whether `message-generate-new-buffers' is a function,     ;; Check whether `message-generate-new-buffers' is a function,
5276     ;; and if so, call it.     ;; and if so, call it.
5277     ((message-functionp message-generate-new-buffers)     ((functionp message-generate-new-buffers)
5278      (funcall message-generate-new-buffers type to group))      (funcall message-generate-new-buffers type to group))
5279     ((eq message-generate-new-buffers 'unsent)     ((eq message-generate-new-buffers 'unsent)
5280      (generate-new-buffer-name      (generate-new-buffer-name
# Line 3587  than 988 characters long, and if they ar Line 5311  than 988 characters long, and if they ar
5311    ;; list of buffers.    ;; list of buffers.
5312    (setq message-buffer-list (delq (current-buffer) message-buffer-list))    (setq message-buffer-list (delq (current-buffer) message-buffer-list))
5313    (while (and message-max-buffers    (while (and message-max-buffers
5314                message-buffer-list                message-buffer-list
5315                (>= (length message-buffer-list) message-max-buffers))                (>= (length message-buffer-list) message-max-buffers))
5316      ;; Kill the oldest buffer -- unless it has been changed.      ;; Kill the oldest buffer -- unless it has been changed.
5317      (let ((buffer (pop message-buffer-list)))      (let ((buffer (pop message-buffer-list)))
# Line 3597  than 988 characters long, and if they ar Line 5321  than 988 characters long, and if they ar
5321    ;; Rename the buffer.    ;; Rename the buffer.
5322    (if message-send-rename-function    (if message-send-rename-function
5323        (funcall message-send-rename-function)        (funcall message-send-rename-function)
5324      (when (string-match "\\`\\*\\(unsent \\)?" (buffer-name))      ;; Note: mail-abbrevs of XEmacs renames buffer name behind Gnus.
5325        (rename-buffer      (when (string-match
5326         (concat "*sent " (substring (buffer-name) (match-end 0))) t)))             "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*\\|\\`mail to "
5327               (buffer-name))
5328          (let ((name (match-string 2 (buffer-name)))
5329                to group)
5330            (if (not (or (null name)
5331                         (string-equal name "mail")
5332                         (string-equal name "posting")))
5333                (setq name (concat "*sent " name "*"))
5334              (message-narrow-to-headers)
5335              (setq to (message-fetch-field "to"))
5336              (setq group (message-fetch-field "newsgroups"))
5337              (widen)
5338              (setq name
5339                    (cond
5340                     (to (concat "*sent mail to "
5341                                 (or (car (mail-extract-address-components to))
5342                                     to) "*"))
5343                     ((and group (not (string= group "")))
5344                      (concat "*sent posting on " group "*"))
5345                     (t "*sent mail*"))))
5346            (unless (string-equal name (buffer-name))
5347              (rename-buffer name t)))))
5348    ;; Push the current buffer onto the list.    ;; Push the current buffer onto the list.
5349    (when message-max-buffers    (when message-max-buffers
5350      (setq message-buffer-list      (setq message-buffer-list
# Line 3639  than 988 characters long, and if they ar Line 5384  than 988 characters long, and if they ar
5384                                headers)                                headers)
5385                        nil switch-function yank-action actions)))))                        nil switch-function yank-action actions)))))
5386    
5387  (eval-when-compile (defvar mc-modes-alist))  (defun message-headers-to-generate (headers included-headers excluded-headers)
5388      "Return a list that includes all headers from HEADERS.
5389    If INCLUDED-HEADERS is a list, just include those headers.  If if is
5390    t, include all headers.  In any case, headers from EXCLUDED-HEADERS
5391    are not included."
5392      (let ((result nil)
5393            header-name)
5394        (dolist (header headers)
5395          (setq header-name (cond
5396                             ((and (consp header)
5397                                   (eq (car header) 'optional))
5398                              ;; On the form (optional . Header)
5399                              (cdr header))
5400                             ((consp header)
5401                              ;; On the form (Header . function)
5402                              (car header))
5403                             (t
5404                              ;; Just a Header.
5405                              header)))
5406          (when (and (not (memq header-name excluded-headers))
5407                     (or (eq included-headers t)
5408                         (memq header-name included-headers)))
5409            (push header result)))
5410        (nreverse result)))
5411    
5412  (defun message-setup-1 (headers &optional replybuffer actions)  (defun message-setup-1 (headers &optional replybuffer actions)
   (when (and (boundp 'mc-modes-alist)  
              (not (assq 'message-mode mc-modes-alist)))  
     (push '(message-mode (encrypt . mc-encrypt-message)  
                          (sign . mc-sign-message))  
           mc-modes-alist))  
5413    (dolist (action actions)    (dolist (action actions)
5414      (condition-case nil      (condition-case nil
5415          (add-to-list 'message-send-actions          (add-to-list 'message-send-actions
# Line 3679  than 988 characters long, and if they ar Line 5443  than 988 characters long, and if they ar
5443        (or (bolp) (insert ?\n)))        (or (bolp) (insert ?\n)))
5444      (when message-generate-headers-first      (when message-generate-headers-first
5445        (message-generate-headers        (message-generate-headers
5446         (delq 'Lines         (message-headers-to-generate
5447               (delq 'Subject          (append message-required-news-headers
5448                     (copy-sequence message-required-news-headers))))))                  message-required-headers)
5449            message-generate-headers-first
5450            '(Lines Subject)))))
5451    (when (message-mail-p)    (when (message-mail-p)
5452      (when message-default-mail-headers      (when message-default-mail-headers
5453        (insert message-default-mail-headers)        (insert message-default-mail-headers)
5454        (or (bolp) (insert ?\n)))        (or (bolp) (insert ?\n)))
5455        (save-restriction
5456          (message-narrow-to-headers)
5457          (if message-alternative-emails
5458              (message-use-alternative-email-as-from)))
5459      (when message-generate-headers-first      (when message-generate-headers-first
5460        (message-generate-headers        (message-generate-headers
5461         (delq 'Lines         (message-headers-to-generate
5462               (delq 'Subject          (append message-required-mail-headers
5463                     (copy-sequence message-required-mail-headers))))))                  message-required-headers)
5464            message-generate-headers-first
5465            '(Lines Subject)))))
5466    (run-hooks 'message-signature-setup-hook)    (run-hooks 'message-signature-setup-hook)
5467    (message-insert-signature)    (message-insert-signature)
5468    (save-restriction    (save-restriction
5469      (message-narrow-to-headers)      (message-narrow-to-headers)
     (if message-alternative-emails  
         (message-use-alternative-email-as-from))  
5470      (run-hooks 'message-header-setup-hook))      (run-hooks 'message-header-setup-hook))
5471    (set-buffer-modified-p nil)    (set-buffer-modified-p nil)
5472    (setq buffer-undo-list nil)    (setq buffer-undo-list nil)
# Line 3713  than 988 characters long, and if they ar Line 5483  than 988 characters long, and if they ar
5483      (if (gnus-alive-p)      (if (gnus-alive-p)
5484          (setq message-draft-article          (setq message-draft-article
5485                (nndraft-request-associate-buffer "drafts"))                (nndraft-request-associate-buffer "drafts"))
5486        (setq buffer-file-name (expand-file-name "*message*"        (setq buffer-file-name (expand-file-name
5487                                                 message-auto-save-directory))                                (if (memq system-type
5488                                            '(ms-dos ms-windows windows-nt
5489                                                     cygwin cygwin32 win32 w32
5490                                                     mswindows))
5491                                      "message"
5492                                    "*message*")
5493                                  message-auto-save-directory))
5494        (setq buffer-auto-save-file-name (make-auto-save-file-name)))        (setq buffer-auto-save-file-name (make-auto-save-file-name)))
5495      (clear-visited-file-modtime)      (clear-visited-file-modtime)
5496      (setq buffer-file-coding-system message-draft-coding-system)))      (setq buffer-file-coding-system message-draft-coding-system)))
# Line 3775  OTHER-HEADERS is an alist of header/valu Line 5551  OTHER-HEADERS is an alist of header/valu
5551    "Start editing a news article to be sent."    "Start editing a news article to be sent."
5552    (interactive)    (interactive)
5553    (let ((message-this-is-news t))    (let ((message-this-is-news t))
5554      (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))      (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups))
5555      (message-setup `((Newsgroups . ,(or newsgroups ""))      (message-setup `((Newsgroups . ,(or newsgroups ""))
5556                       (Subject . ,(or subject ""))))))                       (Subject . ,(or subject ""))))))
5557    
5558  (defun message-get-reply-headers (wide &optional to-address)  (defun message-get-reply-headers (wide &optional to-address address-headers)
5559    (let (follow-to mct never-mct from to cc reply-to ccalist)    (let (follow-to mct never-mct to cc author mft recipients)
5560      ;; Find all relevant headers we need.      ;; Find all relevant headers we need.
5561      (setq from (message-fetch-field "from")      (save-restriction
5562            to (message-fetch-field "to")        (message-narrow-to-headers-or-head)
5563            cc (message-fetch-field "cc")        ;; Gmane renames "To".  Look at "Original-To", too, if it is present in
5564            mct (message-fetch-field "mail-copies-to")        ;; message-header-synonyms.
5565            reply-to (message-fetch-field "reply-to"))        (setq to (or (message-fetch-field "to")
5566                       (and (loop for synonym in message-header-synonyms
5567                                  when (memq 'Original-To synonym)
5568                                  return t)
5569                            (message-fetch-field "original-to")))
5570                cc (message-fetch-field "cc")
5571                mct (message-fetch-field "mail-copies-to")
5572                author (or (message-fetch-field "mail-reply-to")
5573                           (message-fetch-field "reply-to")
5574                           (message-fetch-field "from")
5575                           "")
5576                mft (and message-use-mail-followup-to
5577                         (message-fetch-field "mail-followup-to"))))
5578    
5579      ;; Handle special values of Mail-Copies-To.      ;; Handle special values of Mail-Copies-To.
5580      (when mct      (when mct
# Line 3796  OTHER-HEADERS is an alist of header/valu Line 5584  OTHER-HEADERS is an alist of header/valu
5584               (setq mct nil))               (setq mct nil))
5585              ((or (equal (downcase mct) "always")              ((or (equal (downcase mct) "always")
5586                   (equal (downcase mct) "poster"))                   (equal (downcase mct) "poster"))
5587               (setq mct (or reply-to from)))))               (setq mct author))))
5588    
5589      (if (or (not wide)      (save-match-data
5590              to-address)        ;; Build (textual) list of new recipient addresses.
5591          (progn        (cond
5592            (setq follow-to (list (cons 'To (or to-address reply-to from))))         ((not wide)
5593            (when (and wide mct)          (setq recipients (concat ", " author)))
5594              (push (cons 'Cc mct) follow-to)))         (address-headers
5595        (let (ccalist)          (dolist (header address-headers)
5596          (save-excursion            (let ((value (message-fetch-field header)))
5597            (message-set-work-buffer)              (when value
5598            (unless never-mct                (setq recipients (concat recipients ", " value))))))
5599              (insert (or reply-to from "")))         ((and mft
5600            (insert (if to (concat (if (bolp) "" ", ") to "") ""))               (string-match "[^ \t,]" mft)
5601            (insert (if mct (concat (if (bolp) "" ", ") mct) ""))               (or (not (eq message-use-mail-followup-to 'ask))
5602            (insert (if cc (concat (if (bolp) "" ", ") cc) ""))                   (message-y-or-n-p "Obey Mail-Followup-To? " t "\
5603            (goto-char (point-min))  You should normally obey the Mail-Followup-To: header.  In this
5604            (while (re-search-forward "[ \t]+" nil t)  article, it has the value of
5605              (replace-match " " t t))  
5606            ;; Remove addresses that match `rmail-dont-reply-to-names'.  " mft "
5607            (let ((rmail-dont-reply-to-names message-dont-reply-to-names))  
5608              (insert (prog1 (rmail-dont-reply-to (buffer-string))  which directs your response to " (if (string-match "," mft)
5609                        (erase-buffer))))                                       "the specified addresses"
5610            (goto-char (point-min))                                     "that address only") ".
5611            ;; Perhaps "Mail-Copies-To: never" removed the only address?  
5612            (when (eobp)  Most commonly, Mail-Followup-To is used by a mailing list poster to
5613              (insert (or reply-to from "")))  express that responses should be sent to just the list, and not the
5614            (setq ccalist  poster as well.
5615                  (mapcar  
5616                   (lambda (addr)  If a message is posted to several mailing lists, Mail-Followup-To may
5617                     (cons (mail-strip-quoted-names addr) addr))  also be used to direct the following discussion to one list only,
5618                   (message-tokenize-header (buffer-string))))  because discussions that are spread over several lists tend to be
5619            (let ((s ccalist))  fragmented and very difficult to follow.
5620              (while s  
5621                (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))  Also, some source/announcement lists are not intended for discussion;
5622          (setq follow-to (list (cons 'To (cdr (pop ccalist)))))  responses here are directed to other addresses.")))
5623          (when ccalist          (setq recipients (concat ", " mft)))
5624            (let ((ccs (cons 'Cc (mapconcat         (to-address
5625                                  (lambda (addr) (cdr addr)) ccalist ", "))))          (setq recipients (concat ", " to-address))
5626              (when (string-match "^ +" (cdr ccs))          ;; If the author explicitly asked for a copy, we don't deny it to them.
5627                (setcdr ccs (substring (cdr ccs) (match-end 0))))          (if mct (setq recipients (concat recipients ", " mct))))
5628              (push ccs follow-to)))))         (t
5629            (setq recipients (if never-mct "" (concat ", " author)))
5630            (if to  (setq recipients (concat recipients ", " to)))
5631            (if cc  (setq recipients (concat recipients ", " cc)))
5632            (if mct (setq recipients (concat recipients ", " mct)))))
5633          (if (>= (length recipients) 2)
5634              ;; Strip the leading ", ".
5635              (setq recipients (substring recipients 2)))
5636          ;; Squeeze whitespace.
5637          (while (string-match "[ \t][ \t]+" recipients)
5638            (setq recipients (replace-match " " t t recipients)))
5639          ;; Remove addresses that match `rmail-dont-reply-to-names'.
5640          (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
5641            (setq recipients (rmail-dont-reply-to recipients)))
5642          ;; Perhaps "Mail-Copies-To: never" removed the only address?
5643          (if (string-equal recipients "")
5644              (setq recipients author))
5645          ;; Convert string to a list of (("foo@bar" . "Name <Foo@BAR>") ...).
5646          (setq recipients
5647                (mapcar
5648                 (lambda (addr)
5649                   (cons (downcase (mail-strip-quoted-names addr)) addr))
5650                 (message-tokenize-header recipients)))
5651          ;; Remove first duplicates.  (Why not all duplicates?  Is this a bug?)
5652          (let ((s recipients))
5653            (while s
5654              (setq recipients (delq (assoc (car (pop s)) s) recipients))))
5655    
5656          ;; Remove hierarchical lists that are contained within each other,
5657          ;; if message-hierarchical-addresses is defined.
5658          (when message-hierarchical-addresses
5659            (let ((plain-addrs (mapcar 'car recipients))
5660                  subaddrs recip)
5661              (while plain-addrs
5662                (setq subaddrs (assoc (car plain-addrs)
5663                                      message-hierarchical-addresses)
5664                      plain-addrs (cdr plain-addrs))
5665                (when subaddrs
5666                  (setq subaddrs (cdr subaddrs))
5667                  (while subaddrs
5668                    (setq recip (assoc (car subaddrs) recipients)
5669                          subaddrs (cdr subaddrs))
5670                    (if recip
5671                        (setq recipients (delq recip recipients))))))))
5672    
5673          ;; Build the header alist.  Allow the user to be asked whether
5674          ;; or not to reply to all recipients in a wide reply.
5675          (setq follow-to (list (cons 'To (cdr (pop recipients)))))
5676          (when (and recipients
5677                     (or (not message-wide-reply-confirm-recipients)
5678                         (y-or-n-p "Reply to all recipients? ")))
5679            (setq recipients (mapconcat
5680                              (lambda (addr) (cdr addr)) recipients ", "))
5681            (if (string-match "^ +" recipients)
5682                (setq recipients (substring recipients (match-end 0))))
5683            (push (cons 'Cc recipients) follow-to)))
5684      follow-to))      follow-to))
5685    
   
5686  ;;;###autoload  ;;;###autoload
5687  (defun message-reply (&optional to-address wide)  (defun message-reply (&optional to-address wide)
5688    "Start editing a reply to the article in the current buffer."    "Start editing a reply to the article in the current buffer."
# Line 3857  OTHER-HEADERS is an alist of header/valu Line 5699  OTHER-HEADERS is an alist of header/valu
5699        ;; Allow customizations to have their say.        ;; Allow customizations to have their say.
5700        (if (not wide)        (if (not wide)
5701            ;; This is a regular reply.            ;; This is a regular reply.
5702            (if (message-functionp message-reply-to-function)            (when (functionp message-reply-to-function)
               (setq follow-to (funcall message-reply-to-function)))  
         ;; This is a followup.  
         (if (message-functionp message-wide-reply-to-function)  
5703              (save-excursion              (save-excursion
5704                (setq follow-to                (setq follow-to (funcall message-reply-to-function))))
5705                      (funcall message-wide-reply-to-function)))))          ;; This is a followup.
5706            (when (functionp message-wide-reply-to-function)
5707              (save-excursion
5708                (setq follow-to
5709                      (funcall message-wide-reply-to-function)))))
5710        (setq message-id (message-fetch-field "message-id" t)        (setq message-id (message-fetch-field "message-id" t)
5711              references (message-fetch-field "references")              references (message-fetch-field "references")
5712              date (message-fetch-field "date")              date (message-fetch-field "date")
5713              from (message-fetch-field "from")              from (message-fetch-field "from")
5714              subject (or (message-fetch-field "subject") "none"))              subject (or (message-fetch-field "subject") "none"))
5715      (if gnus-list-identifiers        (when gnus-list-identifiers
5716          (setq subject (message-strip-list-identifiers subject)))          (setq subject (message-strip-list-identifiers subject)))
5717      (setq subject (concat "Re: " (message-strip-subject-re subject)))        (setq subject (concat "Re: " (message-strip-subject-re subject)))
5718          (when message-subject-trailing-was-query
5719            (setq subject (message-strip-subject-trailing-was subject)))
5720    
5721      (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))        (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
5722                 (string-match "<[^>]+>" gnus-warning))                   (string-match "<[^>]+>" gnus-warning))
5723        (setq message-id (match-string 0 gnus-warning)))          (setq message-id (match-string 0 gnus-warning)))
5724    
5725      (unless follow-to        (unless follow-to
5726        (setq follow-to (message-get-reply-headers wide to-address))))          (setq follow-to (message-get-reply-headers wide to-address))))
5727    
5728      (unless (message-mail-user-agent)      (unless (message-mail-user-agent)
5729        (message-pop-to-buffer        (message-pop-to-buffer
# Line 3891  OTHER-HEADERS is an alist of header/valu Line 5736  OTHER-HEADERS is an alist of header/valu
5736    
5737      (message-setup      (message-setup
5738       `((Subject . ,subject)       `((Subject . ,subject)
5739         ,@follow-to         ,@follow-to)
        ,@(if (or references message-id)  
              `((References . ,(concat (or references "") (and references " ")  
                                       (or message-id ""))))  
            nil))  
5740       cur)))       cur)))
5741    
5742  ;;;###autoload  ;;;###autoload
# Line 3911  If TO-NEWSGROUPS, use that as the new Ne Line 5752  If TO-NEWSGROUPS, use that as the new Ne
5752    (interactive)    (interactive)
5753    (require 'gnus-sum)                   ; for gnus-list-identifiers    (require 'gnus-sum)                   ; for gnus-list-identifiers
5754    (let ((cur (current-buffer))    (let ((cur (current-buffer))
5755          from subject date reply-to mct          from subject date reply-to mrt mct
5756          references message-id follow-to          references message-id follow-to
5757          (inhibit-point-motion-hooks t)          (inhibit-point-motion-hooks t)
5758          (message-this-is-news t)          (message-this-is-news t)
# Line 3922  If TO-NEWSGROUPS, use that as the new Ne Line 5763  If TO-NEWSGROUPS, use that as the new Ne
5763         (if (search-forward "\n\n" nil t)         (if (search-forward "\n\n" nil t)
5764             (1- (point))             (1- (point))
5765           (point-max)))           (point-max)))
5766        (when (message-functionp message-followup-to-function)        (when (functionp message-followup-to-function)
5767          (setq follow-to          (setq follow-to
5768                (funcall message-followup-to-function)))                (funcall message-followup-to-function)))
5769        (setq from (message-fetch-field "from")        (setq from (message-fetch-field "from")
# Line 3934  If TO-NEWSGROUPS, use that as the new Ne Line 5775  If TO-NEWSGROUPS, use that as the new Ne
5775              newsgroups (message-fetch-field "newsgroups")              newsgroups (message-fetch-field "newsgroups")
5776              posted-to (message-fetch-field "posted-to")              posted-to (message-fetch-field "posted-to")
5777              reply-to (message-fetch-field "reply-to")              reply-to (message-fetch-field "reply-to")
5778                mrt (message-fetch-field "mail-reply-to")
5779              distribution (message-fetch-field "distribution")              distribution (message-fetch-field "distribution")
5780              mct (message-fetch-field "mail-copies-to"))              mct (message-fetch-field "mail-copies-to"))
5781        (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))        (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
# Line 3947  If TO-NEWSGROUPS, use that as the new Ne Line 5789  If TO-NEWSGROUPS, use that as the new Ne
5789        (if gnus-list-identifiers        (if gnus-list-identifiers
5790            (setq subject (message-strip-list-identifiers subject)))            (setq subject (message-strip-list-identifiers subject)))
5791        (setq subject (concat "Re: " (message-strip-subject-re subject)))        (setq subject (concat "Re: " (message-strip-subject-re subject)))
5792          (when message-subject-trailing-was-query
5793            (setq subject (message-strip-subject-trailing-was subject)))
5794        (widen))        (widen))
5795    
5796      (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))      (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
5797    
5798        (setq message-reply-headers
5799              (vector 0 subject from date message-id references 0 0 ""))
5800    
5801      (message-setup      (message-setup
5802       `((Subject . ,subject)       `((Subject . ,subject)
5803         ,@(cond         ,@(cond
# Line 3971  A typical situation where `Followup-To: Line 5818  A typical situation where `Followup-To:
5818  does not read the newsgroup, so he wouldn't see any replies sent to it."))  does not read the newsgroup, so he wouldn't see any replies sent to it."))
5819                    (progn                    (progn
5820                      (setq message-this-is-news nil)                      (setq message-this-is-news nil)
5821                      (cons 'To (or reply-to from "")))                      (cons 'To (or mrt reply-to from "")))
5822                  (cons 'Newsgroups newsgroups)))                  (cons 'Newsgroups newsgroups)))
5823               (t               (t
5824                (if (or (equal followup-to newsgroups)                (if (or (equal followup-to newsgroups)
# Line 3990  used to direct the following discussion Line 5837  used to direct the following discussion
5837  because discussions that are spread over several newsgroup tend to  because discussions that are spread over several newsgroup tend to
5838  be fragmented and very difficult to follow.  be fragmented and very difficult to follow.
5839    
5840  Also, some source/announcement newsgroups are not indented for discussion;  Also, some source/announcement newsgroups are not intended for discussion;
5841  responses here are directed to other newsgroups."))  responses here are directed to other newsgroups."))
5842                    (cons 'Newsgroups followup-to)                    (cons 'Newsgroups followup-to)
5843                  (cons 'Newsgroups newsgroups))))))                  (cons 'Newsgroups newsgroups))))))
# Line 3999  responses here are directed to other new Line 5846  responses here are directed to other new
5846            (t            (t
5847             `((Newsgroups . ,newsgroups))))             `((Newsgroups . ,newsgroups))))
5848         ,@(and distribution (list (cons 'Distribution distribution)))         ,@(and distribution (list (cons 'Distribution distribution)))
        ,@(if (or references message-id)  
              `((References . ,(concat (or references "") (and references " ")  
                                       (or message-id "")))))  
5849         ,@(when (and mct         ,@(when (and mct
5850                      (not (or (equal (downcase mct) "never")                      (not (or (equal (downcase mct) "never")
5851                               (equal (downcase mct) "nobody"))))                               (equal (downcase mct) "nobody"))))
5852             (list (cons 'Cc (if (or (equal (downcase mct) "always")             (list (cons 'Cc (if (or (equal (downcase mct) "always")
5853                                     (equal (downcase mct) "poster"))                                     (equal (downcase mct) "poster"))
5854                                 (or reply-to from "")                                 (or mrt reply-to from "")
5855                               mct)))))                               mct)))))
5856    
5857       cur)       cur)))
   
     (setq message-reply-headers  
           (vector 0 subject from date message-id references 0 0 ""))))  
5858    
5859    (defun message-is-yours-p ()
5860      "Non-nil means current article is yours.
5861    If you have added 'cancel-messages to 'message-shoot-gnksa-feet', all articles
5862    are yours except those that have Cancel-Lock header not belonging to you.
5863    Instead of shooting GNKSA feet, you should modify 'message-alternative-emails'
5864    regexp to match all of yours addresses."
5865      ;; Canlock-logic as suggested by Per Abrahamsen
5866      ;; <abraham@dina.kvl.dk>
5867      ;;
5868      ;; IF article has cancel-lock THEN
5869      ;;   IF we can verify it THEN
5870      ;;     issue cancel
5871      ;;   ELSE
5872      ;;     error: cancellock: article is not yours
5873      ;; ELSE
5874      ;;   Use old rules, comparing sender...
5875      (save-excursion
5876        (save-restriction
5877          (message-narrow-to-head-1)
5878          (if (message-fetch-field "Cancel-Lock")
5879              (if (null (canlock-verify))
5880                  t
5881                (error "Failed to verify Cancel-lock: This article is not yours"))
5882            (let (sender from)
5883              (or
5884               (message-gnksa-enable-p 'cancel-messages)
5885               (and (setq sender (message-fetch-field "sender"))
5886                    (string-equal (downcase sender)
5887                                  (downcase (message-make-sender))))
5888               ;; Email address in From field equals to our address
5889               (and (setq from (message-fetch-field "from"))
5890                    (string-equal
5891                     (downcase (cadr (mail-extract-address-components from)))
5892                     (downcase (cadr (mail-extract-address-components
5893                                      (message-make-from))))))
5894               ;; Email address in From field matches
5895               ;; 'message-alternative-emails' regexp
5896               (and from
5897                    message-alternative-emails
5898                    (string-match
5899                     message-alternative-emails
5900                     (cadr (mail-extract-address-components from))))))))))
5901    
5902  ;;;###autoload  ;;;###autoload
5903  (defun message-cancel-news (&optional arg)  (defun message-cancel-news (&optional arg)
# Line 4023  If ARG, allow editing of the cancellatio Line 5906  If ARG, allow editing of the cancellatio
5906    (interactive "P")    (interactive "P")
5907    (unless (message-news-p)    (unless (message-news-p)
5908      (error "This is not a news article; canceling is impossible"))      (error "This is not a news article; canceling is impossible"))
5909    (when (yes-or-no-p "Do you really want to cancel this article? ")    (let (from newsgroups message-id distribution buf)
5910      (let (from newsgroups message-id distribution buf sender)      (save-excursion
5911        (save-excursion        ;; Get header info from original article.
5912          ;; Get header info from original article.        (save-restriction
5913          (save-restriction          (message-narrow-to-head-1)
5914            (message-narrow-to-head-1)          (setq from (message-fetch-field "from")
5915            (setq from (message-fetch-field "from")                newsgroups (message-fetch-field "newsgroups")
5916                  sender (message-fetch-field "sender")                message-id (message-fetch-field "message-id" t)
5917                  newsgroups (message-fetch-field "newsgroups")                distribution (message-fetch-field "distribution")))
5918                  message-id (message-fetch-field "message-id" t)        ;; Make sure that this article was written by the user.
5919                  distribution (message-fetch-field "distribution")))        (unless (message-is-yours-p)
5920          ;; Make sure that this article was written by the user.          (error "This article is not yours"))
5921          (unless (or (and sender        (when (yes-or-no-p "Do you really want to cancel this article? ")
                          (string-equal  
                           (downcase sender)  
                           (downcase (message-make-sender))))  
                     (string-equal  
                      (downcase (cadr (mail-extract-address-components from)))  
                      (downcase (cadr (mail-extract-address-components  
                                       (message-make-from))))))  
           (error "This article is not yours"))  
5922          ;; Make control message.          ;; Make control message.
5923          (if arg          (if arg
5924              (message-news)              (message-news)
5925            (setq buf (set-buffer (get-buffer-create " *message cancel*"))))            (setq buf (set-buffer (get-buffer-create " *message cancel*"))))
5926          (erase-buffer)          (erase-buffer)
5927          (insert "Newsgroups: " newsgroups "\n"          (insert "Newsgroups: " newsgroups "\n"
5928                 "From: " from "\n"                  "From: " from "\n"
5929                  "Subject: cmsg cancel " message-id "\n"                  "Subject: cmsg cancel " message-id "\n"
5930                  "Control: cancel " message-id "\n"                  "Control: cancel " message-id "\n"
5931                  (if distribution                  (if distribution
# Line 4073  If ARG, allow editing of the cancellatio Line 5948  If ARG, allow editing of the cancellatio
5948  This is done simply by taking the old article and adding a Supersedes  This is done simply by taking the old article and adding a Supersedes
5949  header line with the old Message-ID."  header line with the old Message-ID."
5950    (interactive)    (interactive)
5951    (let ((cur (current-buffer))    (let ((cur (current-buffer)))
         (sender (message-fetch-field "sender"))  
         (from (message-fetch-field "from")))  
5952      ;; Check whether the user owns the article that is to be superseded.      ;; Check whether the user owns the article that is to be superseded.
5953      (unless (or (and sender      (unless (message-is-yours-p)
                      (string-equal  
                       (downcase sender)  
                       (downcase (message-make-sender))))  
                 (string-equal  
                  (downcase (cadr (mail-extract-address-components from)))  
                  (downcase (cadr (mail-extract-address-components  
                                   (message-make-from))))))  
5954        (error "This article is not yours"))        (error "This article is not yours"))
5955      ;; Get a normal message buffer.      ;; Get a normal message buffer.
5956      (message-pop-to-buffer (message-buffer-name "supersede"))      (message-pop-to-buffer (message-buffer-name "supersede"))
# Line 4161  Previous forwarders, replyers, etc. may Line 6027  Previous forwarders, replyers, etc. may
6027  (defvar message-forward-decoded-p nil  (defvar message-forward-decoded-p nil
6028    "Non-nil means the original message is decoded.")    "Non-nil means the original message is decoded.")
6029    
6030    (defun message-forward-subject-name-subject (subject)
6031      "Generate a SUBJECT for a forwarded message.
6032    The form is: [Source] Subject, where if the original message was mail,
6033    Source is the name of the sender, and if the original message was
6034    news, Source is the list of newsgroups is was posted to."
6035      (let* ((group (message-fetch-field "newsgroups"))
6036             (from (message-fetch-field "from"))
6037             (prefix
6038              (if group
6039                  (gnus-group-decoded-name group)
6040                (or (and from (car (gnus-extract-address-components from)))
6041                    "(nowhere)"))))
6042        (concat "["
6043                (if message-forward-decoded-p
6044                    prefix
6045                  (mail-decode-encoded-word-string prefix))
6046                "] " subject)))
6047    
6048  (defun message-forward-subject-author-subject (subject)  (defun message-forward-subject-author-subject (subject)
6049    "Generate a SUBJECT for a forwarded message.    "Generate a SUBJECT for a forwarded message.
6050  The form is: [Source] Subject, where if the original message was mail,  The form is: [Source] Subject, where if the original message was mail,
6051  Source is the sender, and if the original message was news, Source is  Source is the sender, and if the original message was news, Source is
6052  the list of newsgroups is was posted to."  the list of newsgroups is was posted to."
6053    (concat "["    (let* ((group (message-fetch-field "newsgroups"))
6054             (let ((prefix           (prefix
6055                    (or (message-fetch-field "newsgroups")            (if group
6056                        (message-fetch-field "from")                (gnus-group-decoded-name group)
6057                        "(nowhere)")))              (or (message-fetch-field "from")
6058               (if message-forward-decoded-p                  "(nowhere)"))))
6059                   prefix      (concat "["
6060                 (mail-decode-encoded-word-string prefix)))              (if message-forward-decoded-p
6061            "] " subject))                  prefix
6062                  (mail-decode-encoded-word-string prefix))
6063                "] " subject)))
6064    
6065  (defun message-forward-subject-fwd (subject)  (defun message-forward-subject-fwd (subject)
6066    "Generate a SUBJECT for a forwarded message.    "Generate a SUBJECT for a forwarded message.
6067  The form is: Fwd: Subject, where Subject is the original subject of  The form is: Fwd: Subject, where Subject is the original subject of
6068  the message."  the message."
6069    (concat "Fwd: " subject))    (if (string-match "^Fwd: " subject)
6070          subject
6071        (concat "Fwd: " subject)))
6072    
6073  (defun message-make-forward-subject ()  (defun message-make-forward-subject ()
6074    "Return a Subject header suitable for the message in the current buffer."    "Return a Subject header suitable for the message in the current buffer."
# Line 4204  the message." Line 6092  the message."
6092          ;; Apply funcs in order, passing subject generated by previous          ;; Apply funcs in order, passing subject generated by previous
6093          ;; func to the next one.          ;; func to the next one.
6094          (while funcs          (while funcs
6095            (when (message-functionp (car funcs))            (when (functionp (car funcs))
6096              (setq subject (funcall (car funcs) subject)))              (setq subject (funcall (car funcs) subject)))
6097            (setq funcs (cdr funcs)))            (setq funcs (cdr funcs)))
6098          subject))))          subject))))
# Line 4230  Optional DIGEST will use digest to forwa Line 6118  Optional DIGEST will use digest to forwa
6118        (message-mail nil subject))        (message-mail nil subject))
6119      (message-forward-make-body cur digest)))      (message-forward-make-body cur digest)))
6120    
6121    (defun message-forward-make-body-plain (forward-buffer)
6122      (insert
6123       "\n-------------------- Start of forwarded message --------------------\n")
6124      (let ((b (point)) e)
6125        (insert
6126         (with-temp-buffer
6127           (mm-disable-multibyte)
6128           (insert
6129            (with-current-buffer forward-buffer
6130              (mm-with-unibyte-current-buffer (buffer-string))))
6131           (mm-enable-multibyte)
6132           (mime-to-mml)
6133           (goto-char (point-min))
6134           (when (looking-at "From ")
6135             (replace-match "X-From-Line: "))
6136           (buffer-string)))
6137        (setq e (point))
6138        (insert
6139         "\n-------------------- End of forwarded message --------------------\n")
6140        (when (and (not current-prefix-arg)
6141                   message-forward-ignored-headers)
6142          (save-restriction
6143            (narrow-to-region b e)
6144            (goto-char b)
6145            (narrow-to-region (point)
6146                              (or (search-forward "\n\n" nil t) (point)))
6147            (message-remove-header message-forward-ignored-headers t)))))
6148    
6149    (defun message-forward-make-body-mime (forward-buffer)
6150      (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")
6151      (let ((b (point)) e)
6152        (save-restriction
6153          (narrow-to-region (point) (point))
6154          (mml-insert-buffer forward-buffer)
6155          (goto-char (point-min))
6156          (when (looking-at "From ")
6157            (replace-match "X-From-Line: "))
6158          (goto-char (point-max)))
6159        (setq e (point))
6160        (insert "<#/part>\n")))
6161    
6162    (defun message-forward-make-body-mml (forward-buffer)
6163      (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
6164      (let ((b (point)) e)
6165        (if (not message-forward-decoded-p)
6166            (insert
6167             (with-temp-buffer
6168               (mm-disable-multibyte)
6169               (insert
6170                (with-current-buffer forward-buffer
6171                  (mm-with-unibyte-current-buffer (buffer-string))))
6172               (mm-enable-multibyte)
6173               (mime-to-mml)
6174               (goto-char (point-min))
6175               (when (looking-at "From ")
6176                 (replace-match "X-From-Line: "))
6177               (buffer-string)))
6178          (save-restriction
6179            (narrow-to-region (point) (point))
6180            (mml-insert-buffer forward-buffer)
6181            (goto-char (point-min))
6182            (when (looking-at "From ")
6183              (replace-match "X-From-Line: "))
6184            (goto-char (point-max))))
6185        (setq e (point))
6186        (insert "<#/mml>\n")
6187        (when (and (not current-prefix-arg)
6188                   message-forward-ignored-headers)
6189          (save-restriction
6190            (narrow-to-region b e)
6191            (goto-char b)
6192            (narrow-to-region (point)
6193                              (or (search-forward "\n\n" nil t) (point)))
6194            (message-remove-header message-forward-ignored-headers t)))))
6195    
6196    (defun message-forward-make-body-digest-plain (forward-buffer)
6197      (insert
6198       "\n-------------------- Start of forwarded message --------------------\n")
6199      (let ((b (point)) e)
6200        (mml-insert-buffer forward-buffer)
6201        (setq e (point))
6202        (insert
6203         "\n-------------------- End of forwarded message --------------------\n")))
6204    
6205    (defun message-forward-make-body-digest-mime (forward-buffer)
6206      (insert "\n<#multipart type=digest>\n")
6207      (let ((b (point)) e)
6208        (insert-buffer-substring forward-buffer)
6209        (setq e (point))
6210        (insert "<#/multipart>\n")
6211        (save-restriction
6212          (narrow-to-region b e)
6213          (goto-char b)
6214          (narrow-to-region (point)
6215                            (or (search-forward "\n\n" nil t) (point)))
6216          (delete-region (point-min) (point-max)))))
6217    
6218    (defun message-forward-make-body-digest (forward-buffer)
6219      (if message-forward-as-mime
6220          (message-forward-make-body-digest-mime forward-buffer)
6221        (message-forward-make-body-digest-plain forward-buffer)))
6222    
6223  ;;;###autoload  ;;;###autoload
6224  (defun message-forward-make-body (forward-buffer &optional digest)  (defun message-forward-make-body (forward-buffer &optional digest)
6225    ;; Put point where we want it before inserting the forwarded    ;; Put point where we want it before inserting the forwarded
# Line 4237  Optional DIGEST will use digest to forwa Line 6227  Optional DIGEST will use digest to forwa
6227    (if message-forward-before-signature    (if message-forward-before-signature
6228        (message-goto-body)        (message-goto-body)
6229      (goto-char (point-max)))      (goto-char (point-max)))
6230    (if message-forward-as-mime    (if digest
6231        (if digest        (message-forward-make-body-digest forward-buffer)
           (insert "\n<#multipart type=digest>\n")  
         (if message-forward-show-mml  
             (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")  
           (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")))  
     (insert "\n-------------------- Start of forwarded message --------------------\n"))  
   (let ((b (point)) e)  
     (if digest  
         (if message-forward-as-mime  
             (insert-buffer-substring forward-buffer)  
           (mml-insert-buffer forward-buffer))  
       (if (and message-forward-show-mml  
                (not message-forward-decoded-p))  
           (insert  
            (with-temp-buffer  
              (mm-disable-multibyte) ;; Must copy buffer in unibyte mode  
                (insert  
                 (with-current-buffer forward-buffer  
                   (mm-string-as-unibyte (buffer-string))))  
                (mm-enable-multibyte)  
                (mime-to-mml)  
                (goto-char (point-min))  
                (when (looking-at "From ")  
                  (replace-match "X-From-Line: "))  
                (buffer-string)))  
         (save-restriction  
           (narrow-to-region (point) (point))  
           (mml-insert-buffer forward-buffer)  
           (goto-char (point-min))  
           (when (looking-at "From ")  
             (replace-match "X-From-Line: "))  
           (goto-char (point-max)))))  
     (setq e (point))  
6232      (if message-forward-as-mime      (if message-forward-as-mime
6233          (if digest          (if (and message-forward-show-mml
6234              (insert "<#/multipart>\n")                   (not (and (eq message-forward-show-mml 'best)
6235            (if message-forward-show-mml                             (with-current-buffer forward-buffer
6236                (insert "<#/mml>\n")                               (goto-char (point-min))
6237              (insert "<#/part>\n")))                               (re-search-forward
6238        (insert "\n-------------------- End of forwarded message --------------------\n"))                                "Content-Type: *multipart/\\(signed\\|encrypted\\)"
6239      (if (and digest message-forward-as-mime)                                nil t)))))
6240          (save-restriction              (message-forward-make-body-mml forward-buffer)
6241            (narrow-to-region b e)            (message-forward-make-body-mime forward-buffer))
6242            (goto-char b)        (message-forward-make-body-plain forward-buffer)))
           (narrow-to-region (point)  
                             (or (search-forward "\n\n" nil t) (point)))  
           (delete-region (point-min) (point-max)))  
       (when (and (not current-prefix-arg)  
                  message-forward-ignored-headers)  
         (save-restriction  
           (narrow-to-region b e)  
           (goto-char b)  
           (narrow-to-region (point)  
                             (or (search-forward "\n\n" nil t) (point)))  
           (message-remove-header message-forward-ignored-headers t)))))  
6243    (message-position-point))    (message-position-point))
6244    
6245  ;;;###autoload  ;;;###autoload
6246  (defun message-forward-rmail-make-body (forward-buffer)  (defun message-forward-rmail-make-body (forward-buffer)
6247    (save-window-excursion    (save-window-excursion
6248      (set-buffer forward-buffer)      (set-buffer forward-buffer)
6249        ;; Rmail doesn't have rmail-msg-restore-non-pruned-header in Emacs
6250        ;; 20.  FIXIT, or we drop support for rmail in Emacs 20.
6251      (if (rmail-msg-is-pruned)      (if (rmail-msg-is-pruned)
6252          (rmail-msg-restore-non-pruned-header)))          (rmail-msg-restore-non-pruned-header)))
6253    (message-forward-make-body forward-buffer))    (message-forward-make-body forward-buffer))
6254    
6255    (eval-when-compile (defvar rmail-enable-mime-composing))
6256    
6257    ;; Fixme: Should have defcustom.
6258  ;;;###autoload  ;;;###autoload
6259  (defun message-insinuate-rmail ()  (defun message-insinuate-rmail ()
6260    "Let RMAIL uses message to forward."    "Let RMAIL use message to forward."
6261    (interactive)    (interactive)
6262    (setq rmail-enable-mime-composing t)    (setq rmail-enable-mime-composing t)
6263    (setq rmail-insert-mime-forwarded-message-function    (setq rmail-insert-mime-forwarded-message-function
# Line 4324  Optional DIGEST will use digest to forwa Line 6276  Optional DIGEST will use digest to forwa
6276        (unless (message-mail-user-agent)        (unless (message-mail-user-agent)
6277          (set-buffer (get-buffer-create " *message resend*"))          (set-buffer (get-buffer-create " *message resend*"))
6278          (erase-buffer))          (erase-buffer))
6279        (let ((message-this-is-mail t))        (let ((message-this-is-mail t)
6280                message-setup-hook)
6281          (message-setup `((To . ,address))))          (message-setup `((To . ,address))))
6282        ;; Insert our usual headers.        ;; Insert our usual headers.
6283        (message-generate-headers '(From Date To))        (message-generate-headers '(From Date To Message-ID))
6284        (message-narrow-to-headers)        (message-narrow-to-headers)
6285          ;; Remove X-Draft-From header etc.
6286          (message-remove-header message-ignored-mail-headers t)
6287        ;; Rename them all to "Resent-*".        ;; Rename them all to "Resent-*".
6288          (goto-char (point-min))
6289        (while (re-search-forward "^[A-Za-z]" nil t)        (while (re-search-forward "^[A-Za-z]" nil t)
6290          (forward-char -1)          (forward-char -1)
6291          (insert "Resent-"))          (insert "Resent-"))
# Line 4380  you." Line 6336  you."
6336        (mm-insert-part handles)        (mm-insert-part handles)
6337        (undo-boundary)        (undo-boundary)
6338        (goto-char (point-min))        (goto-char (point-min))
6339        (search-forward "\n\n" nil t)        (re-search-forward "\n\n+" nil t)
6340        (or (and (re-search-forward message-unsent-separator nil t)        (setq boundary (point))
                (forward-line 1))  
           (re-search-forward "^Return-Path:.*\n" nil t))  
6341        ;; We remove everything before the bounced mail.        ;; We remove everything before the bounced mail.
6342        (delete-region        (if (or (re-search-forward message-unsent-separator nil t)
6343         (point-min)                (progn
6344         (if (re-search-forward "^[^ \n\t]+:" nil t)                  (search-forward "\n\n" nil 'move)
6345             (match-beginning 0)                  (re-search-backward "^Return-Path:.*\n" boundary t)))
6346           (point))))            (progn
6347                (forward-line 1)
6348                (delete-region (point-min)
6349                               (if (re-search-forward "^[^ \n\t]+:" nil t)
6350                                   (match-beginning 0)
6351                                 (point))))
6352            (goto-char boundary)
6353            (when (re-search-backward "^.?From .*\n" nil t)
6354              (delete-region (match-beginning 0) (match-end 0)))))
6355      (mm-enable-multibyte)      (mm-enable-multibyte)
     (mime-to-mml)  
6356      (save-restriction      (save-restriction
6357        (message-narrow-to-head-1)        (message-narrow-to-head-1)
6358        (message-remove-header message-ignored-bounced-headers t)        (message-remove-header message-ignored-bounced-headers t)
# Line 4442  you." Line 6403  you."
6403          (special-display-regexps nil)          (special-display-regexps nil)
6404          (same-window-buffer-names nil)          (same-window-buffer-names nil)
6405          (same-window-regexps nil))          (same-window-regexps nil))
6406      (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))      (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)))
6407    (let ((message-this-is-news t))    (let ((message-this-is-news t))
6408      (message-setup `((Newsgroups . ,(or newsgroups ""))      (message-setup `((Newsgroups . ,(or newsgroups ""))
6409                       (Subject . ,(or subject ""))))))                       (Subject . ,(or subject ""))))))
# Line 4456  you." Line 6417  you."
6417          (special-display-regexps nil)          (special-display-regexps nil)
6418          (same-window-buffer-names nil)          (same-window-buffer-names nil)
6419          (same-window-regexps nil))          (same-window-regexps nil))
6420      (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))      (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)))
6421    (let ((message-this-is-news t))    (let ((message-this-is-news t))
6422      (message-setup `((Newsgroups . ,(or newsgroups ""))      (message-setup `((Newsgroups . ,(or newsgroups ""))
6423                       (Subject . ,(or subject ""))))))                       (Subject . ,(or subject ""))))))
# Line 4495  which specify the range to operate on." Line 6456  which specify the range to operate on."
6456          (if (eq (char-after) (char-after (- (point) 2)))          (if (eq (char-after) (char-after (- (point) 2)))
6457              (delete-char -2))))))              (delete-char -2))))))
6458    
6459  (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)  (defun message-exchange-point-and-mark ()
6460      "Exchange point and mark, but don't activate region if it was inactive."
6461      (unless (prog1
6462                  (message-mark-active-p)
6463                (exchange-point-and-mark))
6464        (setq mark-active nil)))
6465    
6466    (defalias 'message-make-overlay 'make-overlay)
6467    (defalias 'message-delete-overlay 'delete-overlay)
6468    (defalias 'message-overlay-put 'overlay-put)
6469    (defun message-kill-all-overlays ()
6470      (if (featurep 'xemacs)
6471          (map-extents (lambda (extent ignore) (delete-extent extent)))
6472        (mapcar #'delete-overlay (overlays-in (point-min) (point-max)))))
6473    
6474  ;; Support for toolbar  ;; Support for toolbar
6475  (eval-when-compile (defvar tool-bar-map))  (eval-when-compile
6476  (if (featurep 'xemacs)    (defvar tool-bar-map)
6477      (require 'messagexmas)    (defvar tool-bar-mode))
6478    (when (and  
6479           (condition-case nil (require 'tool-bar) (error nil))  (defun message-tool-bar-local-item-from-menu (command icon in-map &optional from-map &rest props)
6480           (fboundp 'tool-bar-add-item-from-menu)    ;; We need to make tool bar entries in local keymaps with
6481           tool-bar-mode)    ;; `tool-bar-local-item-from-menu' in Emacs > 21.3
6482      (defvar message-tool-bar-map    (if (fboundp 'tool-bar-local-item-from-menu)
6483        (let ((tool-bar-map (copy-keymap tool-bar-map)))        ;; This is for Emacs 21.3
6484          ;; Zap some items which aren't so relevant and take up space.        (tool-bar-local-item-from-menu command icon in-map from-map props)
6485          (dolist (key '(print-buffer kill-buffer save-buffer write-file      (tool-bar-add-item-from-menu command icon from-map props)))
6486                                      dired open-file))  
6487            (define-key tool-bar-map (vector key) nil))  (defun message-tool-bar-map ()
6488      (or message-tool-bar-map
6489          (tool-bar-add-item-from-menu        (setq message-tool-bar-map
6490           'message-send-and-exit "mail_send" message-mode-map)              (and
6491          (tool-bar-add-item-from-menu               (condition-case nil (require 'tool-bar) (error nil))
6492           'message-kill-buffer "close" message-mode-map)               (fboundp 'tool-bar-add-item-from-menu)
6493          (tool-bar-add-item-from-menu               tool-bar-mode
6494           'message-dont-send "cancel" message-mode-map)               (let ((tool-bar-map (copy-keymap tool-bar-map))
6495          (tool-bar-add-item-from-menu                     (load-path (mm-image-load-path)))
6496           'mml-attach-file "attach" message-mode-map)                 ;; Zap some items which aren't so relevant and take
6497          (tool-bar-add-item-from-menu                 ;; up space.
6498           'ispell-message "spell" message-mode-map)                 (dolist (key '(print-buffer kill-buffer save-buffer
6499          tool-bar-map))))                                             write-file dired open-file))
6500                     (define-key tool-bar-map (vector key) nil))
6501                   (message-tool-bar-local-item-from-menu
6502                    'message-send-and-exit "mail_send" tool-bar-map message-mode-map)
6503                   (message-tool-bar-local-item-from-menu
6504                    'message-kill-buffer "close" tool-bar-map message-mode-map)
6505                   (message-tool-bar-local-item-from-menu
6506                        'message-dont-send "cancel" tool-bar-map message-mode-map)
6507                   (message-tool-bar-local-item-from-menu
6508                    'mml-attach-file "attach" tool-bar-map mml-mode-map)
6509                   (message-tool-bar-local-item-from-menu
6510                    'ispell-message "spell" tool-bar-map message-mode-map)
6511                   (message-tool-bar-local-item-from-menu
6512                    'mml-preview "preview"
6513                    tool-bar-map mml-mode-map)
6514                   (message-tool-bar-local-item-from-menu
6515                    'message-insert-importance-high "important"
6516                    tool-bar-map message-mode-map)
6517                   (message-tool-bar-local-item-from-menu
6518                    'message-insert-importance-low "unimportant"
6519                    tool-bar-map message-mode-map)
6520                   (message-tool-bar-local-item-from-menu
6521                    'message-insert-disposition-notification-to "receipt"
6522                    tool-bar-map message-mode-map)
6523                   tool-bar-map)))))
6524    
6525  ;;; Group name completion.  ;;; Group name completion.
6526    
6527  (defvar message-newgroups-header-regexp  (defcustom message-newgroups-header-regexp
6528    "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"    "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"
6529    "Regexp that match headers that lists groups.")    "Regexp that match headers that lists groups."
6530      :group 'message
6531      :type 'regexp)
6532    
6533    (defcustom message-completion-alist
6534      (list (cons message-newgroups-header-regexp 'message-expand-group)
6535            '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name)
6536            '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):"
6537              . message-expand-name)
6538            '("^\\(Disposition-Notification-To\\|Return-Receipt-To\\):"
6539              . message-expand-name))
6540      "Alist of (RE . FUN).  Use FUN for completion on header lines matching RE."
6541      :group 'message
6542      :type '(alist :key-type regexp :value-type function))
6543    
6544    (defcustom message-tab-body-function nil
6545      "*Function to execute when `message-tab' (TAB) is executed in the body.
6546    If nil, the function bound in `text-mode-map' or `global-map' is executed."
6547      :group 'message
6548      :link '(custom-manual "(message)Various Commands")
6549      :type 'function)
6550    
6551  (defun message-tab ()  (defun message-tab ()
6552    "Expand group names in Newsgroups and Followup-To headers.    "Complete names according to `message-completion-alist'.
6553  Do a `tab-to-tab-stop' if not in those headers."  Execute function specified by `message-tab-body-function' when not in
6554    those headers."
6555    (interactive)    (interactive)
6556    (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp))    (let ((alist message-completion-alist))
6557          (mail-abbrev-in-expansion-header-p))      (while (and alist
6558        (message-expand-group)                  (let ((mail-abbrev-mode-regexp (caar alist)))
6559      (tab-to-tab-stop)))                    (not (mail-abbrev-in-expansion-header-p))))
6560          (setq alist (cdr alist)))
6561        (funcall (or (cdar alist) message-tab-body-function
6562                     (lookup-key text-mode-map "\t")
6563                     (lookup-key global-map "\t")
6564                     'indent-relative))))
6565    
6566  (defun message-expand-group ()  (defun message-expand-group ()
6567    "Expand the group name under point."    "Expand the group name under point."
# Line 4581  Do a `tab-to-tab-stop' if not in those h Line 6605  Do a `tab-to-tab-stop' if not in those h
6605              (goto-char (point-min))              (goto-char (point-min))
6606              (delete-region (point) (progn (forward-line 3) (point))))))))))              (delete-region (point) (progn (forward-line 3) (point))))))))))
6607    
6608    (defun message-expand-name ()
6609      (if (fboundp 'bbdb-complete-name)
6610          (bbdb-complete-name)
6611        (expand-abbrev)))
6612    
6613  ;;; Help stuff.  ;;; Help stuff.
6614    
6615  (defun message-talkative-question (ask question show &rest text)  (defun message-talkative-question (ask question show &rest text)
# Line 4610  The following arguments may contain list Line 6639  The following arguments may contain list
6639           (list list))))           (list list))))
6640    
6641  (defun message-generate-new-buffer-clone-locals (name &optional varstr)  (defun message-generate-new-buffer-clone-locals (name &optional varstr)
6642    "Create and return a buffer with name based on NAME using `generate-new-buffer.'    "Create and return a buffer with name based on NAME using `generate-new-buffer'.
6643  Then clone the local variables and values from the old buffer to the  Then clone the local variables and values from the old buffer to the
6644  new one, cloning only the locals having a substring matching the  new one, cloning only the locals having a substring matching the
6645  regexp varstr."  regexp VARSTR."
6646    (let ((oldbuf (current-buffer)))    (let ((oldbuf (current-buffer)))
6647      (save-excursion      (save-excursion
6648        (set-buffer (generate-new-buffer name))        (set-buffer (generate-new-buffer name))
# Line 4671  regexp varstr." Line 6700  regexp varstr."
6700          (when lines          (when lines
6701            (insert lines))            (insert lines))
6702          (setq content-type-p          (setq content-type-p
6703                (re-search-backward "^Content-Type:" nil t)))                (or mml-boundary
6704                      (re-search-backward "^Content-Type:" nil t))))
6705        (save-restriction        (save-restriction
6706          (message-narrow-to-headers-or-head)          (message-narrow-to-headers-or-head)
6707          (message-remove-first-header "Content-Type")          (message-remove-first-header "Content-Type")
6708          (message-remove-first-header "Content-Transfer-Encoding"))          (message-remove-first-header "Content-Transfer-Encoding"))
6709        ;; We always make sure that the message has a Content-Type header.        ;; We always make sure that the message has a Content-Type
6710        ;; This is because some broken MTAs and MUAs get awfully confused        ;; header.  This is because some broken MTAs and MUAs get
6711        ;; when confronted with a message with a MIME-Version header and        ;; awfully confused when confronted with a message with a
6712        ;; without a Content-Type header.  For instance, Solaris'        ;; MIME-Version header and without a Content-Type header.  For
6713        ;; /usr/bin/mail.        ;; instance, Solaris' /usr/bin/mail.
6714        (unless content-type-p        (unless content-type-p
6715          (goto-char (point-min))          (goto-char (point-min))
6716          ;; For unknown reason, MIME-Version doesn't exist.          ;; For unknown reason, MIME-Version doesn't exist.
# Line 4688  regexp varstr." Line 6718  regexp varstr."
6718            (forward-line 1)            (forward-line 1)
6719            (insert "Content-Type: text/plain; charset=us-ascii\n"))))))            (insert "Content-Type: text/plain; charset=us-ascii\n"))))))
6720    
6721  (defun message-read-from-minibuffer (prompt)  (defun message-read-from-minibuffer (prompt &optional initial-contents)
6722    "Read from the minibuffer while providing abbrev expansion."    "Read from the minibuffer while providing abbrev expansion."
6723    (if (fboundp 'mail-abbrevs-setup)    (if (fboundp 'mail-abbrevs-setup)
6724        (let ((mail-abbrev-mode-regexp "")        (let ((mail-abbrev-mode-regexp "")
6725              (minibuffer-setup-hook 'mail-abbrevs-setup))              (minibuffer-setup-hook 'mail-abbrevs-setup)
6726          (read-from-minibuffer prompt))              (minibuffer-local-map message-minibuffer-local-map))
6727      (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook))          (read-from-minibuffer prompt initial-contents))
6728        (read-string prompt))))      (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)
6729              (minibuffer-local-map message-minibuffer-local-map))
6730          (read-string prompt initial-contents))))
6731    
6732  (defun message-use-alternative-email-as-from ()  (defun message-use-alternative-email-as-from ()
6733    (require 'mail-utils)    (require 'mail-utils)
# Line 4715  regexp varstr." Line 6747  regexp varstr."
6747        (goto-char (point-max))        (goto-char (point-max))
6748        (insert "From: " email "\n"))))        (insert "From: " email "\n"))))
6749    
6750    (defun message-options-get (symbol)
6751      (cdr (assq symbol message-options)))
6752    
6753    (defun message-options-set (symbol value)
6754      (let ((the-cons (assq symbol message-options)))
6755        (if the-cons
6756            (if value
6757                (setcdr the-cons value)
6758              (setq message-options (delq the-cons message-options)))
6759          (and value
6760               (push (cons symbol value) message-options))))
6761      value)
6762    
6763    (defun message-options-set-recipient ()
6764      (save-restriction
6765        (message-narrow-to-headers-or-head)
6766        (message-options-set 'message-sender
6767                             (mail-strip-quoted-names
6768                              (message-fetch-field "from")))
6769        (message-options-set 'message-recipients
6770                             (mail-strip-quoted-names
6771                              (let ((to (message-fetch-field "to"))
6772                                    (cc (message-fetch-field "cc"))
6773                                    (bcc (message-fetch-field "bcc")))
6774                                (concat
6775                                 (or to "")
6776                                 (if (and to cc) ", ")
6777                                 (or cc "")
6778                                 (if (and (or to cc) bcc) ", ")
6779                                 (or bcc "")))))))
6780    
6781    (defun message-hide-headers ()
6782      "Hide headers based on the `message-hidden-headers' variable."
6783      (let ((regexps (if (stringp message-hidden-headers)
6784                         (list message-hidden-headers)
6785                       message-hidden-headers))
6786            (inhibit-point-motion-hooks t)
6787            (after-change-functions nil))
6788        (when regexps
6789          (save-excursion
6790            (save-restriction
6791              (message-narrow-to-headers)
6792              (goto-char (point-min))
6793              (while (not (eobp))
6794                (if (not (message-hide-header-p regexps))
6795                    (message-next-header)
6796                  (let ((begin (point)))
6797                    (message-next-header)
6798                    (add-text-properties
6799                     begin (point)
6800                     '(invisible t message-hidden t))))))))))
6801    
6802    (defun message-hide-header-p (regexps)
6803      (let ((result nil)
6804            (reverse nil))
6805        (when (eq (car regexps) 'not)
6806          (setq reverse t)
6807          (pop regexps))
6808        (dolist (regexp regexps)
6809          (setq result (or result (looking-at regexp))))
6810        (if reverse
6811            (not result)
6812          result)))
6813    
6814    (when (featurep 'xemacs)
6815      (require 'messagexmas)
6816      (message-xmas-redefine))
6817    
6818  (provide 'message)  (provide 'message)
6819    
6820  (run-hooks 'message-load-hook)  (run-hooks 'message-load-hook)

Legend:
Removed from v.1.49.2.3  
changed lines
  Added in v.1.49.2.4

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