/[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.58 by monnier, Fri Mar 5 12:56:55 2004 UTC revision 1.58.2.1 by schwab, Thu Jul 22 16:45:49 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 'sha1 "sha1-el")
51      (autoload 'gnus-find-method-for-group "gnus")
52      (autoload 'nnvirtual-find-group-art "nnvirtual")
53      (autoload 'gnus-group-decoded-name "gnus-group"))
54    
55  (defgroup message '((user-mail-address custom-variable)  (defgroup message '((user-mail-address custom-variable)
56                      (user-full-name custom-variable))                      (user-full-name custom-variable))
# Line 123  mailbox format." Line 134  mailbox format."
134                  (function :tag "Other"))                  (function :tag "Other"))
135    :group 'message-sending)    :group 'message-sending)
136    
137    (defcustom message-fcc-externalize-attachments nil
138      "If non-nil, attachments are included as external parts in Fcc copies."
139      :type 'boolean
140      :group 'message-sending)
141    
142  (defcustom message-courtesy-message  (defcustom message-courtesy-message
143    "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"
144    "*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 146  If the string contains the format spec \
146  the article has been posted to will be inserted there.  the article has been posted to will be inserted there.
147  If this variable is nil, no such courtesy message will be added."  If this variable is nil, no such courtesy message will be added."
148    :group 'message-sending    :group 'message-sending
149    :type 'string)    :type '(radio (string :format "%t: %v\n" :size 0) (const nil)))
150    
151  (defcustom message-ignored-bounced-headers "^\\(Received\\|Return-Path\\):"  (defcustom message-ignored-bounced-headers
152      "^\\(Received\\|Return-Path\\|Delivered-To\\):"
153    "*Regexp that matches headers to be removed in resent bounced mail."    "*Regexp that matches headers to be removed in resent bounced mail."
154    :group 'message-interface    :group 'message-interface
155    :type 'regexp)    :type 'regexp)
# Line 156  Otherwise, most addresses look like `ang Line 173  Otherwise, most addresses look like `ang
173                   (const default))                   (const default))
174    :group 'message-headers)    :group 'message-headers)
175    
176  (defcustom message-syntax-checks nil  (defcustom message-insert-canlock t
177      "Whether to insert a Cancel-Lock header in news postings."
178      :version "21.3"
179      :group 'message-headers
180      :type 'boolean)
181    
182    (defcustom message-syntax-checks
183      (if message-insert-canlock '((sender . disabled)) nil)
184    ;; Guess this one shouldn't be easy to customize...    ;; Guess this one shouldn't be easy to customize...
185    "*Controls what syntax checks should not be performed on outgoing posts.    "*Controls what syntax checks should not be performed on outgoing posts.
186  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 193  Checks include `subject-cmsg', `multiple
193  `new-text', `quoting-style', `redirected-followup', `signature',  `new-text', `quoting-style', `redirected-followup', `signature',
194  `approved', `sender', `empty', `empty-headers', `message-id', `from',  `approved', `sender', `empty', `empty-headers', `message-id', `from',
195  `subject', `shorten-followup-to', `existing-newsgroups',  `subject', `shorten-followup-to', `existing-newsgroups',
196  `buffer-file-name', `unchanged', `newsgroups'."  `buffer-file-name', `unchanged', `newsgroups', `reply-to',
197    `continuation-headers', `long-header-lines', `invisible-text' and
198    `illegible-text'."
199    :group 'message-news    :group 'message-news
200    :type '(repeat sexp))                 ; Fixme: improve this    :type '(repeat sexp))                 ; Fixme: improve this
201    
202    (defcustom message-required-headers '((optional . References)
203                                          From)
204      "*Headers to be generated or prompted for when sending a message.
205    Also see `message-required-news-headers' and
206    `message-required-mail-headers'."
207      :group 'message-news
208      :group 'message-headers
209      :link '(custom-manual "(message)Message Headers")
210      :type '(repeat sexp))
211    
212    (defcustom message-draft-headers '(References From)
213      "*Headers to be generated when saving a draft message."
214      :group 'message-news
215      :group 'message-headers
216      :link '(custom-manual "(message)Message Headers")
217      :type '(repeat sexp))
218    
219  (defcustom message-required-news-headers  (defcustom message-required-news-headers
220    '(From Newsgroups Subject Date Message-ID    '(From Newsgroups Subject Date Message-ID
221           (optional . Organization) Lines           (optional . Organization)
222           (optional . User-Agent))           (optional . User-Agent))
223    "*Headers to be generated or prompted for when posting an article.    "*Headers to be generated or prompted for when posting an article.
224  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 227  User-Agent are optional.  If don't you w
227  header, remove it from this list."  header, remove it from this list."
228    :group 'message-news    :group 'message-news
229    :group 'message-headers    :group 'message-headers
230      :link '(custom-manual "(message)Message Headers")
231    :type '(repeat sexp))    :type '(repeat sexp))
232    
233  (defcustom message-required-mail-headers  (defcustom message-required-mail-headers
234    '(From Subject Date (optional . In-Reply-To) Message-ID Lines    '(From Subject Date (optional . In-Reply-To) Message-ID
235           (optional . User-Agent))           (optional . User-Agent))
236    "*Headers to be generated or prompted for when mailing a message.    "*Headers to be generated or prompted for when mailing a message.
237  RFC822 required that From, Date, To, Subject and Message-ID be  It is recommended that From, Date, To, Subject and Message-ID be
238  included.  Organization, Lines and User-Agent are optional."  included.  Organization and User-Agent are optional."
239    :group 'message-mail    :group 'message-mail
240    :group 'message-headers    :group 'message-headers
241      :link '(custom-manual "(message)Message Headers")
242    :type '(repeat sexp))    :type '(repeat sexp))
243    
244  (defcustom message-deletable-headers '(Message-ID Date Lines)  (defcustom message-deletable-headers '(Message-ID Date Lines)
245    "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."
246    :group 'message-headers    :group 'message-headers
247      :link '(custom-manual "(message)Message Headers")
248    :type 'sexp)    :type 'sexp)
249    
250  (defcustom message-ignored-news-headers  (defcustom message-ignored-news-headers
251    "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:"    "^NNTP-Posting-Host:\\|^Xref:\\|^[BGF]cc:\\|^Resent-Fcc:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:"
252    "*Regexp of headers to be removed unconditionally before posting."    "*Regexp of headers to be removed unconditionally before posting."
253    :group 'message-news    :group 'message-news
254    :group 'message-headers    :group 'message-headers
255      :link '(custom-manual "(message)Message Headers")
256    :type 'regexp)    :type 'regexp)
257    
258  (defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:"  (defcustom message-ignored-mail-headers
259      "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:\\|^X-Draft-From:\\|^X-Gnus-Agent-Meta-Information:"
260    "*Regexp of headers to be removed unconditionally before mailing."    "*Regexp of headers to be removed unconditionally before mailing."
261    :group 'message-mail    :group 'message-mail
262    :group 'message-headers    :group 'message-headers
263      :link '(custom-manual "(message)Mail Headers")
264    :type 'regexp)    :type 'regexp)
265    
266  (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:"
267    "*Header lines matching this regexp will be deleted before posting.    "*Header lines matching this regexp will be deleted before posting.
268  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
269  any confusion."  any confusion."
270    :group 'message-interface    :group 'message-interface
271      :link '(custom-manual "(message)Superseding")
272    :type 'regexp)    :type 'regexp)
273    
274  (defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*"  (defcustom message-subject-re-regexp
275      "^[ \t]*\\([Rr][Ee]\\(\\[[0-9]*\\]\\)*:[ \t]*\\)*[ \t]*"
276    "*Regexp matching \"Re: \" in the subject line."    "*Regexp matching \"Re: \" in the subject line."
277    :group 'message-various    :group 'message-various
278      :link '(custom-manual "(message)Message Headers")
279      :type 'regexp)
280    
281    ;;; Start of variables adopted from `message-utils.el'.
282    
283    (defcustom message-subject-trailing-was-query 'ask
284      "*What to do with trailing \"(was: <old subject>)\" in subject lines.
285    If nil, leave the subject unchanged.  If it is the symbol `ask', query
286    the user what do do.  In this case, the subject is matched against
287    `message-subject-trailing-was-ask-regexp'.  If
288    `message-subject-trailing-was-query' is t, always strip the trailing
289    old subject.  In this case, `message-subject-trailing-was-regexp' is
290    used."
291      :type '(choice (const :tag "never" nil)
292                     (const :tag "always strip" t)
293                     (const ask))
294      :link '(custom-manual "(message)Message Headers")
295      :group 'message-various)
296    
297    (defcustom message-subject-trailing-was-ask-regexp
298      "[ \t]*\\([[(]+[Ww][Aa][Ss][ \t]*.*[\])]+\\)"
299      "*Regexp matching \"(was: <old subject>)\" in the subject line.
300    
301    The function `message-strip-subject-trailing-was' uses this regexp if
302    `message-subject-trailing-was-query' is set to the symbol `ask'.  If
303    the variable is t instead of `ask', use
304    `message-subject-trailing-was-regexp' instead.
305    
306    It is okay to create some false positives here, as the user is asked."
307      :group 'message-various
308      :link '(custom-manual "(message)Message Headers")
309    :type 'regexp)    :type 'regexp)
310    
311    (defcustom message-subject-trailing-was-regexp
312      "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)"
313      "*Regexp matching \"(was: <old subject>)\" in the subject line.
314    
315    If `message-subject-trailing-was-query' is set to t, the subject is
316    matched against `message-subject-trailing-was-regexp' in
317    `message-strip-subject-trailing-was'.  You should use a regexp creating very
318    few false positives here."
319      :group 'message-various
320      :link '(custom-manual "(message)Message Headers")
321      :type 'regexp)
322    
323    ;; Fixme: Why are all these things autoloaded?
324    
325    ;;; marking inserted text
326    
327    ;;;###autoload
328    (defcustom message-mark-insert-begin
329      "--8<---------------cut here---------------start------------->8---\n"
330      "How to mark the beginning of some inserted text."
331      :type 'string
332      :link '(custom-manual "(message)Insertion Variables")
333      :group 'message-various)
334    
335    ;;;###autoload
336    (defcustom message-mark-insert-end
337      "--8<---------------cut here---------------end--------------->8---\n"
338      "How to mark the end of some inserted text."
339      :type 'string
340      :link '(custom-manual "(message)Insertion Variables")
341      :group 'message-various)
342    
343    ;;;###autoload
344    (defcustom message-archive-header
345      "X-No-Archive: Yes\n"
346      "Header to insert when you don't want your article to be archived.
347    Archives \(such as groups.google.com\) respect this header."
348      :type 'string
349      :link '(custom-manual "(message)Header Commands")
350      :group 'message-various)
351    
352    ;;;###autoload
353    (defcustom message-archive-note
354      "X-No-Archive: Yes - save http://groups.google.com/"
355      "Note to insert why you wouldn't want this posting archived.
356    If nil, don't insert any text in the body."
357      :type '(radio (string :format "%t: %v\n" :size 0)
358                    (const nil))
359      :link '(custom-manual "(message)Header Commands")
360      :group 'message-various)
361    
362    ;;; Crossposts and Followups
363    ;; inspired by JoH-followup-to by Jochem Huhman <joh  at gmx.de>
364    ;; new suggestions by R. Weikusat <rw at another.de>
365    
366    (defvar message-cross-post-old-target nil
367      "Old target for cross-posts or follow-ups.")
368    (make-variable-buffer-local 'message-cross-post-old-target)
369    
370    ;;;###autoload
371    (defcustom message-cross-post-default t
372      "When non-nil `message-cross-post-followup-to' will perform a crosspost.
373    If nil, `message-cross-post-followup-to' will only do a followup.  Note that
374    you can explicitly override this setting by calling
375    `message-cross-post-followup-to' with a prefix."
376      :type 'boolean
377      :group 'message-various)
378    
379    ;;;###autoload
380    (defcustom message-cross-post-note
381      "Crosspost & Followup-To: "
382      "Note to insert before signature to notify of cross-post and follow-up."
383      :type 'string
384      :group 'message-various)
385    
386    ;;;###autoload
387    (defcustom message-followup-to-note
388      "Followup-To: "
389      "Note to insert before signature to notify of follow-up only."
390      :type 'string
391      :group 'message-various)
392    
393    ;;;###autoload
394    (defcustom message-cross-post-note-function
395      'message-cross-post-insert-note
396      "Function to use to insert note about Crosspost or Followup-To.
397    The function will be called with four arguments.  The function should not only
398    insert a note, but also ensure old notes are deleted.  See the documentation
399    for `message-cross-post-insert-note'."
400      :type 'function
401      :group 'message-various)
402    
403    ;;; End of variables adopted from `message-utils.el'.
404    
405  ;;;###autoload  ;;;###autoload
406  (defcustom message-signature-separator "^-- *$"  (defcustom message-signature-separator "^-- *$"
407    "Regexp matching the signature separator."    "Regexp matching the signature separator."
408    :type 'regexp    :type 'regexp
409      :link '(custom-manual "(message)Various Message Variables")
410    :group 'message-various)    :group 'message-various)
411    
412  (defcustom message-elide-ellipsis "\n[...]\n\n"  (defcustom message-elide-ellipsis "\n[...]\n\n"
413    "*The string which is inserted for elided text."    "*The string which is inserted for elided text."
414    :type 'string    :type 'string
415      :link '(custom-manual "(message)Various Commands")
416    :group 'message-various)    :group 'message-various)
417    
418  (defcustom message-interactive nil  (defcustom message-interactive t
419    "Non-nil means when sending a message wait for and display errors.    "Non-nil means when sending a message wait for and display errors.
420  nil means let mailer mail back a message to report errors."  nil means let mailer mail back a message to report errors."
421    :group 'message-sending    :group 'message-sending
422    :group 'message-mail    :group 'message-mail
423      :link '(custom-manual "(message)Sending Variables")
424    :type 'boolean)    :type 'boolean)
425    
426  (defcustom message-generate-new-buffers 'unique  (defcustom message-generate-new-buffers 'unique
# Line 250  If this is a function, call that functio Line 429  If this is a function, call that functio
429  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
430  should return the new buffer name."  should return the new buffer name."
431    :group 'message-buffers    :group 'message-buffers
432      :link '(custom-manual "(message)Message Buffers")
433    :type '(choice (const :tag "off" nil)    :type '(choice (const :tag "off" nil)
434                   (const :tag "unique" unique)                   (const :tag "unique" unique)
435                   (const :tag "unsent" unsent)                   (const :tag "unsent" unsent)
# Line 258  should return the new buffer name." Line 438  should return the new buffer name."
438  (defcustom message-kill-buffer-on-exit nil  (defcustom message-kill-buffer-on-exit nil
439    "*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."
440    :group 'message-buffers    :group 'message-buffers
441      :link '(custom-manual "(message)Message Buffers")
442    :type 'boolean)    :type 'boolean)
443    
444  (eval-when-compile  (eval-when-compile
# Line 278  If t, use `message-user-organization-fil Line 459  If t, use `message-user-organization-fil
459  (defcustom message-user-organization-file "/usr/lib/news/organization"  (defcustom message-user-organization-file "/usr/lib/news/organization"
460    "*Local news organization file."    "*Local news organization file."
461    :type 'file    :type 'file
462      :link '(custom-manual "(message)News Headers")
463    :group 'message-headers)    :group 'message-headers)
464    
465  (defcustom message-make-forward-subject-function  (defcustom message-make-forward-subject-function
466    'message-forward-subject-author-subject    #'message-forward-subject-name-subject
467    "*List of functions called to generate subject headers for forwarded messages.    "*List of functions called to generate subject headers for forwarded messages.
468  The subject generated by the previous function is passed into each  The subject generated by the previous function is passed into each
469  successive function.  successive function.
470    
471  The provided functions are:  The provided functions are:
472    
473  * `message-forward-subject-author-subject' (Source of article (author or  * `message-forward-subject-author-subject' Source of article (author or
474        newsgroup)), in brackets followed by the subject        newsgroup), in brackets followed by the subject
475  * `message-forward-subject-fwd' (Subject of article with 'Fwd:' prepended  * `message-forward-subject-name-subject' Source of article (name of author
476          or newsgroup), in brackets followed by the subject
477    * `message-forward-subject-fwd' Subject of article with 'Fwd:' prepended
478        to it."        to it."
479    :group 'message-forwarding    :group 'message-forwarding
480      :link '(custom-manual "(message)Forwarding")
481    :type '(radio (function-item message-forward-subject-author-subject)    :type '(radio (function-item message-forward-subject-author-subject)
482                  (function-item message-forward-subject-fwd)                  (function-item message-forward-subject-fwd)
483                    (function-item message-forward-subject-name-subject)
484                  (repeat :tag "List of functions" function)))                  (repeat :tag "List of functions" function)))
485    
486  (defcustom message-forward-as-mime t  (defcustom message-forward-as-mime t
487    "*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.
488    Otherwise, directly inline the old message in the forwarded message."
489    :version "21.1"    :version "21.1"
490    :group 'message-forwarding    :group 'message-forwarding
491      :link '(custom-manual "(message)Forwarding")
492    :type 'boolean)    :type 'boolean)
493    
494  (defcustom message-forward-show-mml t  (defcustom message-forward-show-mml 'best
495    "*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).
496    Otherwise, forwarded messages are unchanged.
497    Can also be the symbol `best' to indicate that MML should be
498    used, except when it is a bad idea to use MML.  One example where
499    it is a bad idea is when forwarding a signed or encrypted
500    message, because converting MIME to MML would invalidate the
501    digital signature."
502    :version "21.1"    :version "21.1"
503    :group 'message-forwarding    :group 'message-forwarding
504    :type 'boolean)    :type '(choice (const :tag "use MML" t)
505                     (const :tag "don't use MML " nil)
506                     (const :tag "use MML when appropriate" best)))
507    
508  (defcustom message-forward-before-signature t  (defcustom message-forward-before-signature t
509    "*If non-nil, put forwarded message before signature, else after."    "*Non-nil means put forwarded message before signature, else after."
510    :group 'message-forwarding    :group 'message-forwarding
511    :type 'boolean)    :type 'boolean)
512    
513  (defcustom message-wash-forwarded-subjects nil  (defcustom message-wash-forwarded-subjects nil
514    "*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.
515    Done before generating the new subject of a forward."
516    :group 'message-forwarding    :group 'message-forwarding
517      :link '(custom-manual "(message)Forwarding")
518    :type 'boolean)    :type 'boolean)
519    
520  (defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:"  (defcustom message-ignored-resent-headers "^Return-receipt\\|^X-Gnus\\|^Gnus-Warning:\\|^>?From "
521    "*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."
522    :group 'message-interface    :group 'message-interface
523      :link '(custom-manual "(message)Resending")
524    :type 'regexp)    :type 'regexp)
525    
526  (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 533  The provided functions are:
533  (defcustom message-ignored-cited-headers "."  (defcustom message-ignored-cited-headers "."
534    "*Delete these headers from the messages you yank."    "*Delete these headers from the messages you yank."
535    :group 'message-insertion    :group 'message-insertion
536      :link '(custom-manual "(message)Insertion Variables")
537      :type 'regexp)
538    
539    (defcustom message-cite-prefix-regexp
540      (if (string-match "[[:digit:]]" "1") ;; support POSIX?
541          "\\([ \t]*[-_.[:word:]]+>+\\|[ \t]*[]>|}+]\\)+"
542        ;; ?-, ?_ or ?. MUST NOT be in syntax entry w.
543        (let ((old-table (syntax-table))
544              non-word-constituents)
545          (set-syntax-table text-mode-syntax-table)
546          (setq non-word-constituents
547                (concat
548                 (if (string-match "\\w" "-")  "" "-")
549                 (if (string-match "\\w" "_")  "" "_")
550                 (if (string-match "\\w" ".")  "" ".")))
551          (set-syntax-table old-table)
552          (if (equal non-word-constituents "")
553              "\\([ \t]*\\(\\w\\)+>+\\|[ \t]*[]>|}+]\\)+"
554            (concat "\\([ \t]*\\(\\w\\|["
555                    non-word-constituents
556                    "]\\)+>+\\|[ \t]*[]>|}+]\\)+"))))
557      "*Regexp matching the longest possible citation prefix on a line."
558      :group 'message-insertion
559      :link '(custom-manual "(message)Insertion Variables")
560    :type 'regexp)    :type 'regexp)
561    
562  (defcustom message-cancel-message "I am canceling my own article.\n"  (defcustom message-cancel-message "I am canceling my own article.\n"
563    "Message to be inserted in the cancel message."    "Message to be inserted in the cancel message."
564    :group 'message-interface    :group 'message-interface
565      :link '(custom-manual "(message)Canceling News")
566    :type 'string)    :type 'string)
567    
568  ;; Useful to set in site-init.el  ;; Useful to set in site-init.el
# Line 350  variable `mail-header-separator'. Line 574  variable `mail-header-separator'.
574    
575  Valid values include `message-send-mail-with-sendmail' (the default),  Valid values include `message-send-mail-with-sendmail' (the default),
576  `message-send-mail-with-mh', `message-send-mail-with-qmail',  `message-send-mail-with-mh', `message-send-mail-with-qmail',
577  `smtpmail-send-it' and `feedmail-send-it'.  `message-smtpmail-send-it', `smtpmail-send-it' and `feedmail-send-it'.
578    
579  See also `send-mail-function'."  See also `send-mail-function'."
580    :type '(radio (function-item message-send-mail-with-sendmail)    :type '(radio (function-item message-send-mail-with-sendmail)
581                  (function-item message-send-mail-with-mh)                  (function-item message-send-mail-with-mh)
582                  (function-item message-send-mail-with-qmail)                  (function-item message-send-mail-with-qmail)
583                    (function-item message-smtpmail-send-it)
584                  (function-item smtpmail-send-it)                  (function-item smtpmail-send-it)
585                  (function-item feedmail-send-it)                  (function-item feedmail-send-it)
586                  (function :tag "Other"))                  (function :tag "Other"))
587    :group 'message-sending    :group 'message-sending
588      :link '(custom-manual "(message)Mail Variables")
589    :group 'message-mail)    :group 'message-mail)
590    
591  (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 594  The headers should be delimited by a lin
594  variable `mail-header-separator'."  variable `mail-header-separator'."
595    :group 'message-sending    :group 'message-sending
596    :group 'message-news    :group 'message-news
597      :link '(custom-manual "(message)News Variables")
598    :type 'function)    :type 'function)
599    
600  (defcustom message-reply-to-function nil  (defcustom message-reply-to-function nil
# Line 375  variable `mail-header-separator'." Line 602  variable `mail-header-separator'."
602  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
603  and respond with new To and Cc headers."  and respond with new To and Cc headers."
604    :group 'message-interface    :group 'message-interface
605      :link '(custom-manual "(message)Reply")
606    :type '(choice function (const nil)))    :type '(choice function (const nil)))
607    
608  (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 610  and respond with new To and Cc headers."
610  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
611  and respond with new To and Cc headers."  and respond with new To and Cc headers."
612    :group 'message-interface    :group 'message-interface
613      :link '(custom-manual "(message)Wide Reply")
614    :type '(choice function (const nil)))    :type '(choice function (const nil)))
615    
616  (defcustom message-followup-to-function nil  (defcustom message-followup-to-function nil
# Line 389  and respond with new To and Cc headers." Line 618  and respond with new To and Cc headers."
618  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
619  and respond with new To and Cc headers."  and respond with new To and Cc headers."
620    :group 'message-interface    :group 'message-interface
621      :link '(custom-manual "(message)Followup")
622    :type '(choice function (const nil)))    :type '(choice function (const nil)))
623    
624  (defcustom message-use-followup-to 'ask  (defcustom message-use-followup-to 'ask
# Line 398  query before using the \"poster\" value. Line 628  query before using the \"poster\" value.
628  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
629  `use', always use the value."  `use', always use the value."
630    :group 'message-interface    :group 'message-interface
631      :link '(custom-manual "(message)Followup")
632    :type '(choice (const :tag "ignore" nil)    :type '(choice (const :tag "ignore" nil)
633                     (const :tag "use & query" t)
634                   (const use)                   (const use)
635                   (const ask)))                   (const ask)))
636    
637    (defcustom message-use-mail-followup-to 'use
638      "*Specifies what to do with Mail-Followup-To header.
639    If nil, always ignore the header.  If it is the symbol `ask', always
640    query the user whether to use the value.  If it is the symbol `use',
641    always use the value."
642      :group 'message-interface
643      :link '(custom-manual "(message)Mailing Lists")
644      :type '(choice (const :tag "ignore" nil)
645                     (const use)
646                     (const ask)))
647    
648    (defcustom message-subscribed-address-functions nil
649      "*Specifies functions for determining list subscription.
650    If nil, do not attempt to determine list subscription with functions.
651    If non-nil, this variable contains a list of functions which return
652    regular expressions to match lists.  These functions can be used in
653    conjunction with `message-subscribed-regexps' and
654    `message-subscribed-addresses'."
655      :group 'message-interface
656      :link '(custom-manual "(message)Mailing Lists")
657      :type '(repeat sexp))
658    
659    (defcustom message-subscribed-address-file nil
660      "*A file containing addresses the user is subscribed to.
661    If nil, do not look at any files to determine list subscriptions.  If
662    non-nil, each line of this file should be a mailing list address."
663      :group 'message-interface
664      :link '(custom-manual "(message)Mailing Lists")
665      :type '(radio (file :format "%t: %v\n" :size 0)
666                    (const nil)))
667    
668    (defcustom message-subscribed-addresses nil
669      "*Specifies a list of addresses the user is subscribed to.
670    If nil, do not use any predefined list subscriptions.  This list of
671    addresses can be used in conjunction with
672    `message-subscribed-address-functions' and `message-subscribed-regexps'."
673      :group 'message-interface
674      :link '(custom-manual "(message)Mailing Lists")
675      :type '(repeat string))
676    
677    (defcustom message-subscribed-regexps nil
678      "*Specifies a list of addresses the user is subscribed to.
679    If nil, do not use any predefined list subscriptions.  This list of
680    regular expressions can be used in conjunction with
681    `message-subscribed-address-functions' and `message-subscribed-addresses'."
682      :group 'message-interface
683      :link '(custom-manual "(message)Mailing Lists")
684      :type '(repeat regexp))
685    
686    (defcustom message-allow-no-recipients 'ask
687      "Specifies what to do when there are no recipients other than Gcc/Fcc.
688    If it is the symbol `always', the posting is allowed.  If it is the
689    symbol `never', the posting is not allowed.  If it is the symbol
690    `ask', you are prompted."
691      :group 'message-interface
692      :link '(custom-manual "(message)Message Headers")
693      :type '(choice (const always)
694                     (const never)
695                     (const ask)))
696    
697  (defcustom message-sendmail-f-is-evil nil  (defcustom message-sendmail-f-is-evil nil
698    "*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.
699  Doing so would be even more evil than leaving it out."  Doing so would be even more evil than leaving it out."
700    :group 'message-sending    :group 'message-sending
701      :link '(custom-manual "(message)Mail Variables")
702    :type 'boolean)    :type 'boolean)
703    
704    (defcustom message-sendmail-envelope-from nil
705      "*Envelope-from when sending mail with sendmail.
706    If this is nil, use `user-mail-address'.  If it is the symbol
707    `header', use the From: header of the message."
708      :type '(choice (string :tag "From name")
709                     (const :tag "Use From: header from message" header)
710                     (const :tag "Use `user-mail-address'" nil))
711      :link '(custom-manual "(message)Mail Variables")
712      :group 'message-sending)
713    
714  ;; qmail-related stuff  ;; qmail-related stuff
715  (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"  (defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"
716    "Location of the qmail-inject program."    "Location of the qmail-inject program."
717    :group 'message-sending    :group 'message-sending
718      :link '(custom-manual "(message)Mail Variables")
719    :type 'file)    :type 'file)
720    
721  (defcustom message-qmail-inject-args nil  (defcustom message-qmail-inject-args nil
722    "Arguments passed to qmail-inject programs.    "Arguments passed to qmail-inject programs.
723  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
724    may also be a function.
725    
726  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
727  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
728  might set this variable to '(\"-f\" \"you@some.where\")."  might set this variable to '(\"-f\" \"you@some.where\")."
729    :group 'message-sending    :group 'message-sending
730    :type '(repeat string))    :link '(custom-manual "(message)Mail Variables")
731      :type '(choice (function)
732                     (repeat string)))
733    
734  (defvar message-cater-to-broken-inn t  (defvar message-cater-to-broken-inn t
735    "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 756  variable isn't used."
756    ;; create a dependence to `gnus.el'.    ;; create a dependence to `gnus.el'.
757    :type 'sexp)    :type 'sexp)
758    
759  (defcustom message-generate-headers-first nil  ;; FIXME: This should be a temporary workaround until someone implements a
760    "*If non-nil, generate all possible headers before composing."  ;; proper solution.  If a crash happens while replying, the auto-save file
761    ;; will *not* have a `References:' header if `message-generate-headers-first'
762    ;; is nil.  See: http://article.gmane.org/gmane.emacs.gnus.general/51138
763    (defcustom message-generate-headers-first '(references)
764      "Which headers should be generated before starting to compose a message.
765    If `t', generate all required headers.  This can also be a list of headers to
766    generate.  The variables `message-required-news-headers' and
767    `message-required-mail-headers' specify which headers to generate.
768    
769    Note that the variable `message-deletable-headers' specifies headers which
770    are to be deleted and then re-generated before sending, so this variable
771    will not have a visible effect for those headers."
772    :group 'message-headers    :group 'message-headers
773    :type 'boolean)    :link '(custom-manual "(message)Message Headers")
774      :type '(choice (const :tag "None" nil)
775                     (const :tag "References" '(references))
776                     (const :tag "All" t)
777                     (repeat (sexp :tag "Header"))))
778    
779  (defcustom message-setup-hook nil  (defcustom message-setup-hook nil
780    "Normal hook, run each time a new outgoing message is initialized.    "Normal hook, run each time a new outgoing message is initialized.
781  The function `message-setup' runs this hook."  The function `message-setup' runs this hook."
782    :group 'message-various    :group 'message-various
783      :link '(custom-manual "(message)Various Message Variables")
784    :type 'hook)    :type 'hook)
785    
786  (defcustom message-cancel-hook nil  (defcustom message-cancel-hook nil
787    "Hook run when cancelling articles."    "Hook run when cancelling articles."
788    :group 'message-various    :group 'message-various
789      :link '(custom-manual "(message)Various Message Variables")
790    :type 'hook)    :type 'hook)
791    
792  (defcustom message-signature-setup-hook nil  (defcustom message-signature-setup-hook nil
# Line 470  The function `message-setup' runs this h Line 794  The function `message-setup' runs this h
794  It is run after the headers have been inserted and before  It is run after the headers have been inserted and before
795  the signature is inserted."  the signature is inserted."
796    :group 'message-various    :group 'message-various
797      :link '(custom-manual "(message)Various Message Variables")
798    :type 'hook)    :type 'hook)
799    
800  (defcustom message-mode-hook nil  (defcustom message-mode-hook nil
# Line 485  the signature is inserted." Line 810  the signature is inserted."
810  (defcustom message-header-setup-hook nil  (defcustom message-header-setup-hook nil
811    "Hook called narrowed to the headers when setting up a message buffer."    "Hook called narrowed to the headers when setting up a message buffer."
812    :group 'message-various    :group 'message-various
813      :link '(custom-manual "(message)Various Message Variables")
814    :type 'hook)    :type 'hook)
815    
816    (defcustom message-minibuffer-local-map
817      (let ((map (make-sparse-keymap 'message-minibuffer-local-map)))
818        (set-keymap-parent map minibuffer-local-map)
819        map)
820      "Keymap for `message-read-from-minibuffer'.")
821    
822  ;;;###autoload  ;;;###autoload
823  (defcustom message-citation-line-function 'message-insert-citation-line  (defcustom message-citation-line-function 'message-insert-citation-line
824    "*Function called to insert the \"Whomever writes:\" line."    "*Function called to insert the \"Whomever writes:\" line.
825    
826    Note that Gnus provides a feature where the reader can click on
827    `writes:' to hide the cited text.  If you change this line too much,
828    people who read your message will have to change their Gnus
829    configuration.  See the variable `gnus-cite-attribution-suffix'."
830    :type 'function    :type 'function
831      :link '(custom-manual "(message)Insertion Variables")
832    :group 'message-insertion)    :group 'message-insertion)
833    
834  ;;;###autoload  ;;;###autoload
835  (defcustom message-yank-prefix "> "  (defcustom message-yank-prefix "> "
836    "*Prefix inserted on the lines of yanked messages."    "*Prefix inserted on the lines of yanked messages.
837    Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
838    See also `message-yank-cited-prefix'."
839      :type 'string
840      :link '(custom-manual "(message)Insertion Variables")
841      :group 'message-insertion)
842    
843    (defcustom message-yank-cited-prefix ">"
844      "*Prefix inserted on cited or empty lines of yanked messages.
845    Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
846    See also `message-yank-prefix'."
847    :type 'string    :type 'string
848      :link '(custom-manual "(message)Insertion Variables")
849    :group 'message-insertion)    :group 'message-insertion)
850    
851  (defcustom message-indentation-spaces 3  (defcustom message-indentation-spaces 3
852    "*Number of spaces to insert at the beginning of each cited line.    "*Number of spaces to insert at the beginning of each cited line.
853  Used by `message-yank-original' via `message-yank-cite'."  Used by `message-yank-original' via `message-yank-cite'."
854    :group 'message-insertion    :group 'message-insertion
855      :link '(custom-manual "(message)Insertion Variables")
856    :type 'integer)    :type 'integer)
857    
858  ;;;###autoload  ;;;###autoload
# Line 515  Note that `message-cite-original' uses ` Line 865  Note that `message-cite-original' uses `
865                  (function-item message-cite-original-without-signature)                  (function-item message-cite-original-without-signature)
866                  (function-item sc-cite-original)                  (function-item sc-cite-original)
867                  (function :tag "Other"))                  (function :tag "Other"))
868      :link '(custom-manual "(message)Insertion Variables")
869    :group 'message-insertion)    :group 'message-insertion)
870    
871  ;;;###autoload  ;;;###autoload
# Line 524  This can also be a list of functions.  E Line 875  This can also be a list of functions.  E
875  citation between (point) and (mark t).  And each function should leave  citation between (point) and (mark t).  And each function should leave
876  point and mark around the citation text as modified."  point and mark around the citation text as modified."
877    :type 'function    :type 'function
878      :link '(custom-manual "(message)Insertion Variables")
879    :group 'message-insertion)    :group 'message-insertion)
880    
 (defvar message-abbrevs-loaded nil)  
   
881  ;;;###autoload  ;;;###autoload
882  (defcustom message-signature t  (defcustom message-signature t
883    "*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 885  If t, the `message-signature-file' file
885  If a function, the result from the function will be used instead.  If a function, the result from the function will be used instead.
886  If a form, the result from the form will be used instead."  If a form, the result from the form will be used instead."
887    :type 'sexp    :type 'sexp
888      :link '(custom-manual "(message)Insertion Variables")
889    :group 'message-insertion)    :group 'message-insertion)
890    
891  ;;;###autoload  ;;;###autoload
# Line 543  If a form, the result from the form will Line 894  If a form, the result from the form will
894  Ignored if the named file doesn't exist.  Ignored if the named file doesn't exist.
895  If nil, don't insert a signature."  If nil, don't insert a signature."
896    :type '(choice file (const :tags "None" nil))    :type '(choice file (const :tags "None" nil))
897      :link '(custom-manual "(message)Insertion Variables")
898      :group 'message-insertion)
899    
900    ;;;###autoload
901    (defcustom message-signature-insert-empty-line t
902      "*If non-nil, insert an empty line before the signature separator."
903      :type 'boolean
904      :link '(custom-manual "(message)Insertion Variables")
905    :group 'message-insertion)    :group 'message-insertion)
906    
907  (defcustom message-distribution-function nil  (defcustom message-distribution-function nil
908    "*Function called to return a Distribution header."    "*Function called to return a Distribution header."
909    :group 'message-news    :group 'message-news
910    :group 'message-headers    :group 'message-headers
911      :link '(custom-manual "(message)News Headers")
912    :type '(choice function (const nil)))    :type '(choice function (const nil)))
913    
914  (defcustom message-expires 14  (defcustom message-expires 14
# Line 569  If stringp, use this; if non-nil, use no Line 929  If stringp, use this; if non-nil, use no
929                   (sexp :tag "none" :format "%t" t)))                   (sexp :tag "none" :format "%t" t)))
930    
931  (defvar message-reply-buffer nil)  (defvar message-reply-buffer nil)
932  (defvar message-reply-headers nil)  (defvar message-reply-headers nil
933      "The headers of the current replied article.
934    It is a vector of the following headers:
935    \[number subject from date id references chars lines xref extra].")
936  (defvar message-newsreader nil)  (defvar message-newsreader nil)
937  (defvar message-mailer nil)  (defvar message-mailer nil)
938  (defvar message-sent-message-via nil)  (defvar message-sent-message-via nil)
# Line 594  If stringp, use this; if non-nil, use no Line 957  If stringp, use this; if non-nil, use no
957  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
958  these lines."  these lines."
959    :group 'message-headers    :group 'message-headers
960      :link '(custom-manual "(message)Message Headers")
961    :type 'message-header-lines)    :type 'message-header-lines)
962    
963  (defcustom message-default-mail-headers ""  (defcustom message-default-mail-headers ""
964    "*A string of header lines to be inserted in outgoing mails."    "*A string of header lines to be inserted in outgoing mails."
965    :group 'message-headers    :group 'message-headers
966    :group 'message-mail    :group 'message-mail
967      :link '(custom-manual "(message)Mail Headers")
968    :type 'message-header-lines)    :type 'message-header-lines)
969    
970  (defcustom message-default-news-headers ""  (defcustom message-default-news-headers ""
971    "*A string of header lines to be inserted in outgoing news articles."    "*A string of header lines to be inserted in outgoing news articles."
972    :group 'message-headers    :group 'message-headers
973    :group 'message-news    :group 'message-news
974      :link '(custom-manual "(message)News Headers")
975    :type 'message-header-lines)    :type 'message-header-lines)
976    
977  ;; Note: could use /usr/ucb/mail instead of sendmail;  ;; Note: could use /usr/ucb/mail instead of sendmail;
# Line 633  these lines." Line 999  these lines."
999  The value should be an expression to test whether the problem will  The value should be an expression to test whether the problem will
1000  actually occur."  actually occur."
1001    :group 'message-sending    :group 'message-sending
1002      :link '(custom-manual "(message)Mail Variables")
1003    :type 'sexp)    :type 'sexp)
1004    
1005  ;;;###autoload  ;;;###autoload
# Line 671  mail aliases off." Line 1038  mail aliases off."
1038    "*Directory where Message auto-saves buffers if Gnus isn't running.    "*Directory where Message auto-saves buffers if Gnus isn't running.
1039  If nil, Message won't auto-save."  If nil, Message won't auto-save."
1040    :group 'message-buffers    :group 'message-buffers
1041      :link '(custom-manual "(message)Various Message Variables")
1042    :type '(choice directory (const :tag "Don't auto-save" nil)))    :type '(choice directory (const :tag "Don't auto-save" nil)))
1043    
 (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)))  
   
1044  (defcustom message-default-charset  (defcustom message-default-charset
1045    (and (not (mm-multibyte-p)) 'iso-8859-1)    (and (not (mm-multibyte-p)) 'iso-8859-1)
1046    "Default charset used in non-MULE Emacsen.    "Default charset used in non-MULE Emacsen.
1047  If nil, you might be asked to input the charset."  If nil, you might be asked to input the charset."
1048    :version "21.1"    :version "21.1"
1049    :group 'message    :group 'message
1050      :link '(custom-manual "(message)Various Message Variables")
1051    :type 'symbol)    :type 'symbol)
1052    
1053  (defcustom message-dont-reply-to-names  (defcustom message-dont-reply-to-names
1054    (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names)    (and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names)
1055    "*A regexp specifying names to prune when doing wide replies.    "*A regexp specifying addresses to prune when doing wide replies.
1056  A value of nil means exclude your own name only."  A value of nil means exclude your own user name only."
1057    :version "21.1"    :version "21.1"
1058    :group 'message    :group 'message
1059      :link '(custom-manual "(message)Wide Reply")
1060    :type '(choice (const :tag "Yourself" nil)    :type '(choice (const :tag "Yourself" nil)
1061                   regexp))                   regexp))
1062    
1063    (defvar message-shoot-gnksa-feet nil
1064      "*A list of GNKSA feet you are allowed to shoot.
1065    Gnus gives you all the opportunity you could possibly want for
1066    shooting yourself in the foot.  Also, Gnus allows you to shoot the
1067    feet of Good Net-Keeping Seal of Approval.  The following are foot
1068    candidates:
1069    `empty-article'     Allow you to post an empty article;
1070    `quoted-text-only'  Allow you to post quoted text only;
1071    `multiple-copies'   Allow you to post multiple copies;
1072    `cancel-messages'   Allow you to cancel or supersede messages from
1073                        your other email addresses.")
1074    
1075    (defsubst message-gnksa-enable-p (feature)
1076      (or (not (listp message-shoot-gnksa-feet))
1077          (memq feature message-shoot-gnksa-feet)))
1078    
1079    (defcustom message-hidden-headers nil
1080      "Regexp of headers to be hidden when composing new messages.
1081    This can also be a list of regexps to match headers.  Or a list
1082    starting with `not' and followed by regexps."
1083      :group 'message
1084      :link '(custom-manual "(message)Message Headers")
1085      :type '(repeat regexp))
1086    
1087  ;;; Internal variables.  ;;; Internal variables.
1088  ;;; Well, not really internal.  ;;; Well, not really internal.
1089    
# Line 709  A value of nil means exclude your own na Line 1095  A value of nil means exclude your own na
1095      table)      table)
1096    "Syntax table used while in Message mode.")    "Syntax table used while in Message mode.")
1097    
 (defvar message-mode-abbrev-table text-mode-abbrev-table  
   "Abbrev table used in Message mode buffers.  
 Defaults to `text-mode-abbrev-table'.")  
   
1098  (defface message-header-to-face  (defface message-header-to-face
1099    '((((class color)    '((((class color)
1100        (background dark))        (background dark))
1101       (:foreground "green2" :weight bold))       (:foreground "green2" :bold t))
1102      (((class color)      (((class color)
1103        (background light))        (background light))
1104       (:foreground "MidnightBlue" :weight bold))       (:foreground "MidnightBlue" :bold t))
1105      (t      (t
1106       (:weight bold :slant italic)))       (:bold t :italic t)))
1107    "Face used for displaying From headers."    "Face used for displaying From headers."
1108    :group 'message-faces)    :group 'message-faces)
1109    
1110  (defface message-header-cc-face  (defface message-header-cc-face
1111    '((((class color)    '((((class color)
1112        (background dark))        (background dark))
1113       (:foreground "green4" :weight bold))       (:foreground "green4" :bold t))
1114      (((class color)      (((class color)
1115        (background light))        (background light))
1116       (:foreground "MidnightBlue"))       (:foreground "MidnightBlue"))
1117      (t      (t
1118       (:weight bold)))       (:bold t)))
1119    "Face used for displaying Cc headers."    "Face used for displaying Cc headers."
1120    :group 'message-faces)    :group 'message-faces)
1121    
# Line 743  Defaults to `text-mode-abbrev-table'.") Line 1125  Defaults to `text-mode-abbrev-table'.")
1125       (:foreground "green3"))       (:foreground "green3"))
1126      (((class color)      (((class color)
1127        (background light))        (background light))
1128       (:foreground "navy blue" :weight bold))       (:foreground "navy blue" :bold t))
1129      (t      (t
1130       (:weight bold)))       (:bold t)))
1131    "Face used for displaying subject headers."    "Face used for displaying subject headers."
1132    :group 'message-faces)    :group 'message-faces)
1133    
1134  (defface message-header-newsgroups-face  (defface message-header-newsgroups-face
1135    '((((class color)    '((((class color)
1136        (background dark))        (background dark))
1137       (:foreground "yellow" :weight bold :slant italic))       (:foreground "yellow" :bold t :italic t))
1138      (((class color)      (((class color)
1139        (background light))        (background light))
1140       (:foreground "blue4" :weight bold :slant italic))       (:foreground "blue4" :bold t :italic t))
1141      (t      (t
1142       (:weight bold :slant italic)))       (:bold t :italic t)))
1143    "Face used for displaying newsgroups headers."    "Face used for displaying newsgroups headers."
1144    :group 'message-faces)    :group 'message-faces)
1145    
# Line 769  Defaults to `text-mode-abbrev-table'.") Line 1151  Defaults to `text-mode-abbrev-table'.")
1151        (background light))        (background light))
1152       (:foreground "steel blue"))       (:foreground "steel blue"))
1153      (t      (t
1154       (:weight bold :slant italic)))       (:bold t :italic t)))
1155    "Face used for displaying newsgroups headers."    "Face used for displaying newsgroups headers."
1156    :group 'message-faces)    :group 'message-faces)
1157    
# Line 781  Defaults to `text-mode-abbrev-table'.") Line 1163  Defaults to `text-mode-abbrev-table'.")
1163        (background light))        (background light))
1164       (:foreground "cornflower blue"))       (:foreground "cornflower blue"))
1165      (t      (t
1166       (:weight bold)))       (:bold t)))
1167    "Face used for displaying header names."    "Face used for displaying header names."
1168    :group 'message-faces)    :group 'message-faces)
1169    
# Line 793  Defaults to `text-mode-abbrev-table'.") Line 1175  Defaults to `text-mode-abbrev-table'.")
1175        (background light))        (background light))
1176       (:foreground "blue"))       (:foreground "blue"))
1177      (t      (t
1178       (:weight bold)))       (:bold t)))
1179    "Face used for displaying X-Header headers."    "Face used for displaying X-Header headers."
1180    :group 'message-faces)    :group 'message-faces)
1181    
# Line 805  Defaults to `text-mode-abbrev-table'.") Line 1187  Defaults to `text-mode-abbrev-table'.")
1187        (background light))        (background light))
1188       (:foreground "brown"))       (:foreground "brown"))
1189      (t      (t
1190       (:weight bold)))       (:bold t)))
1191    "Face used for displaying the separator."    "Face used for displaying the separator."
1192    :group 'message-faces)    :group 'message-faces)
1193    
# Line 817  Defaults to `text-mode-abbrev-table'.") Line 1199  Defaults to `text-mode-abbrev-table'.")
1199        (background light))        (background light))
1200       (:foreground "red"))       (:foreground "red"))
1201      (t      (t
1202       (:weight bold)))       (:bold t)))
1203    "Face used for displaying cited text names."    "Face used for displaying cited text names."
1204    :group 'message-faces)    :group 'message-faces)
1205    
# Line 829  Defaults to `text-mode-abbrev-table'.") Line 1211  Defaults to `text-mode-abbrev-table'.")
1211        (background light))        (background light))
1212       (:foreground "ForestGreen"))       (:foreground "ForestGreen"))
1213      (t      (t
1214       (:weight bold)))       (:bold t)))
1215    "Face used for displaying MML."    "Face used for displaying MML."
1216    :group 'message-faces)    :group 'message-faces)
1217    
1218    (defun message-font-lock-make-header-matcher (regexp)
1219      (let ((form
1220             `(lambda (limit)
1221                (let ((start (point)))
1222                  (save-restriction
1223                    (widen)
1224                    (goto-char (point-min))
1225                    (if (re-search-forward
1226                         (concat "^" (regexp-quote mail-header-separator) "$")
1227                         nil t)
1228                        (setq limit (min limit (match-beginning 0))))
1229                    (goto-char start))
1230                  (and (< start limit)
1231                       (re-search-forward ,regexp limit t))))))
1232        (if (featurep 'bytecomp)
1233            (byte-compile form)
1234          form)))
1235    
1236  (defvar message-font-lock-keywords  (defvar message-font-lock-keywords
1237    (let* ((cite-prefix "[:alpha:]")    (let ((content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))
1238           (cite-suffix (concat cite-prefix "0-9_.@-"))      `((,(message-font-lock-make-header-matcher
1239           (content "[ \t]*\\(.+\\(\n[ \t].*\\)*\\)\n?"))           (concat "^\\([Tt]o:\\)" content))
     `((,(concat "^\\([Tt]o:\\)" content)  
1240         (1 'message-header-name-face)         (1 'message-header-name-face)
1241         (2 'message-header-to-face nil t))         (2 'message-header-to-face nil t))
1242        (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)        (,(message-font-lock-make-header-matcher
1243             (concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content))
1244         (1 'message-header-name-face)         (1 'message-header-name-face)
1245         (2 'message-header-cc-face nil t))         (2 'message-header-cc-face nil t))
1246        (,(concat "^\\([Ss]ubject:\\)" content)        (,(message-font-lock-make-header-matcher
1247             (concat "^\\([Ss]ubject:\\)" content))
1248         (1 'message-header-name-face)         (1 'message-header-name-face)
1249         (2 'message-header-subject-face nil t))         (2 'message-header-subject-face nil t))
1250        (,(concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content)        (,(message-font-lock-make-header-matcher
1251             (concat "^\\([Nn]ewsgroups:\\|Followup-[Tt]o:\\)" content))
1252         (1 'message-header-name-face)         (1 'message-header-name-face)
1253         (2 'message-header-newsgroups-face nil t))         (2 'message-header-newsgroups-face nil t))
1254        (,(concat "^\\([A-Z][^: \n\t]+:\\)" content)        (,(message-font-lock-make-header-matcher
1255             (concat "^\\([A-Z][^: \n\t]+:\\)" content))
1256         (1 'message-header-name-face)         (1 'message-header-name-face)
1257         (2 'message-header-other-face nil t))         (2 'message-header-other-face nil t))
1258        (,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content)        (,(message-font-lock-make-header-matcher
1259             (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
1260         (1 'message-header-name-face)         (1 'message-header-name-face)
1261         (2 'message-header-name-face))         (2 'message-header-name-face))
1262        ,@(if (and mail-header-separator        ,@(if (and mail-header-separator
# Line 860  Defaults to `text-mode-abbrev-table'.") Line 1264  Defaults to `text-mode-abbrev-table'.")
1264              `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")              `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
1265                 1 'message-separator-face))                 1 'message-separator-face))
1266            nil)            nil)
1267        (,(concat "^[ \t]*"        ((lambda (limit)
1268                  "\\([" cite-prefix "]+[" cite-suffix "]*\\)?"           (re-search-forward (concat "^\\("
1269                  "[:>|}].*")                                      message-cite-prefix-regexp
1270                                        "\\).*")
1271                                limit t))
1272         (0 'message-cited-text-face))         (0 'message-cited-text-face))
1273        ("<#/?\\(multipart\\|part\\|external\\|mml\\).*>"        ("<#/?\\(multipart\\|part\\|external\\|mml\\|secure\\)[^>]*>"
1274         (0 'message-mml-face))))         (0 'message-mml-face))))
1275    "Additional expressions to highlight in Message mode.")    "Additional expressions to highlight in Message mode.")
1276    
1277    
1278  ;; XEmacs does it like this.  For Emacs, we have to set the  ;; XEmacs does it like this.  For Emacs, we have to set the
1279  ;; `font-lock-defaults' buffer-local variable.  ;; `font-lock-defaults' buffer-local variable.
1280  (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 1289  Defaults to `text-mode-abbrev-table'.")
1289  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.")
1290    
1291  (defcustom message-send-hook nil  (defcustom message-send-hook nil
1292    "Hook run before sending messages."    "Hook run before sending messages.
1293    This hook is run quite early when sending."
1294    :group 'message-various    :group 'message-various
1295    :options '(ispell-message)    :options '(ispell-message)
1296      :link '(custom-manual "(message)Various Message Variables")
1297    :type 'hook)    :type 'hook)
1298    
1299  (defcustom message-send-mail-hook nil  (defcustom message-send-mail-hook nil
1300    "Hook run before sending mail messages."    "Hook run before sending mail messages.
1301    This hook is run very late -- just before the message is sent as
1302    mail."
1303    :group 'message-various    :group 'message-various
1304      :link '(custom-manual "(message)Various Message Variables")
1305    :type 'hook)    :type 'hook)
1306    
1307  (defcustom message-send-news-hook nil  (defcustom message-send-news-hook nil
1308    "Hook run before sending news messages."    "Hook run before sending news messages.
1309    This hook is run very late -- just before the message is sent as
1310    news."
1311    :group 'message-various    :group 'message-various
1312      :link '(custom-manual "(message)Various Message Variables")
1313    :type 'hook)    :type 'hook)
1314    
1315  (defcustom message-sent-hook nil  (defcustom message-sent-hook nil
# Line 907  The cdr of each entry is a function for Line 1322  The cdr of each entry is a function for
1322    
1323  (defvar message-draft-coding-system  (defvar message-draft-coding-system
1324    mm-auto-save-coding-system    mm-auto-save-coding-system
1325    "Coding system to compose mail.")    "*Coding system to compose mail.
1326    If you'd like to make it possible to share draft files between XEmacs
1327    and Emacs, you may use `iso-2022-7bit' for this value at your own risk.
1328    Note that the coding-system `iso-2022-7bit' isn't suitable to all data.")
1329    
1330  (defcustom message-send-mail-partially-limit 1000000  (defcustom message-send-mail-partially-limit 1000000
1331    "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 1333  The lower bound of message size in chara
1333  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."
1334    :version "21.1"    :version "21.1"
1335    :group 'message-buffers    :group 'message-buffers
1336      :link '(custom-manual "(message)Mail Variables")
1337    :type '(choice (const :tag "unlimited" nil)    :type '(choice (const :tag "unlimited" nil)
1338                   (integer 1000000)))                   (integer 1000000)))
1339    
# Line 922  should be sent in several parts.  If it Line 1341  should be sent in several parts.  If it
1341    "A regexp to match the alternative email addresses.    "A regexp to match the alternative email addresses.
1342  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."
1343    :group 'message-headers    :group 'message-headers
1344      :link '(custom-manual "(message)Message Headers")
1345    :type '(choice (const :tag "Always use primary" nil)    :type '(choice (const :tag "Always use primary" nil)
1346                   regexp))                   regexp))
1347    
1348    (defcustom message-hierarchical-addresses nil
1349      "A list of hierarchical mail address definitions.
1350    
1351    Inside each entry, the first address is the \"top\" address, and
1352    subsequent addresses are subaddresses; this is used to indicate that
1353    mail sent to the first address will automatically be delivered to the
1354    subaddresses.  So if the first address appears in the recipient list
1355    for a message, the subaddresses will be removed (if present) before
1356    the mail is sent.  All addresses in this structure should be
1357    downcased."
1358      :group 'message-headers
1359      :type '(repeat (repeat string)))
1360    
1361  (defcustom message-mail-user-agent nil  (defcustom message-mail-user-agent nil
1362    "Like `mail-user-agent'.    "Like `mail-user-agent'.
1363  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 1378  Except if it is nil, use Gnus native MUA
1378    :version "21.1"    :version "21.1"
1379    :group 'message)    :group 'message)
1380    
1381    (defcustom message-wide-reply-confirm-recipients nil
1382      "Whether to confirm a wide reply to multiple email recipients.
1383    If this variable is nil, don't ask whether to reply to all recipients.
1384    If this variable is non-nil, pose the question \"Reply to all
1385    recipients?\" before a wide reply to multiple recipients.  If the user
1386    answers yes, reply to all recipients as usual.  If the user answers
1387    no, only reply back to the author."
1388      :version "21.3"
1389      :group 'message-headers
1390      :link '(custom-manual "(message)Wide Reply")
1391      :type 'boolean)
1392    
1393    (defcustom message-user-fqdn nil
1394      "*Domain part of Messsage-Ids."
1395      :group 'message-headers
1396      :link '(custom-manual "(message)News Headers")
1397      :type '(radio (const :format "%v  " nil)
1398                    (string :format "FQDN: %v\n" :size 0)))
1399    
1400    (defcustom message-use-idna (and (condition-case nil (require 'idna)
1401                                       (file-error))
1402                                     (mm-coding-system-p 'utf-8)
1403                                     (executable-find idna-program)
1404                                     'ask)
1405      "Whether to encode non-ASCII in domain names into ASCII according to IDNA."
1406      :group 'message-headers
1407      :link '(custom-manual "(message)IDNA")
1408      :type '(choice (const :tag "Ask" ask)
1409                     (const :tag "Never" nil)
1410                     (const :tag "Always" t)))
1411    
1412  ;;; Internal variables.  ;;; Internal variables.
1413    
1414  (defvar message-sending-message "Sending...")  (defvar message-sending-message "Sending...")
# Line 954  Except if it is nil, use Gnus native MUA Line 1418  Except if it is nil, use Gnus native MUA
1418  (defvar message-draft-article nil)  (defvar message-draft-article nil)
1419  (defvar message-mime-part nil)  (defvar message-mime-part nil)
1420  (defvar message-posting-charset nil)  (defvar message-posting-charset nil)
1421    (defvar message-inserted-headers nil)
1422    
1423  ;; Byte-compiler warning  ;; Byte-compiler warning
1424  (eval-when-compile  (eval-when-compile
# Line 979  Except if it is nil, use Gnus native MUA Line 1444  Except if it is nil, use Gnus native MUA
1444       ;; can be removed, e.g.       ;; can be removed, e.g.
1445       ;;         From: joe@y.z (Joe      K       ;;         From: joe@y.z (Joe      K
1446       ;;                 User)       ;;                 User)
1447       ;; 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
1448       ;;         From: Joe User       ;;         From: Joe User
1449       ;;                 <joe@y.z>       ;;                 <joe@y.z>
1450       ;; 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 1456  Except if it is nil, use Gnus native MUA
1456       ;; We want to match the results of any of these manglings.       ;; We want to match the results of any of these manglings.
1457       ;; The following regexp rejects names whose first characters are       ;; The following regexp rejects names whose first characters are
1458       ;; obviously bogus, but after that anything goes.       ;; obviously bogus, but after that anything goes.
1459       "\\([^\0-\b\n-\r\^?].*\\)? "       "\\([^\0-\b\n-\r\^?].*\\)?"
1460    
1461       ;; The time the message was sent.       ;; The time the message was sent.
1462       "\\([^\0-\r \^?]+\\) +"            ; day of the week       "\\([^\0-\r \^?]+\\) +"            ; day of the week
# Line 1044  Except if it is nil, use Gnus native MUA Line 1509  Except if it is nil, use Gnus native MUA
1509      (User-Agent))      (User-Agent))
1510    "Alist used for formatting headers.")    "Alist used for formatting headers.")
1511    
1512    (defvar message-options nil
1513      "Some saved answers when sending message.")
1514    
1515    (defvar message-send-mail-real-function nil
1516      "Internal send mail function.")
1517    
1518    (defvar message-bogus-system-names "^localhost\\."
1519      "The regexp of bogus system names.")
1520    
1521    (defcustom message-valid-fqdn-regexp
1522      (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain.
1523              ;; valid TLDs:
1524              "\\([a-z][a-z]" ;; two letter country TDLs
1525              "\\|biz\\|com\\|edu\\|gov\\|int\\|mil\\|net\\|org"
1526              "\\|aero\\|coop\\|info\\|name\\|museum"
1527              "\\|arpa\\|pro\\|uucp\\|bitnet\\|bofh" ;; old style?
1528              "\\)")
1529      "Regular expression that matches a valid FQDN."
1530      ;; see also: gnus-button-valid-fqdn-regexp
1531      :group 'message-headers
1532      :type 'regexp)
1533    
1534  (eval-and-compile  (eval-and-compile
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")
# 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 1095  is used by default." Line 1591  is used by default."
1591            (beg 1)            (beg 1)
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 1530  M-RET    `message-newline-and-reformat' Line 2444  M-RET    `message-newline-and-reformat'
2444    (set (make-local-variable 'message-checksum) nil)    (set (make-local-variable 'message-checksum) nil)
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      (set
2448       (make-local-variable 'paragraph-separate)
2449       (format "\\(%s\\)\\|\\(%s\\)"
2450               paragraph-separate
2451               "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)"))
2452    ;; Allow using comment commands to add/remove quoting.    ;; Allow using comment commands to add/remove quoting.
2453    (when message-yank-prefix    (set (make-local-variable 'comment-start) message-yank-prefix)
     (set (make-local-variable 'comment-start) message-yank-prefix)  
     (set (make-local-variable 'comment-start-skip)  
          (concat "^" (regexp-quote message-yank-prefix) "[ \t]*")))  
   ;;(when (fboundp 'mail-hist-define-keys)  
   ;;  (mail-hist-define-keys))  
2454    (if (featurep 'xemacs)    (if (featurep 'xemacs)
2455        (message-setup-toolbar)        (message-setup-toolbar)
2456      (set (make-local-variable 'font-lock-defaults)      (set (make-local-variable 'font-lock-defaults)
2457           '(message-font-lock-keywords t))           '(message-font-lock-keywords t))
2458      (if (boundp 'message-tool-bar-map)      (if (boundp 'tool-bar-map)
2459          (set (make-local-variable 'tool-bar-map) message-tool-bar-map)))          (set (make-local-variable 'tool-bar-map) (message-tool-bar-map))))
2460    (easy-menu-add message-mode-menu message-mode-map)    (easy-menu-add message-mode-menu message-mode-map)
2461    (easy-menu-add message-mode-field-menu message-mode-map)    (easy-menu-add message-mode-field-menu message-mode-map)
2462      (gnus-make-local-hook 'after-change-functions)
2463      ;; Mmmm... Forbidden properties...
2464      (add-hook 'after-change-functions 'message-strip-forbidden-properties
2465                nil 'local)
2466    ;; Allow mail alias things.    ;; Allow mail alias things.
2467    (when (eq message-mail-alias-type 'abbrev)    (when (eq message-mail-alias-type 'abbrev)
2468      (if (fboundp 'mail-abbrevs-setup)      (if (fboundp 'mail-abbrevs-setup)
2469          (mail-abbrevs-setup)          (mail-abbrevs-setup)
2470        (mail-aliases-setup)))        (if (fboundp 'mail-aliases-setup) ; warning avoidance
2471              (mail-aliases-setup))))
2472    (unless buffer-file-name    (unless buffer-file-name
2473      (message-set-auto-save-file-name))      (message-set-auto-save-file-name))
2474    (mm-enable-multibyte)    (unless (buffer-base-buffer)
2475    (make-local-variable 'indent-tabs-mode) ;Turn off tabs for indentation.      ;; Don't enable multibyte on an indirect buffer.  Maybe enabling
2476    (setq indent-tabs-mode nil)      ;; multibyte is not necessary at all. -- zsh
2477    (mml-mode)      (mm-enable-multibyte))
2478    (run-hooks 'text-mode-hook 'message-mode-hook))    (set (make-local-variable 'indent-tabs-mode) nil) ;No tabs for indentation.
2479      (mml-mode))
2480    
2481  (defun message-setup-fill-variables ()  (defun message-setup-fill-variables ()
2482    "Setup message fill variables."    "Setup message fill variables."
2483      (set (make-local-variable 'fill-paragraph-function)
2484           'message-fill-paragraph)
2485    (make-local-variable 'paragraph-separate)    (make-local-variable 'paragraph-separate)
2486    (make-local-variable 'paragraph-start)    (make-local-variable 'paragraph-start)
2487    (make-local-variable 'adaptive-fill-regexp)    (make-local-variable 'adaptive-fill-regexp)
2488    (unless (boundp 'adaptive-fill-first-line-regexp)    (unless (boundp 'adaptive-fill-first-line-regexp)
2489      (setq adaptive-fill-first-line-regexp nil))      (setq adaptive-fill-first-line-regexp nil))
2490    (make-local-variable 'adaptive-fill-first-line-regexp)    (make-local-variable 'adaptive-fill-first-line-regexp)
   (make-local-variable 'auto-fill-inhibit-regexp)  
2491    (let ((quote-prefix-regexp    (let ((quote-prefix-regexp
2492           (concat           ;; User should change message-cite-prefix-regexp if
2493            "[ \t]*"                      ; possible initial space           ;; message-yank-prefix is set to an abnormal value.
2494            "\\(\\(" (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  
2495      (setq paragraph-start      (setq paragraph-start
2496            (concat            (concat
2497             (regexp-quote mail-header-separator) "$\\|"             (regexp-quote mail-header-separator) "$\\|"
2498             "[ \t]*$\\|"                 ; blank lines             "[ \t]*$\\|"                 ; blank lines
2499             "-- $\\|"                    ; signature delimiter             "-- $\\|"                    ; signature delimiter
2500             "---+$\\|"                   ; delimiters for forwarded messages             "---+$\\|"              ; delimiters for forwarded messages
2501             page-delimiter "$\\|"        ; spoiler warnings             page-delimiter "$\\|"        ; spoiler warnings
2502             ".*wrote:$\\|"               ; attribution lines             ".*wrote:$\\|"               ; attribution lines
2503             quote-prefix-regexp "$"))    ; empty lines in quoted text             quote-prefix-regexp "$"))    ; empty lines in quoted text
2504      (setq paragraph-separate paragraph-start)      (setq paragraph-separate paragraph-start)
2505      (setq adaptive-fill-regexp      (setq adaptive-fill-regexp
2506            (concat quote-prefix-regexp "\\|" adaptive-fill-regexp))            (concat quote-prefix-regexp "\\|" adaptive-fill-regexp))
2507      (setq adaptive-fill-first-line-regexp      (setq adaptive-fill-first-line-regexp
2508            (concat quote-prefix-regexp "\\|"            (concat quote-prefix-regexp "\\|"
2509                    adaptive-fill-first-line-regexp))                    adaptive-fill-first-line-regexp)))
2510      (setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")))    (make-local-variable 'auto-fill-inhibit-regexp)
2511      ;;(setq auto-fill-inhibit-regexp "^[A-Z][^: \n\t]+:")
2512      (setq auto-fill-inhibit-regexp nil)
2513      (make-local-variable 'normal-auto-fill-function)
2514      (setq normal-auto-fill-function 'message-do-auto-fill)
2515      ;; KLUDGE: auto fill might already be turned on in `text-mode-hook'.
2516      ;; In that case, ensure that it uses the right function.  The real
2517      ;; solution would be not to use `define-derived-mode', and run
2518      ;; `text-mode-hook' ourself at the end of the mode.
2519      ;; -- Per Abrahamsen <abraham@dina.kvl.dk> Date: 2001-10-19.
2520      (when auto-fill-function
2521        (setq auto-fill-function normal-auto-fill-function)))
2522    
2523    
2524    
# Line 1604  M-RET    `message-newline-and-reformat' Line 2533  M-RET    `message-newline-and-reformat'
2533    (interactive)    (interactive)
2534    (message-position-on-field "To"))    (message-position-on-field "To"))
2535    
2536    (defun message-goto-from ()
2537      "Move point to the From header."
2538      (interactive)
2539      (message-position-on-field "From"))
2540    
2541  (defun message-goto-subject ()  (defun message-goto-subject ()
2542    "Move point to the Subject header."    "Move point to the Subject header."
2543    (interactive)    (interactive)
# Line 1644  M-RET    `message-newline-and-reformat' Line 2578  M-RET    `message-newline-and-reformat'
2578    (interactive)    (interactive)
2579    (message-position-on-field "Followup-To" "Newsgroups"))    (message-position-on-field "Followup-To" "Newsgroups"))
2580    
2581    (defun message-goto-mail-followup-to ()
2582      "Move point to the Mail-Followup-To header."
2583      (interactive)
2584      (message-position-on-field "Mail-Followup-To" "From"))
2585    
2586  (defun message-goto-keywords ()  (defun message-goto-keywords ()
2587    "Move point to the Keywords header."    "Move point to the Keywords header."
2588    (interactive)    (interactive)
# Line 1654  M-RET    `message-newline-and-reformat' Line 2593  M-RET    `message-newline-and-reformat'
2593    (interactive)    (interactive)
2594    (message-position-on-field "Summary" "Subject"))    (message-position-on-field "Summary" "Subject"))
2595    
2596  (defun message-goto-body ()  (defun message-goto-body (&optional interactivep)
2597    "Move point to the beginning of the message body."    "Move point to the beginning of the message body."
2598    (interactive)    (interactive (list t))
2599    (if (looking-at "[ \t]*\n") (expand-abbrev))    (when (and interactivep
2600                 (looking-at "[ \t]*\n"))
2601        (expand-abbrev))
2602    (goto-char (point-min))    (goto-char (point-min))
2603    (or (search-forward (concat "\n" mail-header-separator "\n") nil t)    (or (search-forward (concat "\n" mail-header-separator "\n") nil t)
2604        (search-forward "\n\n" nil t)))        (search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t)))
2605    
2606  (defun message-goto-eoh ()  (defun message-goto-eoh ()
2607    "Move point to the end of the headers."    "Move point to the end of the headers."
# Line 1679  return nil." Line 2620  return nil."
2620      (goto-char (point-max))      (goto-char (point-max))
2621      nil))      nil))
2622    
2623    (defun message-generate-unsubscribed-mail-followup-to (&optional include-cc)
2624      "Insert a reasonable MFT header in a post to an unsubscribed list.
2625    When making original posts to a mailing list you are not subscribed to,
2626    you have to type in a MFT header by hand.  The contents, usually, are
2627    the addresses of the list and your own address.  This function inserts
2628    such a header automatically.  It fetches the contents of the To: header
2629    in the current mail buffer, and appends the current `user-mail-address'.
2630    
2631    If the optional argument INCLUDE-CC is non-nil, the addresses in the
2632    Cc: header are also put into the MFT."
2633    
2634      (interactive "P")
2635      (let* (cc tos)
2636        (save-restriction
2637          (message-narrow-to-headers)
2638          (message-remove-header "Mail-Followup-To")
2639          (setq cc (and include-cc (message-fetch-field "Cc")))
2640          (setq tos (if cc
2641                        (concat (message-fetch-field "To") "," cc)
2642                      (message-fetch-field "To"))))
2643        (message-goto-mail-followup-to)
2644        (insert (concat tos ", " user-mail-address))))
2645    
2646    
2647    
2648  (defun message-insert-to (&optional force)  (defun message-insert-to (&optional force)
2649    "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.
2650  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
2651  an error.  prefix FORCE is given."
 With the prefix argument FORCE, insert the header anyway."  
2652    (interactive "P")    (interactive "P")
2653    (let ((co (message-fetch-reply-field "mail-copies-to")))    (let* ((mct (message-fetch-reply-field "mail-copies-to"))
2654      (when (and (null force)           (dont (and mct (or (equal (downcase mct) "never")
2655                 co                              (equal (downcase mct) "nobody"))))
2656                 (or (equal (downcase co) "never")           (to (or (message-fetch-reply-field "mail-reply-to")
2657                     (equal (downcase co) "nobody")))                   (message-fetch-reply-field "reply-to")
2658        (error "The user has requested not to have copies sent via mail")))                   (message-fetch-reply-field "from"))))
2659    (when (and (message-position-on-field "To")      (when (and dont to)
2660               (mail-fetch-field "to")        (message
2661               (not (string-match "\\` *\\'" (mail-fetch-field "to"))))         (if force
2662      (insert ", "))             "Ignoring the user request not to have copies sent via mail"
2663    (insert (or (message-fetch-reply-field "reply-to")           "Complying with the user request not to have copies sent via mail")))
2664                (message-fetch-reply-field "from") "")))      (when (and force (not to))
2665          (error "No mail address in the article"))
2666        (when (and to (or force (not dont)))
2667          (message-carefully-insert-headers (list (cons 'To to))))))
2668    
2669    (defun message-insert-wide-reply ()
2670      "Insert To and Cc headers as if you were doing a wide reply."
2671      (interactive)
2672      (let ((headers (message-with-reply-buffer
2673                       (message-get-reply-headers t))))
2674        (message-carefully-insert-headers headers)))
2675    
2676    (defcustom message-header-synonyms
2677      '((To Cc Bcc))
2678      "List of lists of header synonyms.
2679    E.g., if this list contains a member list with elements `Cc' and `To',
2680    then `message-carefully-insert-headers' will not insert a `To' header
2681    when the message is already `Cc'ed to the recipient."
2682      :group 'message-headers
2683      :link '(custom-manual "(message)Message Headers")
2684      :type '(repeat sexp))
2685    
2686    (defun message-carefully-insert-headers (headers)
2687      "Insert the HEADERS, an alist, into the message buffer.
2688    Does not insert the headers when they are already present there
2689    or in the synonym headers, defined by `message-header-synonyms'."
2690      ;; FIXME: Should compare only the address and not the full name.  Comparison
2691      ;; should be done case-folded (and with `string=' rather than
2692      ;; `string-match').
2693      (dolist (header headers)
2694        (let* ((header-name (symbol-name (car header)))
2695               (new-header (cdr header))
2696               (synonyms (loop for synonym in message-header-synonyms
2697                               when (memq (car header) synonym) return synonym))
2698               (old-header
2699                (loop for synonym in synonyms
2700                      for old-header = (mail-fetch-field (symbol-name synonym))
2701                      when (and old-header (string-match new-header old-header))
2702                      return synonym)))
2703          (if old-header
2704              (message "already have `%s' in `%s'" new-header old-header)
2705            (when (and (message-position-on-field header-name)
2706                       (setq old-header (mail-fetch-field header-name))
2707                       (not (string-match "\\` *\\'" old-header)))
2708              (insert ", "))
2709            (insert new-header)))))
2710    
2711  (defun message-widen-reply ()  (defun message-widen-reply ()
2712    "Widen the reply to include maximum recipients."    "Widen the reply to include maximum recipients."
# Line 1734  With the prefix argument FORCE, insert t Line 2742  With the prefix argument FORCE, insert t
2742  (defun message-delete-not-region (beg end)  (defun message-delete-not-region (beg end)
2743    "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."
2744    (interactive "r")    (interactive "r")
2745    (save-excursion    (let (citeprefix)
2746      (goto-char end)      (save-excursion
2747      (delete-region (point) (if (not (message-goto-signature))        (goto-char beg)
2748                                 (point)        ;; snarf citation prefix, if appropriate
2749                               (forward-line -2)        (unless (eq (point) (progn (beginning-of-line) (point)))
2750                               (point)))          (when (looking-at message-cite-prefix-regexp)
2751      (insert "\n")            (setq citeprefix (match-string 0))))
2752      (goto-char beg)        (goto-char end)
2753      (delete-region beg (progn (message-goto-body)        (delete-region (point) (if (not (message-goto-signature))
2754                                (forward-line 2)                                   (point)
2755                                (point))))                                 (forward-line -2)
2756                                   (point)))
2757          (insert "\n")
2758          (goto-char beg)
2759          (delete-region beg (progn (message-goto-body)
2760                                    (forward-line 2)
2761                                    (point)))
2762          (when citeprefix
2763            (insert citeprefix))))
2764    (when (message-goto-signature)    (when (message-goto-signature)
2765      (forward-line -2)))      (forward-line -2)))
2766    
# Line 1754  With the prefix argument FORCE, insert t Line 2770  With the prefix argument FORCE, insert t
2770    (let ((point (point)))    (let ((point (point)))
2771      (message-goto-signature)      (message-goto-signature)
2772      (unless (eobp)      (unless (eobp)
2773        (forward-line -2))        (end-of-line -1))
2774      (kill-region point (point))      (kill-region point (point))
2775      (unless (bolp)      (unless (bolp)
2776        (insert "\n"))))        (insert "\n"))))
2777    
2778  (defun message-newline-and-reformat ()  (defun message-newline-and-reformat (&optional arg not-break)
2779    "Insert four newlines, and then reformat if inside quoted text."    "Insert four newlines, and then reformat if inside quoted text.
2780    (interactive)  Prefix arg means justify as well."
2781    ;; The Latin-1 angle quote looks pretty dubious.  -- fx    (interactive (list (if current-prefix-arg 'full)))
2782    (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"))  
2783      (setq point (point))      (setq point (point))
2784      (insert "\n\n\n")      (beginning-of-line)
2785      (delete-region (point) (re-search-forward "[ \t]*"))      (setq beg (point))
2786      (when quoted      (setq bolp (= beg point))
2787        (insert quoted))      ;; Find first line of the paragraph.
2788      (fill-paragraph nil)      (if not-break
2789            (while (and (not (eobp))
2790                        (not (looking-at message-cite-prefix-regexp))
2791                        (looking-at paragraph-start))
2792              (forward-line 1)))
2793        ;; Find the prefix
2794        (when (looking-at message-cite-prefix-regexp)
2795          (setq quoted (match-string 0))
2796          (goto-char (match-end 0))
2797          (looking-at "[ \t]*")
2798          (setq leading-space (match-string 0)))
2799        (if (and quoted
2800                 (not not-break)
2801                 (not bolp)
2802                 (< (- point beg) (length quoted)))
2803            ;; break inside the cite prefix.
2804            (setq quoted nil
2805                  end nil))
2806        (if quoted
2807            (progn
2808              (forward-line 1)
2809              (while (and (not (eobp))
2810                          (not (looking-at paragraph-separate))
2811                          (looking-at message-cite-prefix-regexp)
2812                          (equal quoted (match-string 0)))
2813                (goto-char (match-end 0))
2814                (looking-at "[ \t]*")
2815                (if (> (length leading-space) (length (match-string 0)))
2816                    (setq leading-space (match-string 0)))
2817                (forward-line 1))
2818              (setq end (point))
2819              (goto-char beg)
2820              (while (and (if (bobp) nil (forward-line -1) t)
2821                          (not (looking-at paragraph-start))
2822                          (looking-at message-cite-prefix-regexp)
2823                          (equal quoted (match-string 0)))
2824                (setq beg (point))
2825                (goto-char (match-end 0))
2826                (looking-at "[ \t]*")
2827                (if (> (length leading-space) (length (match-string 0)))
2828                    (setq leading-space (match-string 0)))))
2829          (while (and (not (eobp))
2830                      (not (looking-at paragraph-separate))
2831                      (not (looking-at message-cite-prefix-regexp)))
2832            (forward-line 1))
2833          (setq end (point))
2834          (goto-char beg)
2835          (while (and (if (bobp) nil (forward-line -1) t)
2836                      (not (looking-at paragraph-start))
2837                      (not (looking-at message-cite-prefix-regexp)))
2838            (setq beg (point))))
2839      (goto-char point)      (goto-char point)
2840      (forward-line 1)))      (save-restriction
2841          (narrow-to-region beg end)
2842          (if not-break
2843              (setq point nil)
2844            (if bolp
2845                (newline)
2846              (newline)
2847              (newline))
2848            (setq point (point))
2849            ;; (newline 2) doesn't mark both newline's as hard, so call
2850            ;; newline twice. -jas
2851            (newline)
2852            (newline)
2853            (delete-region (point) (re-search-forward "[ \t]*"))
2854            (when (and quoted (not bolp))
2855              (insert quoted leading-space)))
2856          (undo-boundary)
2857          (if quoted
2858              (let* ((adaptive-fill-regexp
2859                      (regexp-quote (concat quoted leading-space)))
2860                     (adaptive-fill-first-line-regexp
2861                      adaptive-fill-regexp ))
2862                (fill-paragraph arg))
2863            (fill-paragraph arg))
2864          (if point (goto-char point)))))
2865    
2866    (defun message-fill-paragraph (&optional arg)
2867      "Like `fill-paragraph'."
2868      (interactive (list (if current-prefix-arg 'full)))
2869      (if (if (boundp 'filladapt-mode) filladapt-mode)
2870          nil
2871        (message-newline-and-reformat arg t)
2872        t))
2873    
2874  (defun message-split-line ()  ;; Is it better to use `mail-header-end'?
2875    "Split current line, moving portion beyond point vertically down.  (defun message-point-in-header-p ()
2876  If the current line has `message-yank-prefix', insert it on the new line."    "Return t if point is in the header."
2877    (interactive "*")    (save-excursion
2878    (split-line message-yank-prefix))      (let ((p (point)))
2879          (goto-char (point-min))
2880          (not (re-search-forward
2881                (concat "^" (regexp-quote mail-header-separator) "\n")
2882                p t)))))
2883    
2884    (defun message-do-auto-fill ()
2885      "Like `do-auto-fill', but don't fill in message header."
2886      (unless (message-point-in-header-p)
2887        (do-auto-fill)))
2888    
2889  (defun message-insert-signature (&optional force)  (defun message-insert-signature (&optional force)
2890    "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 2899  If the current line has `message-yank-pr
2899             ((and (null message-signature)             ((and (null message-signature)
2900                   force)                   force)
2901              t)              t)
2902             ((message-functionp message-signature)             ((functionp message-signature)
2903              (funcall message-signature))              (funcall message-signature))
2904             ((listp message-signature)             ((listp message-signature)
2905              (eval message-signature))              (eval message-signature))
# Line 1818  If the current line has `message-yank-pr Line 2916  If the current line has `message-yank-pr
2916        ;; Insert the signature.        ;; Insert the signature.
2917        (unless (bolp)        (unless (bolp)
2918          (insert "\n"))          (insert "\n"))
2919        (insert "\n-- \n")        (when message-signature-insert-empty-line
2920            (insert "\n"))
2921          (insert "-- \n")
2922        (if (eq signature t)        (if (eq signature t)
2923            (insert-file-contents message-signature-file)            (insert-file-contents message-signature-file)
2924          (insert signature))          (insert signature))
2925        (goto-char (point-max))        (goto-char (point-max))
2926        (or (bolp) (insert "\n")))))        (or (bolp) (insert "\n")))))
2927    
2928    (defun message-insert-importance-high ()
2929      "Insert header to mark message as important."
2930      (interactive)
2931      (save-excursion
2932        (save-restriction
2933          (message-narrow-to-headers)
2934          (message-remove-header "Importance"))
2935        (message-goto-eoh)
2936        (insert "Importance: high\n")))
2937    
2938    (defun message-insert-importance-low ()
2939      "Insert header to mark message as unimportant."
2940      (interactive)
2941      (save-excursion
2942        (save-restriction
2943          (message-narrow-to-headers)
2944          (message-remove-header "Importance"))
2945        (message-goto-eoh)
2946        (insert "Importance: low\n")))
2947    
2948    (defun message-insert-or-toggle-importance ()
2949      "Insert a \"Importance: high\" header, or cycle through the header values.
2950    The three allowed values according to RFC 1327 are `high', `normal'
2951    and `low'."
2952      (interactive)
2953      (save-excursion
2954        (let ((valid '("high" "normal" "low"))
2955              (new "high")
2956              cur)
2957          (save-restriction
2958            (message-narrow-to-headers)
2959            (when (setq cur (message-fetch-field "Importance"))
2960              (message-remove-header "Importance")
2961              (setq new (cond ((string= cur "high")
2962                               "low")
2963                              ((string= cur "low")
2964                               "normal")
2965                              (t
2966                               "high")))))
2967          (message-goto-eoh)
2968          (insert (format "Importance: %s\n" new)))))
2969    
2970    (defun message-insert-disposition-notification-to ()
2971      "Request a disposition notification (return receipt) to this message.
2972    Note that this should not be used in newsgroups."
2973      (interactive)
2974      (save-excursion
2975        (save-restriction
2976          (message-narrow-to-headers)
2977          (message-remove-header "Disposition-Notification-To"))
2978        (message-goto-eoh)
2979        (insert (format "Disposition-Notification-To: %s\n"
2980                        (or (message-field-value "Reply-to")
2981                            (message-field-value "From")
2982                            (message-make-from))))))
2983    
2984  (defun message-elide-region (b e)  (defun message-elide-region (b e)
2985    "Elide the text in the region.    "Elide the text in the region.
2986  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 3001  text was killed."
3001        (prefix-numeric-value current-prefix-arg))))        (prefix-numeric-value current-prefix-arg))))
3002    
3003    (setq n (if (numberp n) (mod n 26) 13)) ;canonize N    (setq n (if (numberp n) (mod n 26) 13)) ;canonize N
3004    (unless (or (zerop n)                 ; no action needed for a rot of 0    (unless (or (zerop n)                 ; no action needed for a rot of 0
3005                (= b e))                  ; no region to rotate                (= b e))                  ; no region to rotate
3006      ;; We build the table, if necessary.      ;; We build the table, if necessary.
3007      (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 3044  Mail and USENET news headers are not rot
3044    (save-excursion    (save-excursion
3045      (save-restriction      (save-restriction
3046        (when (message-goto-body)        (when (message-goto-body)
3047          (narrow-to-region (point) (point-max)))          (narrow-to-region (point) (point-max)))
3048        (shell-command-on-region        (shell-command-on-region
3049         (point-min) (point-max) program nil t))))         (point-min) (point-max) program nil t))))
3050    
# Line 1968  However, if `message-yank-prefix' is non Line 3124  However, if `message-yank-prefix' is non
3124        (save-excursion        (save-excursion
3125          (goto-char start)          (goto-char start)
3126          (while (< (point) (mark t))          (while (< (point) (mark t))
3127            (insert message-yank-prefix)            (if (or (looking-at ">") (looking-at "^$"))
3128                  (insert message-yank-cited-prefix)
3129                (insert message-yank-prefix))
3130            (forward-line 1))))            (forward-line 1))))
3131      (goto-char start)))      (goto-char start)))
3132    
# Line 1999  prefix, and don't delete any headers." Line 3157  prefix, and don't delete any headers."
3157  (defun message-yank-buffer (buffer)  (defun message-yank-buffer (buffer)
3158    "Insert BUFFER into the current buffer and quote it."    "Insert BUFFER into the current buffer and quote it."
3159    (interactive "bYank buffer: ")    (interactive "bYank buffer: ")
3160    (let ((message-reply-buffer buffer))    (let ((message-reply-buffer (get-buffer buffer)))
3161      (save-window-excursion      (save-window-excursion
3162        (message-yank-original))))        (message-yank-original))))
3163    
# Line 2016  prefix, and don't delete any headers." Line 3174  prefix, and don't delete any headers."
3174    
3175  (defun message-cite-original-without-signature ()  (defun message-cite-original-without-signature ()
3176    "Cite function in the standard Message manner."    "Cite function in the standard Message manner."
3177    (let ((start (point))    (let* ((start (point))
3178          (end (mark t))           (end (mark t))
3179          (functions           (functions
3180           (when message-indent-citation-function            (when message-indent-citation-function
3181             (if (listp message-indent-citation-function)              (if (listp message-indent-citation-function)
3182                 message-indent-citation-function                  message-indent-citation-function
3183               (list message-indent-citation-function)))))                (list message-indent-citation-function))))
3184             ;; This function may be called by `gnus-summary-yank-message' and
3185             ;; may insert a different article from the original.  So, we will
3186             ;; modify the value of `message-reply-headers' with that article.
3187             (message-reply-headers
3188              (save-restriction
3189                (narrow-to-region start end)
3190                (message-narrow-to-head-1)
3191                (vector 0
3192                        (or (message-fetch-field "subject") "none")
3193                        (message-fetch-field "from")
3194                        (message-fetch-field "date")
3195                        (message-fetch-field "message-id" t)
3196                        (message-fetch-field "references")
3197                        0 0 ""))))
3198      (mml-quote-region start end)      (mml-quote-region start end)
3199      ;; Allow undoing.      ;; Allow undoing.
3200      (undo-boundary)      (undo-boundary)
# Line 2045  prefix, and don't delete any headers." Line 3217  prefix, and don't delete any headers."
3217          (insert "\n"))          (insert "\n"))
3218        (funcall message-citation-line-function))))        (funcall message-citation-line-function))))
3219    
3220  (eval-when-compile (defvar mail-citation-hook))         ;Compiler directive  (eval-when-compile (defvar mail-citation-hook)) ;Compiler directive
3221  (defun message-cite-original ()  (defun message-cite-original ()
3222    "Cite function in the standard Message manner."    "Cite function in the standard Message manner."
3223    (if (and (boundp 'mail-citation-hook)    (if (and (boundp 'mail-citation-hook)
3224             mail-citation-hook)             mail-citation-hook)
3225        (run-hooks 'mail-citation-hook)        (run-hooks 'mail-citation-hook)
3226      (let ((start (point))      (let* ((start (point))
3227            (end (mark t))             (end (mark t))
3228            (functions             (functions
3229             (when message-indent-citation-function              (when message-indent-citation-function
3230               (if (listp message-indent-citation-function)                (if (listp message-indent-citation-function)
3231                   message-indent-citation-function                    message-indent-citation-function
3232                 (list message-indent-citation-function)))))                  (list message-indent-citation-function))))
3233               ;; This function may be called by `gnus-summary-yank-message' and
3234               ;; may insert a different article from the original.  So, we will
3235               ;; modify the value of `message-reply-headers' with that article.
3236               (message-reply-headers
3237                (save-restriction
3238                  (narrow-to-region start end)
3239                  (message-narrow-to-head-1)
3240                  (vector 0
3241                          (or (message-fetch-field "subject") "none")
3242                          (message-fetch-field "from")
3243                          (message-fetch-field "date")
3244                          (message-fetch-field "message-id" t)
3245                          (message-fetch-field "references")
3246                          0 0 ""))))
3247        (mml-quote-region start end)        (mml-quote-region start end)
3248        (goto-char start)        (goto-char start)
3249        (while functions        (while functions
# Line 2144  The text will also be indented the norma Line 3330  The text will also be indented the norma
3330        t)))        t)))
3331    
3332  (defun message-dont-send ()  (defun message-dont-send ()
3333    "Don't send the message you have been editing."    "Don't send the message you have been editing.
3334    Instead, just auto-save the buffer and then bury it."
3335    (interactive)    (interactive)
3336    (set-buffer-modified-p t)    (set-buffer-modified-p t)
3337    (save-buffer)    (save-buffer)
# Line 2157  The text will also be indented the norma Line 3344  The text will also be indented the norma
3344    (interactive)    (interactive)
3345    (when (or (not (buffer-modified-p))    (when (or (not (buffer-modified-p))
3346              (yes-or-no-p "Message modified; kill anyway? "))              (yes-or-no-p "Message modified; kill anyway? "))
3347      (let ((actions message-kill-actions))      (let ((actions message-kill-actions)
3348              (draft-article message-draft-article)
3349              (auto-save-file-name buffer-auto-save-file-name)
3350              (file-name buffer-file-name)
3351              (modified (buffer-modified-p)))
3352        (setq buffer-file-name nil)        (setq buffer-file-name nil)
3353        (kill-buffer (current-buffer))        (kill-buffer (current-buffer))
3354          (when (and (or (and auto-save-file-name
3355                              (file-exists-p auto-save-file-name))
3356                         (and file-name
3357                              (file-exists-p file-name)))
3358                   (yes-or-no-p (format "Remove the backup file%s? "
3359                                        (if modified " too" ""))))
3360            (ignore-errors
3361              (delete-file auto-save-file-name))
3362            (let ((message-draft-article draft-article))
3363              (message-disassociate-draft)))
3364        (message-do-actions actions))))        (message-do-actions actions))))
3365    
3366  (defun message-bury (buffer)  (defun message-bury (buffer)
# Line 2190  It should typically alter the sending me Line 3391  It should typically alter the sending me
3391    (message message-sending-message)    (message message-sending-message)
3392    (let ((alist message-send-method-alist)    (let ((alist message-send-method-alist)
3393          (success t)          (success t)
3394          elem sent)          elem sent dont-barf-on-no-method
3395            (message-options message-options))
3396        (message-options-set-recipient)
3397      (while (and success      (while (and success
3398                  (setq elem (pop alist)))                  (setq elem (pop alist)))
3399        (when (funcall (cadr elem))        (when (funcall (cadr elem))
3400          (when (and (or (not (memq (car elem)          (when (and (or (not (memq (car elem)
3401                                    message-sent-message-via))                                    message-sent-message-via))
3402                         (y-or-n-p                         (message-fetch-field "supersedes")
3403                          (format                         (if (or (message-gnksa-enable-p 'multiple-copies)
3404                           "Already sent message via %s; resend? "                                 (not (eq (car elem) 'news)))
3405                           (car elem))))                             (y-or-n-p
3406                                (format
3407                                 "Already sent message via %s; resend? "
3408                                 (car elem)))
3409                             (error "Denied posting -- multiple copies")))
3410                     (setq success (funcall (caddr elem) arg)))                     (setq success (funcall (caddr elem) arg)))
3411            (setq sent t))))            (setq sent t))))
3412      (unless (or sent (not success))      (unless (or sent
3413                    (not success)
3414                    (let ((fcc (message-fetch-field "Fcc"))
3415                          (gcc (message-fetch-field "Gcc")))
3416                      (when (or fcc gcc)
3417                        (or (eq message-allow-no-recipients 'always)
3418                            (and (not (eq message-allow-no-recipients 'never))
3419                                 (setq dont-barf-on-no-method
3420                                       (gnus-y-or-n-p
3421                                        (format "No receiver, perform %s anyway? "
3422                                                (cond ((and fcc gcc) "Fcc and Gcc")
3423                                                      (fcc "Fcc")
3424                                                      (t "Gcc"))))))))))
3425        (error "No methods specified to send by"))        (error "No methods specified to send by"))
3426      (when (and success sent)      (when (or dont-barf-on-no-method
3427                  (and success sent))
3428        (message-do-fcc)        (message-do-fcc)
3429        (save-excursion        (save-excursion
3430          (run-hooks 'message-sent-hook))          (run-hooks 'message-sent-hook))
# Line 2236  It should typically alter the sending me Line 3456  It should typically alter the sending me
3456  (put 'message-check 'lisp-indent-function 1)  (put 'message-check 'lisp-indent-function 1)
3457  (put 'message-check 'edebug-form-spec '(form body))  (put 'message-check 'edebug-form-spec '(form body))
3458    
3459    (defun message-text-with-property (prop)
3460      "Return a list of all points where the text has PROP."
3461      (let ((points nil)
3462            (point (point-min)))
3463        (save-excursion
3464          (while (< point (point-max))
3465            (when (get-text-property point prop)
3466              (push point points))
3467            (incf point)))
3468        (nreverse points)))
3469    
3470  (defun message-fix-before-sending ()  (defun message-fix-before-sending ()
3471    "Do various things to make the message nice before sending it."    "Do various things to make the message nice before sending it."
3472    ;; Make sure there's a newline at the end of the message.    ;; Make sure there's a newline at the end of the message.
3473    (goto-char (point-max))    (goto-char (point-max))
3474    (unless (bolp)    (unless (bolp)
3475      (insert "\n"))      (insert "\n"))
3476    ;; Delete all invisible text.    ;; Make the hidden headers visible.
3477      (let ((points (message-text-with-property 'message-hidden)))
3478        (when points
3479          (goto-char (car points))
3480          (dolist (point points)
3481            (add-text-properties point (1+ point)
3482                                 '(invisible nil intangible nil)))))
3483      ;; Make invisible text visible.
3484      ;; It doesn't seem as if this is useful, since the invisible property
3485      ;; is clobbered by an after-change hook anyhow.
3486    (message-check 'invisible-text    (message-check 'invisible-text
3487      (when (text-property-any (point-min) (point-max) 'invisible t)      (let ((points (message-text-with-property 'invisible)))
3488        (put-text-property (point-min) (point-max) 'invisible nil)        (when points
3489        (unless (yes-or-no-p          (goto-char (car points))
3490                 "Invisible text found and made visible; continue posting? ")          (dolist (point points)
3491          (error "Invisible text found and made visible")))))            (put-text-property point (1+ point) 'invisible nil)
3492              (message-overlay-put (message-make-overlay point (1+ point))
3493                                   'face 'highlight))
3494            (unless (yes-or-no-p
3495                     "Invisible text found and made visible; continue sending? ")
3496              (error "Invisible text found and made visible")))))
3497      (message-check 'illegible-text
3498        (let (found choice)
3499          (message-goto-body)
3500          (skip-chars-forward mm-7bit-chars)
3501          (while (not (eobp))
3502            (when (let ((char (char-after)))
3503                    (or (< (mm-char-int char) 128)
3504                        (and (mm-multibyte-p)
3505                             (memq (char-charset char)
3506                                   '(eight-bit-control eight-bit-graphic
3507                                                       control-1))
3508                             (not (get-text-property
3509                                   (point) 'untranslated-utf-8)))))
3510              (message-overlay-put (message-make-overlay (point) (1+ (point)))
3511                                   'face 'highlight)
3512              (setq found t))
3513            (forward-char)
3514            (skip-chars-forward mm-7bit-chars))
3515          (when found
3516            (setq choice
3517                  (gnus-multiple-choice
3518                   "Non-printable characters found.  Continue sending?"
3519                   '((?d "Remove non-printable characters and send")
3520                     (?r "Replace non-printable characters with dots and send")
3521                     (?i "Ignore non-printable characters and send")
3522                     (?e "Continue editing"))))
3523            (if (eq choice ?e)
3524              (error "Non-printable characters"))
3525            (message-goto-body)
3526            (skip-chars-forward mm-7bit-chars)
3527            (while (not (eobp))
3528              (when (let ((char (char-after)))
3529                      (or (< (mm-char-int char) 128)
3530                          (and (mm-multibyte-p)
3531                               ;; Fixme: Wrong for Emacs 22 and for things
3532                               ;; like undecable utf-8.  Should at least
3533                               ;; use find-coding-systems-region.
3534                               (memq (char-charset char)
3535                                     '(eight-bit-control eight-bit-graphic
3536                                                         control-1))
3537                               (not (get-text-property
3538                                     (point) 'untranslated-utf-8)))))
3539                (if (eq choice ?i)
3540                    (message-kill-all-overlays)
3541                  (delete-char 1)
3542                  (when (eq choice ?r)
3543                    (insert "."))))
3544              (forward-char)
3545              (skip-chars-forward mm-7bit-chars))))))
3546    
3547  (defun message-add-action (action &rest types)  (defun message-add-action (action &rest types)
3548    "Add ACTION to be performed when doing an exit of type TYPES."    "Add ACTION to be performed when doing an exit of type TYPES."
3549      (while types
3550        (add-to-list (intern (format "message-%s-actions" (pop types)))
3551                     action)))
3552    
3553    (defun message-delete-action (action &rest types)
3554      "Delete ACTION from lists of actions performed when doing an exit of type TYPES."
3555    (let (var)    (let (var)
3556      (while types      (while types
3557        (set (setq var (intern (format "message-%s-actions" (pop types))))        (set (setq var (intern (format "message-%s-actions" (pop types))))
3558             (nconc (symbol-value var) (list action))))))             (delq action (symbol-value var))))))
3559    
3560  (defun message-do-actions (actions)  (defun message-do-actions (actions)
3561    "Perform all actions in ACTIONS."    "Perform all actions in ACTIONS."
# Line 2264  It should typically alter the sending me Line 3564  It should typically alter the sending me
3564      (ignore-errors      (ignore-errors
3565        (cond        (cond
3566         ;; A simple function.         ;; A simple function.
3567         ((message-functionp (car actions))         ((functionp (car actions))
3568          (funcall (car actions)))          (funcall (car actions)))
3569         ;; Something to be evaled.         ;; Something to be evaled.
3570         (t         (t
# Line 2272  It should typically alter the sending me Line 3572  It should typically alter the sending me
3572      (pop actions)))      (pop actions)))
3573    
3574  (defun message-send-mail-partially ()  (defun message-send-mail-partially ()
3575    "Sendmail as message/partial."    "Send mail as message/partial."
3576    ;; replace the header delimiter with a blank line    ;; replace the header delimiter with a blank line
3577    (goto-char (point-min))    (goto-char (point-min))
3578    (re-search-forward    (re-search-forward
# Line 2320  It should typically alter the sending me Line 3620  It should typically alter the sending me
3620                (message-remove-header "Lines")                (message-remove-header "Lines")
3621                (goto-char (point-max))                (goto-char (point-max))
3622                (insert "Mime-Version: 1.0\n")                (insert "Mime-Version: 1.0\n")
3623                (setq header (buffer-substring (point-min) (point-max))))                (setq header (buffer-string)))
3624              (goto-char (point-max))              (goto-char (point-max))
3625              (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"
3626                              id n total))                              id n total))
3627                (forward-char -1)
3628              (let ((mail-header-separator ""))              (let ((mail-header-separator ""))
3629                (when (memq 'Message-ID message-required-mail-headers)                (when (memq 'Message-ID message-required-mail-headers)
3630                  (insert "Message-ID: " (message-make-message-id) "\n"))                  (insert "Message-ID: " (message-make-message-id) "\n"))
3631                (when (memq 'Lines message-required-mail-headers)                (when (memq 'Lines message-required-mail-headers)
3632                  (let ((mail-header-separator ""))                  (insert "Lines: " (message-make-lines) "\n"))
                   (insert "Lines: " (message-make-lines) "\n")))  
3633                (message-goto-subject)                (message-goto-subject)
3634                (end-of-line)                (end-of-line)
3635                (insert (format " (%d/%d)" n total))                (insert (format " (%d/%d)" n total))
               (goto-char (point-max))  
               (insert "\n")  
3636                (widen)                (widen)
3637                (mm-with-unibyte-current-buffer                (mm-with-unibyte-current-buffer
3638                  (funcall message-send-mail-function)))                  (funcall (or message-send-mail-real-function
3639                                 message-send-mail-function))))
3640              (setq n (+ n 1))              (setq n (+ n 1))
3641              (setq p (pop plist))              (setq p (pop plist))
3642              (erase-buffer)))              (erase-buffer)))
# Line 2353  It should typically alter the sending me Line 3652  It should typically alter the sending me
3652           (message-posting-charset           (message-posting-charset
3653            (if (fboundp 'gnus-setup-posting-charset)            (if (fboundp 'gnus-setup-posting-charset)
3654                (gnus-setup-posting-charset nil)                (gnus-setup-posting-charset nil)
3655              message-posting-charset)))              message-posting-charset))
3656             (headers message-required-mail-headers))
3657      (save-restriction      (save-restriction
3658        (message-narrow-to-headers)        (message-narrow-to-headers)
3659          ;; Generate the Mail-Followup-To header if the header is not there...
3660          (if (and (message-subscribed-p)
3661                   (not (mail-fetch-field "mail-followup-to")))
3662              (setq headers
3663                    (cons
3664                     (cons "Mail-Followup-To" (message-make-mail-followup-to))
3665                     message-required-mail-headers))
3666            ;; otherwise, delete the MFT header if the field is empty
3667            (when (equal "" (mail-fetch-field "mail-followup-to"))
3668              (message-remove-header "^Mail-Followup-To:")))
3669        ;; Insert some headers.        ;; Insert some headers.
3670        (let ((message-deletable-headers        (let ((message-deletable-headers
3671               (if news nil message-deletable-headers)))               (if news nil message-deletable-headers)))
3672          (message-generate-headers message-required-mail-headers))          (message-generate-headers headers))
3673        ;; Let the user do all of the above.        ;; Let the user do all of the above.
3674        (run-hooks 'message-header-hook))        (run-hooks 'message-header-hook))
3675      (unwind-protect      (unwind-protect
3676          (save-excursion          (save-excursion
3677            (set-buffer tembuf)            (set-buffer tembuf)
3678            (erase-buffer)            (erase-buffer)
3679            ;; Avoid copying text props.            ;; Avoid copying text props (except hard newlines).
3680            (insert (with-current-buffer mailbuf            (insert (with-current-buffer mailbuf
3681                      (buffer-substring-no-properties (point-min) (point-max))))                      (mml-buffer-substring-no-properties-except-hard-newlines
3682                         (point-min) (point-max))))
3683            ;; Remove some headers.            ;; Remove some headers.
3684            (message-encode-message-body)            (message-encode-message-body)
3685            (save-restriction            (save-restriction
# Line 2384  It should typically alter the sending me Line 3695  It should typically alter the sending me
3695            ;; require one newline at the end.            ;; require one newline at the end.
3696            (or (= (preceding-char) ?\n)            (or (= (preceding-char) ?\n)
3697                (insert ?\n))                (insert ?\n))
3698              (message-cleanup-headers)
3699              ;; FIXME: we're inserting the courtesy copy after encoding.
3700              ;; This is wrong if the courtesy copy string contains
3701              ;; non-ASCII characters. -- jh
3702            (when            (when
3703                (save-restriction                (save-restriction
3704                  (message-narrow-to-headers)                  (message-narrow-to-headers)
3705                  (and news                  (and news
3706                       (or (message-fetch-field "cc")                       (or (message-fetch-field "cc")
3707                             (message-fetch-field "bcc")
3708                           (message-fetch-field "to"))                           (message-fetch-field "to"))
3709                       (let ((content-type (message-fetch-field "content-type")))                       (let ((content-type (message-fetch-field
3710                         (or                                            "content-type")))
3711                          (not content-type)                         (and
3712                          (string= "text/plain"                          (or
3713                                   (car                           (not content-type)
3714                                    (mail-header-parse-content-type                           (string= "text/plain"
3715                                     content-type)))))))                                    (car
3716                                       (mail-header-parse-content-type
3717                                        content-type))))
3718                            (not
3719                             (string= "base64"
3720                                      (message-fetch-field
3721                                       "content-transfer-encoding")))))))
3722              (message-insert-courtesy-copy))              (message-insert-courtesy-copy))
3723            (if (or (not message-send-mail-partially-limit)            (if (or (not message-send-mail-partially-limit)
3724                    (< (point-max) message-send-mail-partially-limit)                    (< (point-max) message-send-mail-partially-limit)
3725                    (not (y-or-n-p "The message size is too large, should it be sent partially? ")))                    (not (message-y-or-n-p
3726                            "The message size is too large, split? "
3727                            t
3728                            "\
3729    The message size, "
3730                            (/ (point-max) 1000) "KB, is too large.
3731    
3732    Some mail gateways (MTA's) bounce large messages.  To avoid the
3733    problem, answer `y', and the message will be split into several
3734    smaller pieces, the size of each is about "
3735                            (/ message-send-mail-partially-limit 1000)
3736                            "KB except the last
3737    one.
3738    
3739    However, some mail readers (MUA's) can't read split messages, i.e.,
3740    mails in message/partially format. Answer `n', and the message will be
3741    sent in one piece.
3742    
3743    The size limit is controlled by `message-send-mail-partially-limit'.
3744    If you always want Gnus to send messages in one piece, set
3745    `message-send-mail-partially-limit' to nil.
3746    ")))
3747                (mm-with-unibyte-current-buffer                (mm-with-unibyte-current-buffer
3748                  (funcall message-send-mail-function))                  (message "Sending via mail...")
3749                    (funcall (or message-send-mail-real-function
3750                                 message-send-mail-function)))
3751              (message-send-mail-partially)))              (message-send-mail-partially)))
3752        (kill-buffer tembuf))        (kill-buffer tembuf))
3753      (set-buffer mailbuf)      (set-buffer mailbuf)
# Line 2415  It should typically alter the sending me Line 3760  It should typically alter the sending me
3760                       " sendmail errors")                       " sendmail errors")
3761                    0))                    0))
3762          resend-to-addresses delimline)          resend-to-addresses delimline)
3763      (let ((case-fold-search t))      (unwind-protect
3764        (save-restriction          (progn
3765          (message-narrow-to-headers)            (let ((case-fold-search t))
3766          (setq resend-to-addresses (message-fetch-field "resent-to")))              (save-restriction
3767        ;; Change header-delimiter to be what sendmail expects.                (message-narrow-to-headers)
3768        (goto-char (point-min))                (setq resend-to-addresses (message-fetch-field "resent-to")))
3769        (re-search-forward              ;; Change header-delimiter to be what sendmail expects.
3770         (concat "^" (regexp-quote mail-header-separator) "\n"))              (goto-char (point-min))
3771        (replace-match "\n")              (re-search-forward
3772        (backward-char 1)               (concat "^" (regexp-quote mail-header-separator) "\n"))
3773        (setq delimline (point-marker))              (replace-match "\n")
3774        (run-hooks 'message-send-mail-hook)              (backward-char 1)
3775        ;; Insert an extra newline if we need it to work around              (setq delimline (point-marker))
3776        ;; Sun's bug that swallows newlines.              (run-hooks 'message-send-mail-hook)
3777        (goto-char (1+ delimline))              ;; Insert an extra newline if we need it to work around
3778        (when (eval message-mailer-swallows-blank-line)              ;; Sun's bug that swallows newlines.
3779          (newline))              (goto-char (1+ delimline))
3780        (when message-interactive              (when (eval message-mailer-swallows-blank-line)
3781          (save-excursion                (newline))
3782            (set-buffer errbuf)              (when message-interactive
3783            (erase-buffer))))                (save-excursion
3784      (let ((default-directory "/")                  (set-buffer errbuf)
3785            (coding-system-for-write message-send-coding-system))                  (erase-buffer))))
3786        (apply 'call-process-region            (let* ((default-directory "/")
3787               (append (list (point-min) (point-max)                   (coding-system-for-write message-send-coding-system)
3788                             (if (boundp 'sendmail-program)                   (cpr (apply
3789                                 sendmail-program                         'call-process-region
3790                               "/usr/lib/sendmail")                         (append
3791                             nil errbuf nil "-oi")                          (list (point-min) (point-max)
3792                       ;; Always specify who from,                                (if (boundp 'sendmail-program)
3793                       ;; since some systems have broken sendmails.                                    sendmail-program
3794                       ;; But some systems are more broken with -f, so                                  "/usr/lib/sendmail")
3795                       ;; we'll let users override this.                                nil errbuf nil "-oi")
3796                       (if (null message-sendmail-f-is-evil)                          ;; Always specify who from,
3797                           (list "-f" (message-make-address)))                          ;; since some systems have broken sendmails.
3798                       ;; These mean "report errors by mail"                          ;; But some systems are more broken with -f, so
3799                       ;; and "deliver in background".                          ;; we'll let users override this.
3800                       (if (null message-interactive) '("-oem" "-odb"))                          (if (null message-sendmail-f-is-evil)
3801                       ;; Get the addresses from the message                              (list "-f" (message-sendmail-envelope-from)))
3802                       ;; unless this is a resend.                          ;; These mean "report errors by mail"
3803                       ;; We must not do that for a resend                          ;; and "deliver in background".
3804                       ;; because we would find the original addresses.                          (if (null message-interactive) '("-oem" "-odb"))
3805                       ;; For a resend, include the specific addresses.                          ;; Get the addresses from the message
3806                       (if resend-to-addresses                          ;; unless this is a resend.
3807                           (list resend-to-addresses)                          ;; We must not do that for a resend
3808                         '("-t")))))                          ;; because we would find the original addresses.
3809      (when message-interactive                          ;; For a resend, include the specific addresses.
3810        (save-excursion                          (if resend-to-addresses
3811          (set-buffer errbuf)                              (list resend-to-addresses)
3812          (goto-char (point-min))                            '("-t"))))))
3813          (while (re-search-forward "\n\n* *" nil t)              (unless (or (null cpr) (and (numberp cpr) (zerop cpr)))
3814            (replace-match "; "))                (error "Sending...failed with exit value %d" cpr)))
3815          (if (not (zerop (buffer-size)))            (when message-interactive
3816              (error "Sending...failed to %s"              (save-excursion
3817                     (buffer-substring (point-min) (point-max)))))                (set-buffer errbuf)
3818                  (goto-char (point-min))
3819                  (while (re-search-forward "\n\n* *" nil t)
3820                    (replace-match "; "))
3821                  (if (not (zerop (buffer-size)))
3822                      (error "Sending...failed to %s"
3823                             (buffer-string))))))
3824        (when (bufferp errbuf)        (when (bufferp errbuf)
3825          (kill-buffer errbuf)))))          (kill-buffer errbuf)))))
3826    
# Line 2506  to find out how to use this." Line 3857  to find out how to use this."
3857           ;; 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
3858           ;; 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
3859           ;; gets full control (no gestapo'ish -f's, for instance).  --sj           ;; gets full control (no gestapo'ish -f's, for instance).  --sj
3860           message-qmail-inject-args))           (if (functionp message-qmail-inject-args)
3861                 (funcall message-qmail-inject-args)
3862               message-qmail-inject-args)))
3863      ;; qmail-inject doesn't say anything on it's stdout/stderr,      ;; qmail-inject doesn't say anything on it's stdout/stderr,
3864      ;; we have to look at the retval instead      ;; we have to look at the retval instead
3865      (0 nil)      (0 nil)
3866      (1   (error "qmail-inject reported permanent failure"))      (100 (error "qmail-inject reported permanent failure"))
3867      (111 (error "qmail-inject reported transient failure"))      (111 (error "qmail-inject reported transient failure"))
3868      ;; should never happen      ;; should never happen
3869      (t   (error "qmail-inject reported unknown failure"))))      (t   (error "qmail-inject reported unknown failure"))))
# Line 2533  to find out how to use this." Line 3886  to find out how to use this."
3886      ;; Pass it on to mh.      ;; Pass it on to mh.
3887      (mh-send-letter)))      (mh-send-letter)))
3888    
3889    (defun message-smtpmail-send-it ()
3890      "Send the prepared message buffer with `smtpmail-send-it'.
3891    This only differs from `smtpmail-send-it' that this command evaluates
3892    `message-send-mail-hook' just before sending a message.  It is useful
3893    if your ISP requires the POP-before-SMTP authentication.  See the
3894    documentation for the function `mail-source-touch-pop'."
3895      (run-hooks 'message-send-mail-hook)
3896      (smtpmail-send-it))
3897    
3898    (defun message-canlock-generate ()
3899      "Return a string that is non-trivial to guess.
3900    Do not use this for anything important, it is cryptographically weak."
3901      (let (sha1-maximum-internal-length)
3902        (sha1 (concat (message-unique-id)
3903                      (format "%x%x%x" (random) (random t) (random))
3904                      (prin1-to-string (recent-keys))
3905                      (prin1-to-string (garbage-collect))))))
3906    
3907    (defun message-canlock-password ()
3908      "The password used by message for cancel locks.
3909    This is the value of `canlock-password', if that option is non-nil.
3910    Otherwise, generate and save a value for `canlock-password' first."
3911      (unless canlock-password
3912        (customize-save-variable 'canlock-password (message-canlock-generate))
3913        (setq canlock-password-for-verify canlock-password))
3914      canlock-password)
3915    
3916    (defun message-insert-canlock ()
3917      (when message-insert-canlock
3918        (message-canlock-password)
3919        (canlock-insert-header)))
3920    
3921  (defun message-send-news (&optional arg)  (defun message-send-news (&optional arg)
3922    (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))    (let* ((tembuf (message-generate-new-buffer-clone-locals " *message temp*"))
3923           (case-fold-search nil)           (case-fold-search nil)
3924           (method (if (message-functionp message-post-method)           (method (if (functionp message-post-method)
3925                       (funcall message-post-method arg)                       (funcall message-post-method arg)
3926                     message-post-method))                     message-post-method))
3927           (group-name-charset (gnus-group-name-charset method ""))           (newsgroups-field (save-restriction
3928                                (message-narrow-to-headers-or-head)
3929                                (message-fetch-field "Newsgroups")))
3930             (followup-field (save-restriction
3931                               (message-narrow-to-headers-or-head)
3932                               (message-fetch-field "Followup-To")))
3933             ;; BUG: We really need to get the charset for each name in the
3934             ;; Newsgroups and Followup-To lines to allow crossposting
3935             ;; between group namess with incompatible character sets.
3936             ;; -- Per Abrahamsen <abraham@dina.kvl.dk> 2001-10-08.
3937             (group-field-charset
3938              (gnus-group-name-charset method newsgroups-field))
3939             (followup-field-charset
3940              (gnus-group-name-charset method (or followup-field "")))
3941           (rfc2047-header-encoding-alist           (rfc2047-header-encoding-alist
3942            (if group-name-charset            (append (when group-field-charset
3943                (cons (cons "Newsgroups" group-name-charset)                      (list (cons "Newsgroups" group-field-charset)))
3944                      rfc2047-header-encoding-alist)                    (when followup-field-charset
3945              rfc2047-header-encoding-alist))                      (list (cons "Followup-To" followup-field-charset)))
3946                      rfc2047-header-encoding-alist))
3947           (messbuf (current-buffer))           (messbuf (current-buffer))
3948           (message-syntax-checks           (message-syntax-checks
3949            (if arg            (if (and arg
3950                       (listp message-syntax-checks))
3951                (cons '(existing-newsgroups . disabled)                (cons '(existing-newsgroups . disabled)
3952                      message-syntax-checks)                      message-syntax-checks)
3953              message-syntax-checks))              message-syntax-checks))
3954           (message-this-is-news t)           (message-this-is-news t)
3955           (message-posting-charset (gnus-setup-posting-charset           (message-posting-charset
3956                                     (save-restriction            (gnus-setup-posting-charset newsgroups-field))
                                      (message-narrow-to-headers-or-head)  
                                      (message-fetch-field "Newsgroups"))))  
3957           result)           result)
3958      (if (not (message-check-news-body-syntax))      (if (not (message-check-news-body-syntax))
3959          nil          nil
# Line 2563  to find out how to use this." Line 3961  to find out how to use this."
3961          (message-narrow-to-headers)          (message-narrow-to-headers)
3962          ;; Insert some headers.          ;; Insert some headers.
3963          (message-generate-headers message-required-news-headers)          (message-generate-headers message-required-news-headers)
3964            (message-insert-canlock)
3965          ;; Let the user do all of the above.          ;; Let the user do all of the above.
3966          (run-hooks 'message-header-hook))          (run-hooks 'message-header-hook))
3967        (if group-name-charset        ;; Note: This check will be disabled by the ".*" default value for
3968            (setq message-syntax-checks        ;; gnus-group-name-charset-group-alist. -- Pa 2001-10-07.
3969          (when (and group-field-charset
3970                     (listp message-syntax-checks))
3971            (setq message-syntax-checks
3972                (cons '(valid-newsgroups . disabled)                (cons '(valid-newsgroups . disabled)
3973                      message-syntax-checks)))                      message-syntax-checks)))
3974        (message-cleanup-headers)        (message-cleanup-headers)
3975        (if (not (message-check-news-syntax))        (if (not (let ((message-post-method method))
3976                     (message-check-news-syntax)))
3977            nil            nil
3978          (unwind-protect          (unwind-protect
3979              (save-excursion              (save-excursion
3980                (set-buffer tembuf)                (set-buffer tembuf)
3981                (buffer-disable-undo)                (buffer-disable-undo)
3982                (erase-buffer)                (erase-buffer)
3983                ;; Avoid copying text props.                ;; Avoid copying text props (except hard newlines).
3984                (insert (with-current-buffer messbuf                (insert
3985                          (buffer-substring-no-properties                 (with-current-buffer messbuf
3986                           (point-min) (point-max))))                   (mml-buffer-substring-no-properties-except-hard-newlines
3987                      (point-min) (point-max))))
3988                (message-encode-message-body)                (message-encode-message-body)
3989                ;; Remove some headers.                ;; Remove some headers.
3990                (save-restriction                (save-restriction
# Line 2605  to find out how to use this." Line 4009  to find out how to use this."
4009                  (backward-char 1))                  (backward-char 1))
4010                (run-hooks 'message-send-news-hook)                (run-hooks 'message-send-news-hook)
4011                (gnus-open-server method)                (gnus-open-server method)
4012                  (message "Sending news via %s..." (gnus-server-string method))
4013                (setq result (let ((mail-header-separator ""))                (setq result (let ((mail-header-separator ""))
4014                               (gnus-request-post method))))                               (gnus-request-post method))))
4015            (kill-buffer tembuf))            (kill-buffer tembuf))
# Line 2665  to find out how to use this." Line 4070  to find out how to use this."
4070           (y-or-n-p           (y-or-n-p
4071            "The control code \"cmsg\" is in the subject.  Really post? ")            "The control code \"cmsg\" is in the subject.  Really post? ")
4072         t))         t))
4073       ;; Check long header lines.
4074       (message-check 'long-header-lines
4075         (let ((start (point))
4076               (header nil)
4077               (length 0)
4078               found)
4079           (while (and (not found)
4080                       (re-search-forward "^\\([^ \t:]+\\): " nil t))
4081             (if (> (- (point) (match-beginning 0)) 998)
4082                 (setq found t
4083                       length (- (point) (match-beginning 0)))
4084               (setq header (match-string-no-properties 1)))
4085             (setq start (match-beginning 0))
4086             (forward-line 1))
4087           (if found
4088               (y-or-n-p (format "Your %s header is too long (%d).  Really post? "
4089                                 header length))
4090             t)))
4091     ;; Check for multiple identical headers.     ;; Check for multiple identical headers.
4092     (message-check 'multiple-headers     (message-check 'multiple-headers
4093       (let (found)       (let (found)
# Line 2703  to find out how to use this." Line 4126  to find out how to use this."
4126                     (zerop                     (zerop
4127                      (length                      (length
4128                       (setq to (completing-read                       (setq to (completing-read
4129                                 "Followups to: (default all groups) "                                 "Followups to (default: no Followup-To header) "
4130                                 (mapcar (lambda (g) (list g))                                 (mapcar #'list
4131                                         (cons "poster"                                         (cons "poster"
4132                                               (message-tokenize-header                                               (message-tokenize-header
4133                                                newsgroups)))))))))                                                newsgroups)))))))))
# Line 2714  to find out how to use this." Line 4137  to find out how to use this."
4137     ;; Check "Shoot me".     ;; Check "Shoot me".
4138     (message-check 'shoot     (message-check 'shoot
4139       (if (re-search-forward       (if (re-search-forward
4140            "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)
4141           (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? ")
4142         t))         t))
4143     ;; Check for Approved.     ;; Check for Approved.
# Line 2745  to find out how to use this." Line 4168  to find out how to use this."
4168                       (if followup-to                       (if followup-to
4169                           (concat newsgroups "," followup-to)                           (concat newsgroups "," followup-to)
4170                         newsgroups)))                         newsgroups)))
4171              (hashtb (and (boundp 'gnus-active-hashtb)              (post-method (if (functionp message-post-method)
4172                           gnus-active-hashtb))                               (funcall message-post-method)
4173                               message-post-method))
4174                ;; KLUDGE to handle nnvirtual groups.  Doing this right
4175                ;; would probably involve a new nnoo function.
4176                ;; -- Per Abrahamsen <abraham@dina.kvl.dk>, 2001-10-17.
4177                (method (if (and (consp post-method)
4178                                 (eq (car post-method) 'nnvirtual)
4179                                 gnus-message-group-art)
4180                            (let ((group (car (nnvirtual-find-group-art
4181                                               (car gnus-message-group-art)
4182                                               (cdr gnus-message-group-art)))))
4183                              (gnus-find-method-for-group group))
4184                          post-method))
4185                (known-groups
4186                 (mapcar (lambda (n)
4187                           (gnus-group-name-decode
4188                            (gnus-group-real-name n)
4189                            (gnus-group-name-charset method n)))
4190                         (gnus-groups-from-server method)))
4191              errors)              errors)
4192         (if (or (not hashtb)         (while groups
4193                 (not (boundp 'gnus-read-active-file))           (when (and (not (equal (car groups) "poster"))
4194                 (not gnus-read-active-file)                      (not (member (car groups) known-groups))
4195                 (eq gnus-read-active-file 'some))                      (not (member (car groups) errors)))
4196             t             (push (car groups) errors))
4197           (while groups           (pop groups))
4198             (when (and (not (boundp (intern (car groups) hashtb)))         (cond
4199                        (not (equal (car groups) "poster")))          ;; Gnus is not running.
4200               (push (car groups) errors))          ((or (not (and (boundp 'gnus-active-hashtb)
4201             (pop groups))                         gnus-active-hashtb))
4202           (if (not errors)               (not (boundp 'gnus-read-active-file)))
4203               t           t)
4204             (y-or-n-p          ;; We don't have all the group names.
4205              (format          ((and (or (not gnus-read-active-file)
4206               "Really post to %s unknown group%s: %s? "                    (eq gnus-read-active-file 'some))
4207               (if (= (length errors) 1) "this" "these")                errors)
4208               (if (= (length errors) 1) "" "s")           (y-or-n-p
4209               (mapconcat 'identity errors ", ")))))))            (format
4210               "Really use %s possibly unknown group%s: %s? "
4211               (if (= (length errors) 1) "this" "these")
4212               (if (= (length errors) 1) "" "s")
4213               (mapconcat 'identity errors ", "))))
4214            ;; There were no errors.
4215            ((not errors)
4216             t)
4217            ;; There are unknown groups.
4218            (t
4219             (y-or-n-p
4220              (format
4221               "Really post to %s unknown group%s: %s? "
4222               (if (= (length errors) 1) "this" "these")
4223               (if (= (length errors) 1) "" "s")
4224               (mapconcat 'identity errors ", ")))))))
4225       ;; Check continuation headers.
4226       (message-check 'continuation-headers
4227         (goto-char (point-min))
4228         (let ((do-posting t))
4229           (while (re-search-forward "^[^ \t\n][^:\n]*$" nil t)
4230             (if (y-or-n-p "Fix continuation lines? ")
4231                 (progn
4232                   (goto-char (match-beginning 0))
4233                   (insert " "))
4234               (unless (y-or-n-p "Send anyway? ")
4235                 (setq do-posting nil))))
4236           do-posting))
4237     ;; Check the Newsgroups & Followup-To headers for syntax errors.     ;; Check the Newsgroups & Followup-To headers for syntax errors.
4238     (message-check 'valid-newsgroups     (message-check 'valid-newsgroups
4239       (let ((case-fold-search t)       (let ((case-fold-search t)
# Line 2820  to find out how to use this." Line 4288  to find out how to use this."
4288                     "@[^\\.]*\\."                     "@[^\\.]*\\."
4289                     (setq ad (nth 1 (mail-extract-address-components                     (setq ad (nth 1 (mail-extract-address-components
4290                                      from))))) ;larsi@ifi                                      from))))) ;larsi@ifi
4291               (string-match "\\.\\." ad) ;larsi@ifi..uio               (string-match "\\.\\." ad) ;larsi@ifi..uio
4292               (string-match "@\\." ad)   ;larsi@.ifi.uio               (string-match "@\\." ad)   ;larsi@.ifi.uio
4293               (string-match "\\.$" ad)   ;larsi@ifi.uio.               (string-match "\\.$" ad)   ;larsi@ifi.uio.
4294               (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio               (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
# Line 2828  to find out how to use this." Line 4296  to find out how to use this."
4296           (message           (message
4297            "Denied posting -- the From looks strange: \"%s\"." from)            "Denied posting -- the From looks strange: \"%s\"." from)
4298           nil)           nil)
4299            ((let ((addresses (rfc822-addresses from)))
4300               (while (and addresses
4301                           (not (eq (string-to-char (car addresses)) ?\()))
4302                 (setq addresses (cdr addresses)))
4303               addresses)
4304             (message
4305              "Denied posting -- bad From address: \"%s\"." from)
4306             nil)
4307            (t t))))
4308       ;; Check the Reply-To header.
4309       (message-check 'reply-to
4310         (let* ((case-fold-search t)
4311                (reply-to (message-fetch-field "reply-to"))
4312                ad)
4313           (cond
4314            ((not reply-to)
4315             t)
4316            ((string-match "," reply-to)
4317             (y-or-n-p
4318              (format "Multiple Reply-To addresses: \"%s\". Really post? "
4319                      reply-to)))
4320            ((or (not (string-match
4321                       "@[^\\.]*\\."
4322                       (setq ad (nth 1 (mail-extract-address-components
4323                                        reply-to))))) ;larsi@ifi
4324                 (string-match "\\.\\." ad) ;larsi@ifi..uio
4325                 (string-match "@\\." ad)   ;larsi@.ifi.uio
4326                 (string-match "\\.$" ad)   ;larsi@ifi.uio.
4327                 (not (string-match "^[^@]+@[^@]+$" ad)) ;larsi.ifi.uio
4328                 (string-match "(.*).*(.*)" reply-to)) ;(lars) (lars)
4329             (y-or-n-p
4330              (format
4331               "The Reply-To looks strange: \"%s\". Really post? "
4332               reply-to)))
4333          (t t))))))          (t t))))))
4334    
4335  (defun message-check-news-body-syntax ()  (defun message-check-news-body-syntax ()
# Line 2837  to find out how to use this." Line 4339  to find out how to use this."
4339       (goto-char (point-min))       (goto-char (point-min))
4340       (re-search-forward       (re-search-forward
4341        (concat "^" (regexp-quote mail-header-separator) "$"))        (concat "^" (regexp-quote mail-header-separator) "$"))
4342         (forward-line 1)
4343       (while (and       (while (and
4344               (progn               (or (looking-at
4345                 (end-of-line)                    "<#\\(/\\)?\\(multipart\\|part\\|external\\|mml\\)")
4346                 (< (current-column) 80))                   (let ((p (point)))
4347                       (end-of-line)
4348                       (< (- (point) p) 80)))
4349               (zerop (forward-line 1))))               (zerop (forward-line 1))))
4350       (or (bolp)       (or (bolp)
4351           (eobp)           (eobp)
# Line 2857  to find out how to use this." Line 4362  to find out how to use this."
4362         (re-search-backward message-signature-separator nil t)         (re-search-backward message-signature-separator nil t)
4363         (beginning-of-line)         (beginning-of-line)
4364         (or (re-search-backward "[^ \n\t]" b t)         (or (re-search-backward "[^ \n\t]" b t)
4365             (y-or-n-p "Empty article.  Really post? "))))             (if (message-gnksa-enable-p 'empty-article)
4366                   (y-or-n-p "Empty article.  Really post? ")
4367                 (message "Denied posting -- Empty article.")
4368                 nil))))
4369     ;; Check for control characters.     ;; Check for control characters.
4370     (message-check 'control-chars     (message-check 'control-chars
4371       (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 4384  to find out how to use this."
4384       (or       (or
4385        (not message-checksum)        (not message-checksum)
4386        (not (eq (message-checksum) message-checksum))        (not (eq (message-checksum) message-checksum))
4387        (y-or-n-p        (if (message-gnksa-enable-p 'quoted-text-only)
4388         "It looks like no new text has been added.  Really post? ")))            (y-or-n-p
4389               "It looks like no new text has been added.  Really post? ")
4390            (message "Denied posting -- no new text has been added.")
4391            nil)))
4392     ;; Check the length of the signature.     ;; Check the length of the signature.
4393     (message-check 'signature     (message-check 'signature
4394       (goto-char (point-max))       (goto-char (point-max))
# Line 2891  to find out how to use this." Line 4402  to find out how to use this."
4402     (message-check 'quoting-style     (message-check 'quoting-style
4403       (goto-char (point-max))       (goto-char (point-max))
4404       (let ((no-problem t))       (let ((no-problem t))
4405         (when (search-backward-regexp "^>[^\n]*\n>" nil t)         (when (search-backward-regexp "^>[^\n]*\n" nil t)
4406           (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)))  
4407         (if no-problem         (if no-problem
4408             t             t
4409           (y-or-n-p "Your text should follow quoted text.  Really post? "))))))           (if (message-gnksa-enable-p 'quoted-text-only)
4410                 (y-or-n-p "Your text should follow quoted text.  Really post? ")
4411               ;; Ensure that
4412               (goto-char (point-min))
4413               (re-search-forward
4414                (concat "^" (regexp-quote mail-header-separator) "$"))
4415               (if (search-forward-regexp "^[ \t]*[^>\n]" nil t)
4416                   (y-or-n-p "Your text should follow quoted text.  Really post? ")
4417                 (message "Denied posting -- only quoted text.")
4418                 nil)))))))
4419    
4420  (defun message-checksum ()  (defun message-checksum ()
4421    "Return a \"checksum\" for the current buffer."    "Return a \"checksum\" for the current buffer."
# Line 2910  to find out how to use this." Line 4426  to find out how to use this."
4426         (concat "^" (regexp-quote mail-header-separator) "$"))         (concat "^" (regexp-quote mail-header-separator) "$"))
4427        (while (not (eobp))        (while (not (eobp))
4428          (when (not (looking-at "[ \t\n]"))          (when (not (looking-at "[ \t\n]"))
4429            (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)            (setq sum (logxor (ash sum 1) (if (natnump sum) 0 1)
4430                              (char-after))))                              (char-after))))
4431          (forward-char 1)))          (forward-char 1)))
4432      sum))      sum))
4433    
# Line 2919  to find out how to use this." Line 4435  to find out how to use this."
4435    "Process Fcc headers in the current buffer."    "Process Fcc headers in the current buffer."
4436    (let ((case-fold-search t)    (let ((case-fold-search t)
4437          (buf (current-buffer))          (buf (current-buffer))
4438          list file)          list file
4439            (mml-externalize-attachments message-fcc-externalize-attachments))
4440      (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)  
4441        (save-restriction        (save-restriction
4442          (message-narrow-to-headers)          (message-narrow-to-headers)
4443          (let ((mail-parse-charset message-default-charset)          (setq file (message-fetch-field "fcc" t)))
4444                (rfc2047-header-encoding-alist        (when file
4445                 (cons '("Newsgroups" . default)          (set-buffer (get-buffer-create " *message temp*"))
4446                       rfc2047-header-encoding-alist)))          (erase-buffer)
4447            (mail-encode-encoded-word-buffer)))          (insert-buffer-substring buf)
4448        (goto-char (point-min))          (message-encode-message-body)
4449        (when (re-search-forward          (save-restriction
4450               (concat "^" (regexp-quote mail-header-separator) "$")            (message-narrow-to-headers)
4451               nil t)            (while (setq file (message-fetch-field "fcc" t))
4452          (replace-match "" t t ))              (push file list)
4453        ;; Process FCC operations.              (message-remove-header "fcc" nil t))
4454        (while list            (let ((mail-parse-charset message-default-charset)
4455          (setq file (pop list))                  (rfc2047-header-encoding-alist
4456          (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)                   (cons '("Newsgroups" . default)
4457              ;; Pipe the article to the program in question.                         rfc2047-header-encoding-alist)))
4458              (call-process-region (point-min) (point-max) shell-file-name              (mail-encode-encoded-word-buffer)))
4459                                   nil nil nil shell-command-switch          (goto-char (point-min))
4460                                   (match-string 1 file))          (when (re-search-forward
4461            ;; Save the article.                 (concat "^" (regexp-quote mail-header-separator) "$")
4462            (setq file (expand-file-name file))                 nil t)
4463            (unless (file-exists-p (file-name-directory file))            (replace-match "" t t ))
4464              (make-directory (file-name-directory file) t))          ;; Process FCC operations.
4465            (if (and message-fcc-handler-function          (while list
4466                     (not (eq message-fcc-handler-function 'rmail-output)))            (setq file (pop list))
4467                (funcall message-fcc-handler-function file)            (if (string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" file)
4468              (if (and (file-readable-p file) (mail-file-babyl-p file))                ;; Pipe the article to the program in question.
4469                  (rmail-output file 1 nil t)                (call-process-region (point-min) (point-max) shell-file-name
4470                (let ((mail-use-rfc822 t))                                     nil nil nil shell-command-switch
4471                  (rmail-output file 1 t t))))))                                     (match-string 1 file))
4472        (kill-buffer (current-buffer)))))              ;; Save the article.
4473                (setq file (expand-file-name file))
4474                (unless (file-exists-p (file-name-directory file))
4475                  (make-directory (file-name-directory file) t))
4476                (if (and message-fcc-handler-function
4477                         (not (eq message-fcc-handler-function 'rmail-output)))
4478                    (funcall message-fcc-handler-function file)
4479                  (if (and (file-readable-p file) (mail-file-babyl-p file))
4480                      (rmail-output file 1 nil t)
4481                    (let ((mail-use-rfc822 t))
4482                      (rmail-output file 1 t t))))))
4483            (kill-buffer (current-buffer))))))
4484    
4485  (defun message-output (filename)  (defun message-output (filename)
4486    "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 4512  to find out how to use this."
4512             (point)))             (point)))
4513          (goto-char (point-min))          (goto-char (point-min))
4514          (while (re-search-forward "\n[ \t]+" nil t)          (while (re-search-forward "\n[ \t]+" nil t)
4515            (replace-match " " t t))      ;No line breaks (too confusing)            (replace-match " " t t))     ;No line breaks (too confusing)
4516          (goto-char (point-min))          (goto-char (point-min))
4517          (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)          (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
4518            (replace-match "," t t))            (replace-match "," t t))
# Line 3012  If NOW, use that time instead." Line 4531  If NOW, use that time instead."
4531        (setq sign "-")        (setq sign "-")
4532        (setq zone (- zone)))        (setq zone (- zone)))
4533      (concat      (concat
4534         ;; The day name of the %a spec is locale-specific.  Pfff.
4535         (format "%s, " (capitalize (car (rassoc (nth 6 (decode-time now))
4536                                                 parse-time-weekdays))))
4537       (format-time-string "%d" now)       (format-time-string "%d" now)
4538       ;; The month name of the %b spec is locale-specific.  Pfff.       ;; The month name of the %b spec is locale-specific.  Pfff.
4539       (format " %s "       (format " %s "
# Line 3063  If NOW, use that time instead." Line 4585  If NOW, use that time instead."
4585               (aset user (match-beginning 0) ?_))               (aset user (match-beginning 0) ?_))
4586             user)             user)
4587         (message-number-base36 (user-uid) -1))         (message-number-base36 (user-uid) -1))
4588       (message-number-base36 (+ (car   tm)       (message-number-base36 (+ (car tm)
4589                                 (lsh (% message-unique-id-char 25) 16)) 4)                                 (lsh (% message-unique-id-char 25) 16)) 4)
4590       (message-number-base36 (+ (nth 1 tm)       (message-number-base36 (+ (nth 1 tm)
4591                                 (lsh (/ message-unique-id-char 25) 16)) 4)                                 (lsh (/ message-unique-id-char 25) 16)) 4)
4592       ;; Append the newsreader name, because while the generated       ;; Append a given name, because while the generated ID is unique
4593       ;; ID is unique to this newsreader, other newsreaders might       ;; to this newsreader, other newsreaders might otherwise generate
4594       ;; otherwise generate the same ID via another algorithm.       ;; the same ID via another algorithm.
4595       ".fsf")))       ".fsf")))
4596    
4597  (defun message-number-base36 (num len)  (defun message-number-base36 (num len)
# Line 3085  If NOW, use that time instead." Line 4607  If NOW, use that time instead."
4607    "Make an Organization header."    "Make an Organization header."
4608    (let* ((organization    (let* ((organization
4609            (when message-user-organization            (when message-user-organization
4610              (if (message-functionp message-user-organization)              (if (functionp message-user-organization)
4611                  (funcall message-user-organization)                  (funcall message-user-organization)
4612                message-user-organization))))                message-user-organization))))
4613      (save-excursion      (with-temp-buffer
4614        (message-set-work-buffer)        (mm-enable-multibyte)
4615        (cond ((stringp organization)        (cond ((stringp organization)
4616               (insert organization))               (insert organization))
4617              ((and (eq t organization)              ((and (eq t organization)
# Line 3107  If NOW, use that time instead." Line 4629  If NOW, use that time instead."
4629    (save-excursion    (save-excursion
4630      (save-restriction      (save-restriction
4631        (widen)        (widen)
4632        (goto-char (point-min))        (message-goto-body)
       (re-search-forward  
        (concat "^" (regexp-quote mail-header-separator) "$"))  
       (forward-line 1)  
4633        (int-to-string (count-lines (point) (point-max))))))        (int-to-string (count-lines (point) (point-max))))))
4634    
4635    (defun message-make-references ()
4636      "Return the References header for this message."
4637      (when message-reply-headers
4638        (let ((message-id (mail-header-message-id message-reply-headers))
4639              (references (mail-header-references message-reply-headers))
4640              new-references)
4641          (if (or references message-id)
4642              (concat (or references "") (and references " ")
4643                      (or message-id ""))
4644            nil))))
4645    
4646  (defun message-make-in-reply-to ()  (defun message-make-in-reply-to ()
4647    "Return the In-Reply-To header for this message."    "Return the In-Reply-To header for this message."
4648    (when message-reply-headers    (when message-reply-headers
4649      (mail-header-message-id message-reply-headers)))      (let ((from (mail-header-from message-reply-headers))
4650              (date (mail-header-date message-reply-headers))
4651              (msg-id (mail-header-message-id message-reply-headers)))
4652          (when from
4653            (let ((name (mail-extract-address-components from)))
4654              (concat msg-id (if msg-id " (")
4655                      (or (car name)
4656                          (nth 1 name))
4657                      "'s message of \""
4658                      (if (or (not date) (string= date ""))
4659                          "(unknown date)" date)
4660                      "\"" (if msg-id ")")))))))
4661    
4662  (defun message-make-distribution ()  (defun message-make-distribution ()
4663    "Make a Distribution header."    "Make a Distribution header."
4664    (let ((orig-distribution (message-fetch-reply-field "distribution")))    (let ((orig-distribution (message-fetch-reply-field "distribution")))
4665      (cond ((message-functionp message-distribution-function)      (cond ((functionp message-distribution-function)
4666             (funcall message-distribution-function))             (funcall message-distribution-function))
4667            (t orig-distribution))))            (t orig-distribution))))
4668    
# Line 3154  If NOW, use that time instead." Line 4695  If NOW, use that time instead."
4695                (user-full-name))))                (user-full-name))))
4696      (when (string= fullname "&")      (when (string= fullname "&")
4697        (setq fullname (user-login-name)))        (setq fullname (user-login-name)))
4698      (save-excursion      (with-temp-buffer
4699        (message-set-work-buffer)        (mm-enable-multibyte)
4700        (cond        (cond
4701         ((or (null style)         ((or (null style)
4702              (equal fullname ""))              (equal fullname ""))
# Line 3172  If NOW, use that time instead." Line 4713  If NOW, use that time instead."
4713                         (string-match "[\\()]" tmp)))))                         (string-match "[\\()]" tmp)))))
4714          (insert fullname)          (insert fullname)
4715          (goto-char (point-min))          (goto-char (point-min))
4716          ;; Look for a character that cannot appear unquoted          ;; Look for a character that cannot appear unquoted
4717          ;; according to RFC 822.          ;; according to RFC 822.
4718          (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)          (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
4719            ;; Quote fullname, escaping specials.            ;; Quote fullname, escaping specials.
4720            (goto-char (point-min))            (goto-char (point-min))
4721            (insert "\"")            (insert "\"")
4722            (while (re-search-forward "[\"\\]" nil 1)            (while (re-search-forward "[\"\\]" nil 1)
4723              (replace-match "\\\\\\&" t))              (replace-match "\\\\\\&" t))
4724            (insert "\""))            (insert "\""))
4725          (insert " <" login ">"))          (insert " <" login ">"))
4726         (t                               ; 'parens or default         (t                               ; 'parens or default
4727          (insert login " (")          (insert login " (")
# Line 3216  give as trustworthy answer as possible." Line 4757  give as trustworthy answer as possible."
4757    
4758  (defun message-user-mail-address ()  (defun message-user-mail-address ()
4759    "Return the pertinent part of `user-mail-address'."    "Return the pertinent part of `user-mail-address'."
4760    (when user-mail-address    (when (and user-mail-address
4761                 (string-match "@.*\\." user-mail-address))
4762      (if (string-match " " user-mail-address)      (if (string-match " " user-mail-address)
4763          (nth 1 (mail-extract-address-components user-mail-address))          (nth 1 (mail-extract-address-components user-mail-address))
4764        user-mail-address)))        user-mail-address)))
4765    
4766    (defun message-sendmail-envelope-from ()
4767      "Return the envelope from."
4768      (cond ((eq message-sendmail-envelope-from 'header)
4769             (nth 1 (mail-extract-address-components
4770                     (message-fetch-field "from"))))
4771            ((stringp message-sendmail-envelope-from)
4772             message-sendmail-envelope-from)
4773            (t
4774             (message-make-address))))
4775    
4776  (defun message-make-fqdn ()  (defun message-make-fqdn ()
4777    "Return user's fully qualified domain name."    "Return user's fully qualified domain name."
4778    (let ((system-name (system-name))    (let* ((system-name (system-name))
4779          (user-mail (message-user-mail-address)))           (user-mail (message-user-mail-address))
4780             (user-domain
4781              (if (and user-mail
4782                       (string-match "@\\(.*\\)\\'" user-mail))
4783                  (match-string 1 user-mail)))
4784             (case-fold-search t))
4785      (cond      (cond
4786       ((string-match "[^.]\\.[^.]" system-name)       ((and message-user-fqdn
4787               (stringp message-user-fqdn)
4788               (string-match message-valid-fqdn-regexp message-user-fqdn)
4789               (not (string-match message-bogus-system-names message-user-fqdn)))
4790          message-user-fqdn)
4791         ;; `message-user-fqdn' seems to be valid
4792         ((and (string-match message-valid-fqdn-regexp system-name)
4793               (not (string-match message-bogus-system-names system-name)))
4794        ;; `system-name' returned the right result.        ;; `system-name' returned the right result.
4795        system-name)        system-name)
4796       ;; Try `mail-host-address'.       ;; Try `mail-host-address'.
4797       ((and (boundp 'mail-host-address)       ((and (boundp 'mail-host-address)
4798             (stringp mail-host-address)             (stringp mail-host-address)
4799             (string-match "\\." mail-host-address))             (string-match message-valid-fqdn-regexp mail-host-address)
4800               (not (string-match message-bogus-system-names mail-host-address)))
4801        mail-host-address)        mail-host-address)
4802       ;; We try `user-mail-address' as a backup.       ;; We try `user-mail-address' as a backup.
4803       ((and user-mail       ((and user-domain
4804             (string-match "\\." user-mail)             (stringp user-domain)
4805             (string-match "@\\(.*\\)\\'" user-mail))             (string-match message-valid-fqdn-regexp user-domain)
4806        (match-string 1 user-mail))             (not (string-match message-bogus-system-names user-domain)))
4807          user-domain)
4808       ;; Default to this bogus thing.       ;; Default to this bogus thing.
4809       (t       (t
4810        (concat system-name ".i-did-not-set--mail-host-address--so-shoot-me")))))        (concat system-name
4811                  ".i-did-not-set--mail-host-address--so-tickle-me")))))
4812    
4813  (defun message-make-host-name ()  (defun message-make-host-name ()
4814    "Return the name of the host."    "Return the name of the host."
# Line 3254  give as trustworthy answer as possible." Line 4821  give as trustworthy answer as possible."
4821    (or mail-host-address    (or mail-host-address
4822        (message-make-fqdn)))        (message-make-fqdn)))
4823    
4824    (defun message-to-list-only ()
4825      "Send a message to the list only.
4826    Remove all addresses but the list address from To and Cc headers."
4827      (interactive)
4828      (let ((listaddr (message-make-mail-followup-to t)))
4829        (when listaddr
4830          (save-excursion
4831            (message-remove-header "to")
4832            (message-remove-header "cc")
4833            (message-position-on-field "To" "X-Draft-From")
4834            (insert listaddr)))))
4835    
4836    (defun message-make-mail-followup-to (&optional only-show-subscribed)
4837      "Return the Mail-Followup-To header.
4838    If passed the optional argument ONLY-SHOW-SUBSCRIBED only return the
4839    subscribed address (and not the additional To and Cc header contents)."
4840      (let* ((case-fold-search t)
4841             (to (message-fetch-field "To"))
4842             (cc (message-fetch-field "cc"))
4843             (msg-recipients (concat to (and to cc ", ") cc))
4844             (recipients
4845              (mapcar 'mail-strip-quoted-names
4846                      (message-tokenize-header msg-recipients)))
4847             (file-regexps
4848              (if message-subscribed-address-file
4849                  (let (begin end item re)
4850                    (save-excursion
4851                      (with-temp-buffer
4852                        (insert-file-contents message-subscribed-address-file)
4853                        (while (not (eobp))
4854                          (setq begin (point))
4855                          (forward-line 1)
4856                          (setq end (point))
4857                          (if (bolp) (setq end (1- end)))
4858                          (setq item (regexp-quote (buffer-substring begin end)))
4859                          (if re (setq re (concat re "\\|" item))
4860                            (setq re (concat "\\`\\(" item))))
4861                        (and re (list (concat re "\\)\\'"))))))))
4862             (mft-regexps (apply 'append message-subscribed-regexps
4863                                 (mapcar 'regexp-quote
4864                                         message-subscribed-addresses)
4865                                 file-regexps
4866                                 (mapcar 'funcall
4867                                         message-subscribed-address-functions))))
4868        (save-match-data
4869          (let ((subscribed-lists nil)
4870                (list
4871                 (loop for recipient in recipients
4872                   when (loop for regexp in mft-regexps
4873                          when (string-match regexp recipient) return t)
4874                   return recipient)))
4875            (when list
4876              (if only-show-subscribed
4877                  list
4878                msg-recipients))))))
4879    
4880    (defun message-idna-inside-rhs-p ()
4881      "Return t iff point is inside a RHS (heuristically).
4882    Only works properly if header contains mailbox-list or address-list.
4883    I.e., calling it on a Subject: header is useless."
4884      (save-restriction
4885        (narrow-to-region (save-excursion (or (re-search-backward "^[^ \t]" nil t)
4886                                              (point-min)))
4887                          (save-excursion (or (re-search-forward "^[^ \t]" nil t)
4888                                              (point-max))))
4889        (if (re-search-backward "[\\\n\r\t ]"
4890                                (save-excursion (search-backward "@" nil t)) t)
4891            ;; whitespace between @ and point
4892            nil
4893          (let ((dquote 1) (paren 1))
4894            (while (save-excursion (re-search-backward "[^\\]\"" nil t dquote))
4895              (incf dquote))
4896            (while (save-excursion (re-search-backward "[^\\]\(" nil t paren))
4897              (incf paren))
4898            (and (= (% dquote 2) 1) (= (% paren 2) 1))))))
4899    
4900    (autoload 'idna-to-ascii "idna")
4901    
4902    (defun message-idna-to-ascii-rhs-1 (header)
4903      "Interactively potentially IDNA encode domain names in HEADER."
4904      (let (rhs ace start startpos endpos ovl)
4905        (goto-char (point-min))
4906        (while (re-search-forward (concat "^" header) nil t)
4907          (while (re-search-forward "@\\([^ \t\r\n>,]+\\)"
4908                                    (or (save-excursion
4909                                          (re-search-forward "^[^ \t]" nil t))
4910                                        (point-max))
4911                                    t)
4912            (setq rhs (match-string-no-properties 1)
4913                  startpos (match-beginning 1)
4914                  endpos (match-end 1))
4915            (when (save-match-data
4916                    (and (message-idna-inside-rhs-p)
4917                         (setq ace (idna-to-ascii rhs))
4918                         (not (string= rhs ace))
4919                         (if (eq message-use-idna 'ask)
4920                             (unwind-protect
4921                                 (progn
4922                                   (setq ovl (message-make-overlay startpos
4923                                                                   endpos))
4924                                   (message-overlay-put ovl 'face 'highlight)
4925                                   (y-or-n-p
4926                                    (format "Replace with `%s'? " ace)))
4927                               (message "")
4928                               (message-delete-overlay ovl))
4929                           message-use-idna)))
4930              (replace-match (concat "@" ace)))))))
4931    
4932    (defun message-idna-to-ascii-rhs ()
4933      "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers.
4934    See `message-idna-encode'."
4935      (interactive)
4936      (when message-use-idna
4937        (save-excursion
4938          (save-restriction
4939            (message-narrow-to-head)
4940            (message-idna-to-ascii-rhs-1 "From")
4941            (message-idna-to-ascii-rhs-1 "To")
4942            (message-idna-to-ascii-rhs-1 "Cc")))))
4943    
4944  (defun message-generate-headers (headers)  (defun message-generate-headers (headers)
4945    "Prepare article HEADERS.    "Prepare article HEADERS.
4946  Headers already prepared in the buffer are not modified."  Headers already prepared in the buffer are not modified."
4947      (setq headers (append headers message-required-headers))
4948    (save-restriction    (save-restriction
4949      (message-narrow-to-headers)      (message-narrow-to-headers)
4950      (let* ((Date (message-make-date))      (let* ((Date (message-make-date))
# Line 3267  Headers already prepared in the buffer a Line 4955  Headers already prepared in the buffer a
4955             (Subject nil)             (Subject nil)
4956             (Newsgroups nil)             (Newsgroups nil)
4957             (In-Reply-To (message-make-in-reply-to))             (In-Reply-To (message-make-in-reply-to))
4958               (References (message-make-references))
4959             (To nil)             (To nil)
4960             (Distribution (message-make-distribution))             (Distribution (message-make-distribution))
4961             (Lines (message-make-lines))             (Lines (message-make-lines))
4962             (User-Agent message-newsreader)             (User-Agent message-newsreader)
4963             (Expires (message-make-expires))             (Expires (message-make-expires))
4964             (case-fold-search t)             (case-fold-search t)
4965             header value elem)             (optionalp nil)
4966               header value elem header-string)
4967        ;; First we remove any old generated headers.        ;; First we remove any old generated headers.
4968        (let ((headers message-deletable-headers))        (let ((headers message-deletable-headers))
4969          (unless (buffer-modified-p)          (unless (buffer-modified-p)
# Line 3294  Headers already prepared in the buffer a Line 4984  Headers already prepared in the buffer a
4984          (setq elem (pop headers))          (setq elem (pop headers))
4985          (if (consp elem)          (if (consp elem)
4986              (if (eq (car elem) 'optional)              (if (eq (car elem) 'optional)
4987                  (setq header (cdr elem))                  (setq header (cdr elem)
4988                          optionalp t)
4989                (setq header (car elem)))                (setq header (car elem)))
4990            (setq header elem))            (setq header elem))
4991            (setq header-string  (if (stringp header)
4992                                     header
4993                                   (symbol-name header)))
4994          (when (or (not (re-search-forward          (when (or (not (re-search-forward
4995                          (concat "^"                          (concat "^"
4996                                  (regexp-quote                                  (regexp-quote (downcase header-string))
                                  (downcase  
                                   (if (stringp header)  
                                       header  
                                     (symbol-name header))))  
4997                                  ":")                                  ":")
4998                          nil t))                          nil t))
4999                    (progn                    (progn
5000                      ;; The header was found.  We insert a space after the                      ;; The header was found.  We insert a space after the
5001                      ;; colon, if there is none.                      ;; colon, if there is none.
5002                      (if (/= (char-after) ? ) (insert " ") (forward-char 1))                      (if (/= (char-after) ? ) (insert " ") (forward-char 1))
5003                      ;; Find out whether the header is empty...                      ;; Find out whether the header is empty.
5004                      (looking-at "[ \t]*\n[^ \t]")))                      (looking-at "[ \t]*\n[^ \t]")))
5005            ;; So we find out what value we should insert.            ;; So we find out what value we should insert.
5006            (setq value            (setq value
5007                  (cond                  (cond
5008                   ((and (consp elem) (eq (car elem) 'optional))                   ((and (consp elem)
5009                           (eq (car elem) 'optional)
5010                           (not (member header-string message-inserted-headers)))
5011                    ;; This is an optional header.  If the cdr of this                    ;; This is an optional header.  If the cdr of this
5012                    ;; is something that is nil, then we do not insert                    ;; is something that is nil, then we do not insert
5013                    ;; this header.                    ;; this header.
5014                    (setq header (cdr elem))                    (setq header (cdr elem))
5015                    (or (and (fboundp (cdr elem)) (funcall (cdr elem)))                    (or (and (functionp (cdr elem))
5016                        (and (boundp (cdr elem)) (symbol-value (cdr elem)))))                             (funcall (cdr elem)))
5017                          (and (boundp (cdr elem))
5018                               (symbol-value (cdr elem)))))
5019                   ((consp elem)                   ((consp elem)
5020                    ;; The element is a cons.  Either the cdr is a                    ;; The element is a cons.  Either the cdr is a
5021                    ;; string to be inserted verbatim, or it is a                    ;; string to be inserted verbatim, or it is a
5022                    ;; function, and we insert the value returned from                    ;; function, and we insert the value returned from
5023                    ;; this function.                    ;; this function.
5024                    (or (and (stringp (cdr elem)) (cdr elem))                    (or (and (stringp (cdr elem))
5025                        (and (fboundp (cdr elem)) (funcall (cdr elem)))))                             (cdr elem))
5026                   ((and (boundp header) (symbol-value header))                        (and (functionp (cdr elem))
5027                               (funcall (cdr elem)))))
5028                     ((and (boundp header)
5029                           (symbol-value header))
5030                    ;; The element is a symbol.  We insert the value                    ;; The element is a symbol.  We insert the value
5031                    ;; of this symbol, if any.                    ;; of this symbol, if any.
5032                    (symbol-value header))                    (symbol-value header))
# Line 3346  Headers already prepared in the buffer a Line 5043  Headers already prepared in the buffer a
5043                    (progn                    (progn
5044                      ;; This header didn't exist, so we insert it.                      ;; This header didn't exist, so we insert it.
5045                      (goto-char (point-max))                      (goto-char (point-max))
5046                      (insert (if (stringp header) header (symbol-name header))                      (let ((formatter
5047                              ": " value "\n")                             (cdr (assq header message-header-format-alist))))
5048                      (forward-line -1))                        (if formatter
5049                              (funcall formatter header value)
5050                            (insert header-string ": " value))
5051                          ;; We check whether the value was ended by a
5052                          ;; newline.  If now, we insert one.
5053                          (unless (bolp)
5054                            (insert "\n"))
5055                          (forward-line -1)))
5056                  ;; The value of this header was empty, so we clear                  ;; The value of this header was empty, so we clear
5057                  ;; totally and insert the new value.                  ;; totally and insert the new value.
5058                  (delete-region (point) (gnus-point-at-eol))                  (delete-region (point) (gnus-point-at-eol))
5059                  (insert value))                  ;; If the header is optional, and the header was
5060                    ;; empty, we con't insert it anyway.
5061                    (unless optionalp
5062                      (push header-string message-inserted-headers)
5063                      (insert value)))
5064                ;; Add the deletable property to the headers that require it.                ;; Add the deletable property to the headers that require it.
5065                (and (memq header message-deletable-headers)                (and (memq header message-deletable-headers)
5066                     (progn (beginning-of-line) (looking-at "[^:]+: "))                     (progn (beginning-of-line) (looking-at "[^:]+: "))
# Line 3383  Headers already prepared in the buffer a Line 5091  Headers already prepared in the buffer a
5091              (beginning-of-line))              (beginning-of-line))
5092            (when (or (message-news-p)            (when (or (message-news-p)
5093                      (string-match "@.+\\.." secure-sender))                      (string-match "@.+\\.." secure-sender))
5094              (insert "Sender: " secure-sender "\n")))))))              (insert "Sender: " secure-sender "\n"))))
5095          ;; Check for IDNA
5096          (message-idna-to-ascii-rhs))))
5097    
5098  (defun message-insert-courtesy-copy ()  (defun message-insert-courtesy-copy ()
5099    "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 5146  Headers already prepared in the buffer a
5146      (widen)      (widen)
5147      (forward-line 1)))      (forward-line 1)))
5148    
5149    (defun message-split-line ()
5150      "Split current line, moving portion beyond point vertically down.
5151    If the current line has `message-yank-prefix', insert it on the new line."
5152      (interactive "*")
5153      (condition-case nil
5154          (split-line message-yank-prefix) ;; Emacs 21.3.50+ supports arg.
5155        (error
5156         (split-line))))
5157        
5158  (defun message-fill-header (header value)  (defun message-fill-header (header value)
5159    (let ((begin (point))    (let ((begin (point))
5160          (fill-column 78)          (fill-column 78)
# Line 3463  Headers already prepared in the buffer a Line 5182  Headers already prepared in the buffer a
5182            (nthcdr (+ (- cut 2) surplus 1) list)))            (nthcdr (+ (- cut 2) surplus 1) list)))
5183    
5184  (defun message-shorten-references (header references)  (defun message-shorten-references (header references)
5185    "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.
5186  If folding is disallowed, also check that the REFERENCES are less  If folding is disallowed, also check that the REFERENCES are less
5187  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."
5188    (let ((maxcount 31)    (let ((maxcount 21)
5189          (count 0)          (count 0)
5190          (cut 6)          (cut 2)
5191          refs)          refs)
5192      (with-temp-buffer      (with-temp-buffer
5193        (insert references)        (insert references)
# Line 3534  than 988 characters long, and if they ar Line 5253  than 988 characters long, and if they ar
5253        (forward-line 2)))        (forward-line 2)))
5254     (sit-for 0)))     (sit-for 0)))
5255    
5256    (defcustom message-beginning-of-line t
5257      "Whether \\<message-mode-map>\\[message-beginning-of-line]\
5258     goes to beginning of header values."
5259      :group 'message-buffers
5260      :link '(custom-manual "(message)Movement")
5261      :type 'boolean)
5262    
5263    (defun message-beginning-of-line (&optional n)
5264      "Move point to beginning of header value or to beginning of line.
5265    The prefix argument N is passed directly to `beginning-of-line'.
5266    
5267    This command is identical to `beginning-of-line' if point is
5268    outside the message header or if the option `message-beginning-of-line'
5269    is nil.
5270    
5271    If point is in the message header and on a (non-continued) header
5272    line, move point to the beginning of the header value.  If point
5273    is already there, move point to beginning of line.  Therefore,
5274    repeated calls will toggle point between beginning of field and
5275    beginning of line."
5276      (interactive "p")
5277      (let ((zrs 'zmacs-region-stays))
5278        (when (and (interactive-p) (boundp zrs))
5279          (set zrs t)))
5280      (if (and message-beginning-of-line
5281               (message-point-in-header-p))
5282          (let* ((here (point))
5283                 (bol (progn (beginning-of-line n) (point)))
5284                 (eol (gnus-point-at-eol))
5285                 (eoh (re-search-forward ": *" eol t)))
5286            (if (or (not eoh) (equal here eoh))
5287                (goto-char bol)
5288              (goto-char eoh)))
5289        (beginning-of-line n)))
5290    
5291  (defun message-buffer-name (type &optional to group)  (defun message-buffer-name (type &optional to group)
5292    "Return a new (unique) buffer name based on TYPE and TO."    "Return a new (unique) buffer name based on TYPE and TO."
5293    (cond    (cond
# Line 3550  than 988 characters long, and if they ar Line 5304  than 988 characters long, and if they ar
5304               "*")))               "*")))
5305     ;; Check whether `message-generate-new-buffers' is a function,     ;; Check whether `message-generate-new-buffers' is a function,
5306     ;; and if so, call it.     ;; and if so, call it.
5307     ((message-functionp message-generate-new-buffers)     ((functionp message-generate-new-buffers)
5308      (funcall message-generate-new-buffers type to group))      (funcall message-generate-new-buffers type to group))
5309     ((eq message-generate-new-buffers 'unsent)     ((eq message-generate-new-buffers 'unsent)
5310      (generate-new-buffer-name      (generate-new-buffer-name
# Line 3587  than 988 characters long, and if they ar Line 5341  than 988 characters long, and if they ar
5341    ;; list of buffers.    ;; list of buffers.
5342    (setq message-buffer-list (delq (current-buffer) message-buffer-list))    (setq message-buffer-list (delq (current-buffer) message-buffer-list))
5343    (while (and message-max-buffers    (while (and message-max-buffers
5344                message-buffer-list                message-buffer-list
5345                (>= (length message-buffer-list) message-max-buffers))                (>= (length message-buffer-list) message-max-buffers))
5346      ;; Kill the oldest buffer -- unless it has been changed.      ;; Kill the oldest buffer -- unless it has been changed.
5347      (let ((buffer (pop message-buffer-list)))      (let ((buffer (pop message-buffer-list)))
# Line 3597  than 988 characters long, and if they ar Line 5351  than 988 characters long, and if they ar
5351    ;; Rename the buffer.    ;; Rename the buffer.
5352    (if message-send-rename-function    (if message-send-rename-function
5353        (funcall message-send-rename-function)        (funcall message-send-rename-function)
5354      (when (string-match "\\`\\*\\(unsent \\)?" (buffer-name))      ;; Note: mail-abbrevs of XEmacs renames buffer name behind Gnus.
5355        (rename-buffer      (when (string-match
5356         (concat "*sent " (substring (buffer-name) (match-end 0))) t)))             "\\`\\*\\(sent \\|unsent \\)?\\(.+\\)\\*[^\\*]*\\|\\`mail to "
5357               (buffer-name))
5358          (let ((name (match-string 2 (buffer-name)))
5359                to group)
5360            (if (not (or (null name)
5361                         (string-equal name "mail")
5362                         (string-equal name "posting")))
5363                (setq name (concat "*sent " name "*"))
5364              (message-narrow-to-headers)
5365              (setq to (message-fetch-field "to"))
5366              (setq group (message-fetch-field "newsgroups"))
5367              (widen)
5368              (setq name
5369                    (cond
5370                     (to (concat "*sent mail to "
5371                                 (or (car (mail-extract-address-components to))
5372                                     to) "*"))
5373                     ((and group (not (string= group "")))
5374                      (concat "*sent posting on " group "*"))
5375                     (t "*sent mail*"))))
5376            (unless (string-equal name (buffer-name))
5377              (rename-buffer name t)))))
5378    ;; Push the current buffer onto the list.    ;; Push the current buffer onto the list.
5379    (when message-max-buffers    (when message-max-buffers
5380      (setq message-buffer-list      (setq message-buffer-list
# Line 3639  than 988 characters long, and if they ar Line 5414  than 988 characters long, and if they ar
5414                                headers)                                headers)
5415                        nil switch-function yank-action actions)))))                        nil switch-function yank-action actions)))))
5416    
5417  (eval-when-compile (defvar mc-modes-alist))  (defun message-headers-to-generate (headers included-headers excluded-headers)
5418      "Return a list that includes all headers from HEADERS.
5419    If INCLUDED-HEADERS is a list, just include those headers.  If if is
5420    t, include all headers.  In any case, headers from EXCLUDED-HEADERS
5421    are not included."
5422      (let ((result nil)
5423            header-name)
5424        (dolist (header headers)
5425          (setq header-name (cond
5426                             ((and (consp header)
5427                                   (eq (car header) 'optional))
5428                              ;; On the form (optional . Header)
5429                              (cdr header))
5430                             ((consp header)
5431                              ;; On the form (Header . function)
5432                              (car header))
5433                             (t
5434                              ;; Just a Header.
5435                              header)))
5436          (when (and (not (memq header-name excluded-headers))
5437                     (or (eq included-headers t)
5438                         (memq header-name included-headers)))
5439            (push header result)))
5440        (nreverse result)))
5441    
5442  (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))  
5443    (dolist (action actions)    (dolist (action actions)
5444      (condition-case nil      (condition-case nil
5445          (add-to-list 'message-send-actions          (add-to-list 'message-send-actions
# Line 3679  than 988 characters long, and if they ar Line 5473  than 988 characters long, and if they ar
5473        (or (bolp) (insert ?\n)))        (or (bolp) (insert ?\n)))
5474      (when message-generate-headers-first      (when message-generate-headers-first
5475        (message-generate-headers        (message-generate-headers
5476         (delq 'Lines         (message-headers-to-generate
5477               (delq 'Subject          (append message-required-news-headers
5478                     (copy-sequence message-required-news-headers))))))                  message-required-headers)
5479            message-generate-headers-first
5480            '(Lines Subject)))))
5481    (when (message-mail-p)    (when (message-mail-p)
5482      (when message-default-mail-headers      (when message-default-mail-headers
5483        (insert message-default-mail-headers)        (insert message-default-mail-headers)
5484        (or (bolp) (insert ?\n)))        (or (bolp) (insert ?\n)))
5485        (save-restriction
5486          (message-narrow-to-headers)
5487          (if message-alternative-emails
5488              (message-use-alternative-email-as-from)))
5489      (when message-generate-headers-first      (when message-generate-headers-first
5490        (message-generate-headers        (message-generate-headers
5491         (delq 'Lines         (message-headers-to-generate
5492               (delq 'Subject          (append message-required-mail-headers
5493                     (copy-sequence message-required-mail-headers))))))                  message-required-headers)
5494            message-generate-headers-first
5495            '(Lines Subject)))))
5496    (run-hooks 'message-signature-setup-hook)    (run-hooks 'message-signature-setup-hook)
5497    (message-insert-signature)    (message-insert-signature)
5498    (save-restriction    (save-restriction
5499      (message-narrow-to-headers)      (message-narrow-to-headers)
     (if message-alternative-emails  
         (message-use-alternative-email-as-from))  
5500      (run-hooks 'message-header-setup-hook))      (run-hooks 'message-header-setup-hook))
5501    (set-buffer-modified-p nil)    (set-buffer-modified-p nil)
5502    (setq buffer-undo-list nil)    (setq buffer-undo-list nil)
# Line 3713  than 988 characters long, and if they ar Line 5513  than 988 characters long, and if they ar
5513      (if (gnus-alive-p)      (if (gnus-alive-p)
5514          (setq message-draft-article          (setq message-draft-article
5515                (nndraft-request-associate-buffer "drafts"))                (nndraft-request-associate-buffer "drafts"))
5516        (setq buffer-file-name (expand-file-name "*message*"        (setq buffer-file-name (expand-file-name
5517                                                 message-auto-save-directory))                                (if (memq system-type
5518                                            '(ms-dos ms-windows windows-nt
5519                                                     cygwin cygwin32 win32 w32
5520                                                     mswindows))
5521                                      "message"
5522                                    "*message*")
5523                                  message-auto-save-directory))
5524        (setq buffer-auto-save-file-name (make-auto-save-file-name)))        (setq buffer-auto-save-file-name (make-auto-save-file-name)))
5525      (clear-visited-file-modtime)      (clear-visited-file-modtime)
5526      (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 5581  OTHER-HEADERS is an alist of header/valu
5581    "Start editing a news article to be sent."    "Start editing a news article to be sent."
5582    (interactive)    (interactive)
5583    (let ((message-this-is-news t))    (let ((message-this-is-news t))
5584      (message-pop-to-buffer (message-buffer-name "news" nil newsgroups))      (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups))
5585      (message-setup `((Newsgroups . ,(or newsgroups ""))      (message-setup `((Newsgroups . ,(or newsgroups ""))
5586                       (Subject . ,(or subject ""))))))                       (Subject . ,(or subject ""))))))
5587    
5588  (defun message-get-reply-headers (wide &optional to-address)  (defun message-get-reply-headers (wide &optional to-address address-headers)
5589    (let (follow-to mct never-mct from to cc reply-to ccalist)    (let (follow-to mct never-mct to cc author mft recipients)
5590      ;; Find all relevant headers we need.      ;; Find all relevant headers we need.
5591      (setq from (message-fetch-field "from")      (save-restriction
5592            to (message-fetch-field "to")        (message-narrow-to-headers-or-head)
5593            cc (message-fetch-field "cc")        ;; Gmane renames "To".  Look at "Original-To", too, if it is present in
5594            mct (message-fetch-field "mail-copies-to")        ;; message-header-synonyms.
5595            reply-to (message-fetch-field "reply-to"))        (setq to (or (message-fetch-field "to")
5596                       (and (loop for synonym in message-header-synonyms
5597                                  when (memq 'Original-To synonym)
5598                                  return t)
5599                            (message-fetch-field "original-to")))
5600                cc (message-fetch-field "cc")
5601                mct (message-fetch-field "mail-copies-to")
5602                author (or (message-fetch-field "mail-reply-to")
5603                           (message-fetch-field "reply-to")
5604                           (message-fetch-field "from")
5605                           "")
5606                mft (and message-use-mail-followup-to
5607                         (message-fetch-field "mail-followup-to"))))
5608    
5609      ;; Handle special values of Mail-Copies-To.      ;; Handle special values of Mail-Copies-To.
5610      (when mct      (when mct
# Line 3796  OTHER-HEADERS is an alist of header/valu Line 5614  OTHER-HEADERS is an alist of header/valu
5614               (setq mct nil))               (setq mct nil))
5615              ((or (equal (downcase mct) "always")              ((or (equal (downcase mct) "always")
5616                   (equal (downcase mct) "poster"))                   (equal (downcase mct) "poster"))
5617               (setq mct (or reply-to from)))))               (setq mct author))))
5618    
5619      (if (or (not wide)      (save-match-data
5620              to-address)        ;; Build (textual) list of new recipient addresses.
5621          (progn        (cond
5622            (setq follow-to (list (cons 'To (or to-address reply-to from))))         ((not wide)
5623            (when (and wide mct)          (setq recipients (concat ", " author)))
5624              (push (cons 'Cc mct) follow-to)))         (address-headers
5625        (let (ccalist)          (dolist (header address-headers)
5626          (save-excursion            (let ((value (message-fetch-field header)))
5627            (message-set-work-buffer)              (when value
5628            (unless never-mct                (setq recipients (concat recipients ", " value))))))
5629              (insert (or reply-to from "")))         ((and mft
5630            (insert (if to (concat (if (bolp) "" ", ") to "") ""))               (string-match "[^ \t,]" mft)
5631            (insert (if mct (concat (if (bolp) "" ", ") mct) ""))               (or (not (eq message-use-mail-followup-to 'ask))
5632            (insert (if cc (concat (if (bolp) "" ", ") cc) ""))                   (message-y-or-n-p "Obey Mail-Followup-To? " t "\
5633            (goto-char (point-min))  You should normally obey the Mail-Followup-To: header.  In this
5634            (while (re-search-forward "[ \t]+" nil t)  article, it has the value of
5635              (replace-match " " t t))  
5636            ;; Remove addresses that match `rmail-dont-reply-to-names'.  " mft "
5637            (let ((rmail-dont-reply-to-names message-dont-reply-to-names))  
5638              (insert (prog1 (rmail-dont-reply-to (buffer-string))  which directs your response to " (if (string-match "," mft)
5639                        (erase-buffer))))                                       "the specified addresses"
5640            (goto-char (point-min))                                     "that address only") ".
5641            ;; Perhaps "Mail-Copies-To: never" removed the only address?  
5642            (when (eobp)  Most commonly, Mail-Followup-To is used by a mailing list poster to
5643              (insert (or reply-to from "")))  express that responses should be sent to just the list, and not the
5644            (setq ccalist  poster as well.
5645                  (mapcar  
5646                   (lambda (addr)  If a message is posted to several mailing lists, Mail-Followup-To may
5647                     (cons (mail-strip-quoted-names addr) addr))  also be used to direct the following discussion to one list only,
5648                   (message-tokenize-header (buffer-string))))  because discussions that are spread over several lists tend to be
5649            (let ((s ccalist))  fragmented and very difficult to follow.
5650              (while s  
5651                (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))  Also, some source/announcement lists are not intended for discussion;
5652          (setq follow-to (list (cons 'To (cdr (pop ccalist)))))  responses here are directed to other addresses.")))
5653          (when ccalist          (setq recipients (concat ", " mft)))
5654            (let ((ccs (cons 'Cc (mapconcat         (to-address
5655                                  (lambda (addr) (cdr addr)) ccalist ", "))))          (setq recipients (concat ", " to-address))
5656              (when (string-match "^ +" (cdr ccs))          ;; If the author explicitly asked for a copy, we don't deny it to them.
5657                (setcdr ccs (substring (cdr ccs) (match-end 0))))          (if mct (setq recipients (concat recipients ", " mct))))
5658              (push ccs follow-to)))))         (t
5659            (setq recipients (if never-mct "" (concat ", " author)))
5660            (if to  (setq recipients (concat recipients ", " to)))
5661            (if cc  (setq recipients (concat recipients ", " cc)))
5662            (if mct (setq recipients (concat recipients ", " mct)))))
5663          (if (>= (length recipients) 2)
5664              ;; Strip the leading ", ".
5665              (setq recipients (substring recipients 2)))
5666          ;; Squeeze whitespace.
5667          (while (string-match "[ \t][ \t]+" recipients)
5668            (setq recipients (replace-match " " t t recipients)))
5669          ;; Remove addresses that match `rmail-dont-reply-to-names'.
5670          (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
5671            (setq recipients (rmail-dont-reply-to recipients)))
5672          ;; Perhaps "Mail-Copies-To: never" removed the only address?
5673          (if (string-equal recipients "")
5674              (setq recipients author))
5675          ;; Convert string to a list of (("foo@bar" . "Name <Foo@BAR>") ...).
5676          (setq recipients
5677                (mapcar
5678                 (lambda (addr)
5679                   (cons (downcase (mail-strip-quoted-names addr)) addr))
5680                 (message-tokenize-header recipients)))
5681          ;; Remove first duplicates.  (Why not all duplicates?  Is this a bug?)
5682          (let ((s recipients))
5683            (while s
5684              (setq recipients (delq (assoc (car (pop s)) s) recipients))))
5685    
5686          ;; Remove hierarchical lists that are contained within each other,
5687          ;; if message-hierarchical-addresses is defined.
5688          (when message-hierarchical-addresses
5689            (let ((plain-addrs (mapcar 'car recipients))
5690                  subaddrs recip)
5691              (while plain-addrs
5692                (setq subaddrs (assoc (car plain-addrs)
5693                                      message-hierarchical-addresses)
5694                      plain-addrs (cdr plain-addrs))
5695                (when subaddrs
5696                  (setq subaddrs (cdr subaddrs))
5697                  (while subaddrs
5698                    (setq recip (assoc (car subaddrs) recipients)
5699                          subaddrs (cdr subaddrs))
5700                    (if recip
5701                        (setq recipients (delq recip recipients))))))))
5702    
5703          ;; Build the header alist.  Allow the user to be asked whether
5704          ;; or not to reply to all recipients in a wide reply.
5705          (setq follow-to (list (cons 'To (cdr (pop recipients)))))
5706          (when (and recipients
5707                     (or (not message-wide-reply-confirm-recipients)
5708                         (y-or-n-p "Reply to all recipients? ")))
5709            (setq recipients (mapconcat
5710                              (lambda (addr) (cdr addr)) recipients ", "))
5711            (if (string-match "^ +" recipients)
5712                (setq recipients (substring recipients (match-end 0))))
5713            (push (cons 'Cc recipients) follow-to)))
5714      follow-to))      follow-to))
5715    
   
5716  ;;;###autoload  ;;;###autoload
5717  (defun message-reply (&optional to-address wide)  (defun message-reply (&optional to-address wide)
5718    "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 5729  OTHER-HEADERS is an alist of header/valu
5729        ;; Allow customizations to have their say.        ;; Allow customizations to have their say.
5730        (if (not wide)        (if (not wide)
5731            ;; This is a regular reply.            ;; This is a regular reply.
5732            (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)  
5733              (save-excursion              (save-excursion
5734                (setq follow-to                (setq follow-to (funcall message-reply-to-function))))
5735                      (funcall message-wide-reply-to-function)))))          ;; This is a followup.
5736            (when (functionp message-wide-reply-to-function)
5737              (save-excursion
5738                (setq follow-to
5739                      (funcall message-wide-reply-to-function)))))
5740        (setq message-id (message-fetch-field "message-id" t)        (setq message-id (message-fetch-field "message-id" t)
5741              references (message-fetch-field "references")              references (message-fetch-field "references")
5742              date (message-fetch-field "date")              date (message-fetch-field "date")
5743              from (message-fetch-field "from")              from (message-fetch-field "from")
5744              subject (or (message-fetch-field "subject") "none"))              subject (or (message-fetch-field "subject") "none"))
5745      (if gnus-list-identifiers        (when gnus-list-identifiers
5746          (setq subject (message-strip-list-identifiers subject)))          (setq subject (message-strip-list-identifiers subject)))
5747      (setq subject (concat "Re: " (message-strip-subject-re subject)))        (setq subject (concat "Re: " (message-strip-subject-re subject)))
5748          (when message-subject-trailing-was-query
5749            (setq subject (message-strip-subject-trailing-was subject)))
5750    
5751      (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))        (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
5752                 (string-match "<[^>]+>" gnus-warning))                   (string-match "<[^>]+>" gnus-warning))
5753        (setq message-id (match-string 0 gnus-warning)))          (setq message-id (match-string 0 gnus-warning)))
5754    
5755      (unless follow-to        (unless follow-to
5756        (setq follow-to (message-get-reply-headers wide to-address))))          (setq follow-to (message-get-reply-headers wide to-address))))
5757    
5758      (unless (message-mail-user-agent)      (unless (message-mail-user-agent)
5759        (message-pop-to-buffer        (message-pop-to-buffer
# Line 3891  OTHER-HEADERS is an alist of header/valu Line 5766  OTHER-HEADERS is an alist of header/valu
5766    
5767      (message-setup      (message-setup
5768       `((Subject . ,subject)       `((Subject . ,subject)
5769         ,@follow-to         ,@follow-to)
        ,@(if (or references message-id)  
              `((References . ,(concat (or references "") (and references " ")  
                                       (or message-id ""))))  
            nil))  
5770       cur)))       cur)))
5771    
5772  ;;;###autoload  ;;;###autoload
# Line 3911  If TO-NEWSGROUPS, use that as the new Ne Line 5782  If TO-NEWSGROUPS, use that as the new Ne
5782    (interactive)    (interactive)
5783    (require 'gnus-sum)                   ; for gnus-list-identifiers    (require 'gnus-sum)                   ; for gnus-list-identifiers
5784    (let ((cur (current-buffer))    (let ((cur (current-buffer))
5785          from subject date reply-to mct          from subject date reply-to mrt mct
5786          references message-id follow-to          references message-id follow-to
5787          (inhibit-point-motion-hooks t)          (inhibit-point-motion-hooks t)
5788          (message-this-is-news t)          (message-this-is-news t)
# Line 3922  If TO-NEWSGROUPS, use that as the new Ne Line 5793  If TO-NEWSGROUPS, use that as the new Ne
5793         (if (search-forward "\n\n" nil t)         (if (search-forward "\n\n" nil t)
5794             (1- (point))             (1- (point))
5795           (point-max)))           (point-max)))
5796        (when (message-functionp message-followup-to-function)        (when (functionp message-followup-to-function)
5797          (setq follow-to          (setq follow-to
5798                (funcall message-followup-to-function)))                (funcall message-followup-to-function)))
5799        (setq from (message-fetch-field "from")        (setq from (message-fetch-field "from")
# Line 3934  If TO-NEWSGROUPS, use that as the new Ne Line 5805  If TO-NEWSGROUPS, use that as the new Ne
5805              newsgroups (message-fetch-field "newsgroups")              newsgroups (message-fetch-field "newsgroups")
5806              posted-to (message-fetch-field "posted-to")              posted-to (message-fetch-field "posted-to")
5807              reply-to (message-fetch-field "reply-to")              reply-to (message-fetch-field "reply-to")
5808                mrt (message-fetch-field "mail-reply-to")
5809              distribution (message-fetch-field "distribution")              distribution (message-fetch-field "distribution")
5810              mct (message-fetch-field "mail-copies-to"))              mct (message-fetch-field "mail-copies-to"))
5811        (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 5819  If TO-NEWSGROUPS, use that as the new Ne
5819        (if gnus-list-identifiers        (if gnus-list-identifiers
5820            (setq subject (message-strip-list-identifiers subject)))            (setq subject (message-strip-list-identifiers subject)))
5821        (setq subject (concat "Re: " (message-strip-subject-re subject)))        (setq subject (concat "Re: " (message-strip-subject-re subject)))
5822          (when message-subject-trailing-was-query
5823            (setq subject (message-strip-subject-trailing-was subject)))
5824        (widen))        (widen))
5825    
5826      (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))      (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
5827    
5828        (setq message-reply-headers
5829              (vector 0 subject from date message-id references 0 0 ""))
5830    
5831      (message-setup      (message-setup
5832       `((Subject . ,subject)       `((Subject . ,subject)
5833         ,@(cond         ,@(cond
# Line 3971  A typical situation where `Followup-To: Line 5848  A typical situation where `Followup-To:
5848  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."))
5849                    (progn                    (progn
5850                      (setq message-this-is-news nil)                      (setq message-this-is-news nil)
5851                      (cons 'To (or reply-to from "")))                      (cons 'To (or mrt reply-to from "")))
5852                  (cons 'Newsgroups newsgroups)))                  (cons 'Newsgroups newsgroups)))
5853               (t               (t
5854                (if (or (equal followup-to newsgroups)                (if (or (equal followup-to newsgroups)
# Line 3990  used to direct the following discussion Line 5867  used to direct the following discussion
5867  because discussions that are spread over several newsgroup tend to  because discussions that are spread over several newsgroup tend to
5868  be fragmented and very difficult to follow.  be fragmented and very difficult to follow.
5869    
5870  Also, some source/announcement newsgroups are not indented for discussion;  Also, some source/announcement newsgroups are not intended for discussion;
5871  responses here are directed to other newsgroups."))  responses here are directed to other newsgroups."))
5872                    (cons 'Newsgroups followup-to)                    (cons 'Newsgroups followup-to)
5873                  (cons 'Newsgroups newsgroups))))))                  (cons 'Newsgroups newsgroups))))))
# Line 3999  responses here are directed to other new Line 5876  responses here are directed to other new
5876            (t            (t
5877             `((Newsgroups . ,newsgroups))))             `((Newsgroups . ,newsgroups))))
5878         ,@(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 "")))))  
5879         ,@(when (and mct         ,@(when (and mct
5880                      (not (or (equal (downcase mct) "never")                      (not (or (equal (downcase mct) "never")
5881                               (equal (downcase mct) "nobody"))))                               (equal (downcase mct) "nobody"))))
5882             (list (cons 'Cc (if (or (equal (downcase mct) "always")             (list (cons 'Cc (if (or (equal (downcase mct) "always")
5883                                     (equal (downcase mct) "poster"))                                     (equal (downcase mct) "poster"))
5884                                 (or reply-to from "")                                 (or mrt reply-to from "")
5885                               mct)))))                               mct)))))
5886    
5887       cur)       cur)))
   
     (setq message-reply-headers  
           (vector 0 subject from date message-id references 0 0 ""))))  
5888    
5889    (defun message-is-yours-p ()
5890      "Non-nil means current article is yours.
5891    If you have added 'cancel-messages to 'message-shoot-gnksa-feet', all articles
5892    are yours except those that have Cancel-Lock header not belonging to you.
5893    Instead of shooting GNKSA feet, you should modify 'message-alternative-emails'
5894    regexp to match all of yours addresses."
5895      ;; Canlock-logic as suggested by Per Abrahamsen
5896      ;; <abraham@dina.kvl.dk>
5897      ;;
5898      ;; IF article has cancel-lock THEN
5899      ;;   IF we can verify it THEN
5900      ;;     issue cancel
5901      ;;   ELSE
5902      ;;     error: cancellock: article is not yours
5903      ;; ELSE
5904      ;;   Use old rules, comparing sender...
5905      (save-excursion
5906        (save-restriction
5907          (message-narrow-to-head-1)
5908          (if (message-fetch-field "Cancel-Lock")
5909              (if (null (canlock-verify))
5910                  t
5911                (error "Failed to verify Cancel-lock: This article is not yours"))
5912            (let (sender from)
5913              (or
5914               (message-gnksa-enable-p 'cancel-messages)
5915               (and (setq sender (message-fetch-field "sender"))
5916                    (string-equal (downcase sender)
5917                                  (downcase (message-make-sender))))
5918               ;; Email address in From field equals to our address
5919               (and (setq from (message-fetch-field "from"))
5920                    (string-equal
5921                     (downcase (cadr (mail-extract-address-components from)))
5922                     (downcase (cadr (mail-extract-address-components
5923                                      (message-make-from))))))
5924               ;; Email address in From field matches
5925               ;; 'message-alternative-emails' regexp
5926               (and from
5927                    message-alternative-emails
5928                    (string-match
5929                     message-alternative-emails
5930                     (cadr (mail-extract-address-components from))))))))))
5931    
5932  ;;;###autoload  ;;;###autoload
5933  (defun message-cancel-news (&optional arg)  (defun message-cancel-news (&optional arg)
# Line 4023  If ARG, allow editing of the cancellatio Line 5936  If ARG, allow editing of the cancellatio
5936    (interactive "P")    (interactive "P")
5937    (unless (message-news-p)    (unless (message-news-p)
5938      (error "This is not a news article; canceling is impossible"))      (error "This is not a news article; canceling is impossible"))
5939    (when (yes-or-no-p "Do you really want to cancel this article? ")    (let (from newsgroups message-id distribution buf)
5940      (let (from newsgroups message-id distribution buf sender)      (save-excursion
5941        (save-excursion        ;; Get header info from original article.
5942          ;; Get header info from original article.        (save-restriction
5943          (save-restriction          (message-narrow-to-head-1)
5944            (message-narrow-to-head-1)          (setq from (message-fetch-field "from")
5945            (setq from (message-fetch-field "from")                newsgroups (message-fetch-field "newsgroups")
5946                  sender (message-fetch-field "sender")                message-id (message-fetch-field "message-id" t)
5947                  newsgroups (message-fetch-field "newsgroups")                distribution (message-fetch-field "distribution")))
5948                  message-id (message-fetch-field "message-id" t)        ;; Make sure that this article was written by the user.
5949                  distribution (message-fetch-field "distribution")))        (unless (message-is-yours-p)
5950          ;; Make sure that this article was written by the user.          (error "This article is not yours"))
5951          (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"))  
5952          ;; Make control message.          ;; Make control message.
5953          (if arg          (if arg
5954              (message-news)              (message-news)
5955            (setq buf (set-buffer (get-buffer-create " *message cancel*"))))            (setq buf (set-buffer (get-buffer-create " *message cancel*"))))
5956          (erase-buffer)          (erase-buffer)
5957          (insert "Newsgroups: " newsgroups "\n"          (insert "Newsgroups: " newsgroups "\n"
5958                 "From: " from "\n"                  "From: " from "\n"
5959                  "Subject: cmsg cancel " message-id "\n"                  "Subject: cmsg cancel " message-id "\n"
5960                  "Control: cancel " message-id "\n"                  "Control: cancel " message-id "\n"
5961                  (if distribution                  (if distribution
# Line 4073  If ARG, allow editing of the cancellatio Line 5978  If ARG, allow editing of the cancellatio
5978  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
5979  header line with the old Message-ID."  header line with the old Message-ID."
5980    (interactive)    (interactive)
5981    (let ((cur (current-buffer))    (let ((cur (current-buffer)))
         (sender (message-fetch-field "sender"))  
         (from (message-fetch-field "from")))  
5982      ;; Check whether the user owns the article that is to be superseded.      ;; Check whether the user owns the article that is to be superseded.
5983      (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))))))  
5984        (error "This article is not yours"))        (error "This article is not yours"))
5985      ;; Get a normal message buffer.      ;; Get a normal message buffer.
5986      (message-pop-to-buffer (message-buffer-name "supersede"))      (message-pop-to-buffer (message-buffer-name "supersede"))
# Line 4161  Previous forwarders, replyers, etc. may Line 6057  Previous forwarders, replyers, etc. may
6057  (defvar message-forward-decoded-p nil  (defvar message-forward-decoded-p nil
6058    "Non-nil means the original message is decoded.")    "Non-nil means the original message is decoded.")
6059    
6060    (defun message-forward-subject-name-subject (subject)
6061      "Generate a SUBJECT for a forwarded message.
6062    The form is: [Source] Subject, where if the original message was mail,
6063    Source is the name of the sender, and if the original message was
6064    news, Source is the list of newsgroups is was posted to."
6065      (let* ((group (message-fetch-field "newsgroups"))
6066             (from (message-fetch-field "from"))
6067             (prefix
6068              (if group
6069                  (gnus-group-decoded-name group)
6070                (or (and from (car (gnus-extract-address-components from)))
6071                    "(nowhere)"))))
6072        (concat "["
6073                (if message-forward-decoded-p
6074                    prefix
6075                  (mail-decode-encoded-word-string prefix))
6076                "] " subject)))
6077    
6078  (defun message-forward-subject-author-subject (subject)  (defun message-forward-subject-author-subject (subject)
6079    "Generate a SUBJECT for a forwarded message.    "Generate a SUBJECT for a forwarded message.
6080  The form is: [Source] Subject, where if the original message was mail,  The form is: [Source] Subject, where if the original message was mail,
6081  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
6082  the list of newsgroups is was posted to."  the list of newsgroups is was posted to."
6083    (concat "["    (let* ((group (message-fetch-field "newsgroups"))
6084             (let ((prefix           (prefix
6085                    (or (message-fetch-field "newsgroups")            (if group
6086                        (message-fetch-field "from")                (gnus-group-decoded-name group)
6087                        "(nowhere)")))              (or (message-fetch-field "from")
6088               (if message-forward-decoded-p                  "(nowhere)"))))
6089                   prefix      (concat "["
6090                 (mail-decode-encoded-word-string prefix)))              (if message-forward-decoded-p
6091            "] " subject))                  prefix
6092                  (mail-decode-encoded-word-string prefix))
6093                "] " subject)))
6094    
6095  (defun message-forward-subject-fwd (subject)  (defun message-forward-subject-fwd (subject)
6096    "Generate a SUBJECT for a forwarded message.    "Generate a SUBJECT for a forwarded message.
6097  The form is: Fwd: Subject, where Subject is the original subject of  The form is: Fwd: Subject, where Subject is the original subject of
6098  the message."  the message."
6099    (concat "Fwd: " subject))    (if (string-match "^Fwd: " subject)
6100          subject
6101        (concat "Fwd: " subject)))
6102    
6103  (defun message-make-forward-subject ()  (defun message-make-forward-subject ()
6104    "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 6122  the message."
6122          ;; Apply funcs in order, passing subject generated by previous          ;; Apply funcs in order, passing subject generated by previous
6123          ;; func to the next one.          ;; func to the next one.
6124          (while funcs          (while funcs
6125            (when (message-functionp (car funcs))            (when (functionp (car funcs))
6126              (setq subject (funcall (car funcs) subject)))              (setq subject (funcall (car funcs) subject)))
6127            (setq funcs (cdr funcs)))            (setq funcs (cdr funcs)))
6128          subject))))          subject))))
# Line 4230  Optional DIGEST will use digest to forwa Line 6148  Optional DIGEST will use digest to forwa
6148        (message-mail nil subject))        (message-mail nil subject))
6149      (message-forward-make-body cur digest)))      (message-forward-make-body cur digest)))
6150    
6151    (defun message-forward-make-body-plain (forward-buffer)
6152      (insert
6153       "\n-------------------- Start of forwarded message --------------------\n")
6154      (let ((b (point)) e)
6155        (insert
6156         (with-temp-buffer
6157           (mm-disable-multibyte)
6158           (insert
6159            (with-current-buffer forward-buffer
6160              (mm-with-unibyte-current-buffer (buffer-string))))
6161           (mm-enable-multibyte)
6162           (mime-to-mml)
6163           (goto-char (point-min))
6164           (when (looking-at "From ")
6165             (replace-match "X-From-Line: "))
6166           (buffer-string)))
6167        (setq e (point))
6168        (insert
6169         "\n-------------------- End of forwarded message --------------------\n")
6170        (when (and (not current-prefix-arg)
6171                   message-forward-ignored-headers)
6172          (save-restriction
6173            (narrow-to-region b e)
6174            (goto-char b)
6175            (narrow-to-region (point)
6176                              (or (search-forward "\n\n" nil t) (point)))
6177            (message-remove-header message-forward-ignored-headers t)))))
6178    
6179    (defun message-forward-make-body-mime (forward-buffer)
6180      (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")
6181      (let ((b (point)) e)
6182        (save-restriction
6183          (narrow-to-region (point) (point))
6184          (mml-insert-buffer forward-buffer)
6185          (goto-char (point-min))
6186          (when (looking-at "From ")
6187            (replace-match "X-From-Line: "))
6188          (goto-char (point-max)))
6189        (setq e (point))
6190        (insert "<#/part>\n")))
6191    
6192    (defun message-forward-make-body-mml (forward-buffer)
6193      (insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
6194      (let ((b (point)) e)
6195        (if (not message-forward-decoded-p)
6196            (insert
6197             (with-temp-buffer
6198               (mm-disable-multibyte)
6199               (insert
6200                (with-current-buffer forward-buffer
6201                  (mm-with-unibyte-current-buffer (buffer-string))))
6202               (mm-enable-multibyte)
6203               (mime-to-mml)
6204               (goto-char (point-min))
6205               (when (looking-at "From ")
6206                 (replace-match "X-From-Line: "))
6207               (buffer-string)))
6208          (save-restriction
6209            (narrow-to-region (point) (point))
6210            (mml-insert-buffer forward-buffer)
6211            (goto-char (point-min))
6212            (when (looking-at "From ")
6213              (replace-match "X-From-Line: "))
6214            (goto-char (point-max))))
6215        (setq e (point))
6216        (insert "<#/mml>\n")
6217        (when (and (not current-prefix-arg)
6218                   message-forward-ignored-headers)
6219          (save-restriction
6220            (narrow-to-region b e)
6221            (goto-char b)
6222            (narrow-to-region (point)
6223                              (or (search-forward "\n\n" nil t) (point)))
6224            (message-remove-header message-forward-ignored-headers t)))))
6225    
6226    (defun message-forward-make-body-digest-plain (forward-buffer)
6227      (insert
6228       "\n-------------------- Start of forwarded message --------------------\n")
6229      (let ((b (point)) e)
6230        (mml-insert-buffer forward-buffer)
6231        (setq e (point))
6232        (insert
6233         "\n-------------------- End of forwarded message --------------------\n")))
6234    
6235    (defun message-forward-make-body-digest-mime (forward-buffer)
6236      (insert "\n<#multipart type=digest>\n")
6237      (let ((b (point)) e)
6238        (insert-buffer-substring forward-buffer)
6239        (setq e (point))
6240        (insert "<#/multipart>\n")
6241        (save-restriction
6242          (narrow-to-region b e)
6243          (goto-char b)
6244          (narrow-to-region (point)
6245                            (or (search-forward "\n\n" nil t) (point)))
6246          (delete-region (point-min) (point-max)))))
6247    
6248    (defun message-forward-make-body-digest (forward-buffer)
6249      (if message-forward-as-mime
6250          (message-forward-make-body-digest-mime forward-buffer)
6251        (message-forward-make-body-digest-plain forward-buffer)))
6252    
6253  ;;;###autoload  ;;;###autoload
6254  (defun message-forward-make-body (forward-buffer &optional digest)  (defun message-forward-make-body (forward-buffer &optional digest)
6255    ;; 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 6257  Optional DIGEST will use digest to forwa
6257    (if message-forward-before-signature    (if message-forward-before-signature
6258        (message-goto-body)        (message-goto-body)
6259      (goto-char (point-max)))      (goto-char (point-max)))
6260    (if message-forward-as-mime    (if digest
6261        (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))  
6262      (if message-forward-as-mime      (if message-forward-as-mime
6263          (if digest          (if (and message-forward-show-mml
6264              (insert "<#/multipart>\n")                   (not (and (eq message-forward-show-mml 'best)
6265            (if message-forward-show-mml                             (with-current-buffer forward-buffer
6266                (insert "<#/mml>\n")                               (goto-char (point-min))
6267              (insert "<#/part>\n")))                               (re-search-forward
6268        (insert "\n-------------------- End of forwarded message --------------------\n"))                                "Content-Type: *multipart/\\(signed\\|encrypted\\)"
6269      (if (and digest message-forward-as-mime)                                nil t)))))
6270          (save-restriction              (message-forward-make-body-mml forward-buffer)
6271            (narrow-to-region b e)            (message-forward-make-body-mime forward-buffer))
6272            (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)))))  
6273    (message-position-point))    (message-position-point))
6274    
6275  ;;;###autoload  ;;;###autoload
6276  (defun message-forward-rmail-make-body (forward-buffer)  (defun message-forward-rmail-make-body (forward-buffer)
6277    (save-window-excursion    (save-window-excursion
6278      (set-buffer forward-buffer)      (set-buffer forward-buffer)
6279        ;; Rmail doesn't have rmail-msg-restore-non-pruned-header in Emacs
6280        ;; 20.  FIXIT, or we drop support for rmail in Emacs 20.
6281      (if (rmail-msg-is-pruned)      (if (rmail-msg-is-pruned)
6282          (rmail-msg-restore-non-pruned-header)))          (rmail-msg-restore-non-pruned-header)))
6283    (message-forward-make-body forward-buffer))    (message-forward-make-body forward-buffer))
6284    
6285    (eval-when-compile (defvar rmail-enable-mime-composing))
6286    
6287    ;; Fixme: Should have defcustom.
6288  ;;;###autoload  ;;;###autoload
6289  (defun message-insinuate-rmail ()  (defun message-insinuate-rmail ()
6290    "Let RMAIL uses message to forward."    "Let RMAIL use message to forward."
6291    (interactive)    (interactive)
6292    (setq rmail-enable-mime-composing t)    (setq rmail-enable-mime-composing t)
6293    (setq rmail-insert-mime-forwarded-message-function    (setq rmail-insert-mime-forwarded-message-function
# Line 4324  Optional DIGEST will use digest to forwa Line 6306  Optional DIGEST will use digest to forwa
6306        (unless (message-mail-user-agent)        (unless (message-mail-user-agent)
6307          (set-buffer (get-buffer-create " *message resend*"))          (set-buffer (get-buffer-create " *message resend*"))
6308          (erase-buffer))          (erase-buffer))
6309        (let ((message-this-is-mail t))        (let ((message-this-is-mail t)
6310                message-setup-hook)
6311          (message-setup `((To . ,address))))          (message-setup `((To . ,address))))
6312        ;; Insert our usual headers.        ;; Insert our usual headers.
6313        (message-generate-headers '(From Date To))        (message-generate-headers '(From Date To Message-ID))
6314        (message-narrow-to-headers)        (message-narrow-to-headers)
6315          ;; Remove X-Draft-From header etc.
6316          (message-remove-header message-ignored-mail-headers t)
6317        ;; Rename them all to "Resent-*".        ;; Rename them all to "Resent-*".
6318          (goto-char (point-min))
6319        (while (re-search-forward "^[A-Za-z]" nil t)        (while (re-search-forward "^[A-Za-z]" nil t)
6320          (forward-char -1)          (forward-char -1)
6321          (insert "Resent-"))          (insert "Resent-"))
# Line 4380  you." Line 6366  you."
6366        (mm-insert-part handles)        (mm-insert-part handles)
6367        (undo-boundary)        (undo-boundary)
6368        (goto-char (point-min))        (goto-char (point-min))
6369        (search-forward "\n\n" nil t)        (re-search-forward "\n\n+" nil t)
6370        (or (and (re-search-forward message-unsent-separator nil t)        (setq boundary (point))
                (forward-line 1))  
           (re-search-forward "^Return-Path:.*\n" nil t))  
6371        ;; We remove everything before the bounced mail.        ;; We remove everything before the bounced mail.
6372        (delete-region        (if (or (re-search-forward message-unsent-separator nil t)
6373         (point-min)                (progn
6374         (if (re-search-forward "^[^ \n\t]+:" nil t)                  (search-forward "\n\n" nil 'move)
6375             (match-beginning 0)                  (re-search-backward "^Return-Path:.*\n" boundary t)))
6376           (point))))            (progn
6377                (forward-line 1)
6378                (delete-region (point-min)
6379                               (if (re-search-forward "^[^ \n\t]+:" nil t)
6380                                   (match-beginning 0)
6381                                 (point))))
6382            (goto-char boundary)
6383            (when (re-search-backward "^.?From .*\n" nil t)
6384              (delete-region (match-beginning 0) (match-end 0)))))
6385      (mm-enable-multibyte)      (mm-enable-multibyte)
     (mime-to-mml)  
6386      (save-restriction      (save-restriction
6387        (message-narrow-to-head-1)        (message-narrow-to-head-1)
6388        (message-remove-header message-ignored-bounced-headers t)        (message-remove-header message-ignored-bounced-headers t)
# Line 4442  you." Line 6433  you."
6433          (special-display-regexps nil)          (special-display-regexps nil)
6434          (same-window-buffer-names nil)          (same-window-buffer-names nil)
6435          (same-window-regexps nil))          (same-window-regexps nil))
6436      (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))      (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)))
6437    (let ((message-this-is-news t))    (let ((message-this-is-news t))
6438      (message-setup `((Newsgroups . ,(or newsgroups ""))      (message-setup `((Newsgroups . ,(or newsgroups ""))
6439                       (Subject . ,(or subject ""))))))                       (Subject . ,(or subject ""))))))
# Line 4456  you." Line 6447  you."
6447          (special-display-regexps nil)          (special-display-regexps nil)
6448          (same-window-buffer-names nil)          (same-window-buffer-names nil)
6449          (same-window-regexps nil))          (same-window-regexps nil))
6450      (message-pop-to-buffer (message-buffer-name "news" nil newsgroups)))      (message-pop-to-buffer (message-buffer-name "posting" nil newsgroups)))
6451    (let ((message-this-is-news t))    (let ((message-this-is-news t))
6452      (message-setup `((Newsgroups . ,(or newsgroups ""))      (message-setup `((Newsgroups . ,(or newsgroups ""))
6453                       (Subject . ,(or subject ""))))))                       (Subject . ,(or subject ""))))))
# Line 4496  which specify the range to operate on." Line 6487  which specify the range to operate on."
6487              (delete-char -2))))))              (delete-char -2))))))
6488    
6489  (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)  (defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
6490    (defalias 'message-make-overlay 'make-overlay)
6491    (defalias 'message-delete-overlay 'delete-overlay)
6492    (defalias 'message-overlay-put 'overlay-put)
6493    (defun message-kill-all-overlays ()
6494      (if (featurep 'xemacs)
6495          (map-extents (lambda (extent ignore) (delete-extent extent)))
6496        (mapcar #'delete-overlay (overlays-in (point-min) (point-max)))))
6497    
6498  ;; Support for toolbar  ;; Support for toolbar
6499  (eval-when-compile (defvar tool-bar-map))  (eval-when-compile
6500  (if (featurep 'xemacs)    (defvar tool-bar-map)
6501      (require 'messagexmas)    (defvar tool-bar-mode))
6502    (when (and  
6503           (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)
6504           (fboundp 'tool-bar-add-item-from-menu)    ;; We need to make tool bar entries in local keymaps with
6505           tool-bar-mode)    ;; `tool-bar-local-item-from-menu' in Emacs > 21.3
6506      (defvar message-tool-bar-map    (if (fboundp 'tool-bar-local-item-from-menu)
6507        (let ((tool-bar-map (copy-keymap tool-bar-map)))        ;; This is for Emacs 21.3
6508          ;; 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)
6509          (dolist (key '(print-buffer kill-buffer save-buffer write-file      (tool-bar-add-item-from-menu command icon from-map props)))
6510                                      dired open-file))  
6511            (define-key tool-bar-map (vector key) nil))  (defun message-tool-bar-map ()
6512      (or message-tool-bar-map
6513          (tool-bar-add-item-from-menu        (setq message-tool-bar-map
6514           'message-send-and-exit "mail_send" message-mode-map)              (and
6515          (tool-bar-add-item-from-menu               (condition-case nil (require 'tool-bar) (error nil))
6516           'message-kill-buffer "close" message-mode-map)               (fboundp 'tool-bar-add-item-from-menu)
6517          (tool-bar-add-item-from-menu               tool-bar-mode
6518           'message-dont-send "cancel" message-mode-map)               (let ((tool-bar-map (copy-keymap tool-bar-map))
6519          (tool-bar-add-item-from-menu                     (load-path (mm-image-load-path)))
6520           'mml-attach-file "attach" message-mode-map)                 ;; Zap some items which aren't so relevant and take
6521          (tool-bar-add-item-from-menu                 ;; up space.
6522           'ispell-message "spell" message-mode-map)                 (dolist (key '(print-buffer kill-buffer save-buffer
6523          tool-bar-map))))                                             write-file dired open-file))
6524                     (define-key tool-bar-map (vector key) nil))
6525                   (message-tool-bar-local-item-from-menu
6526                    'message-send-and-exit "mail_send" tool-bar-map message-mode-map)
6527                   (message-tool-bar-local-item-from-menu
6528                    'message-kill-buffer "close" tool-bar-map message-mode-map)
6529                   (message-tool-bar-local-item-from-menu
6530                        'message-dont-send "cancel" tool-bar-map message-mode-map)
6531                   (message-tool-bar-local-item-from-menu
6532                    'mml-attach-file "attach" tool-bar-map mml-mode-map)
6533                   (message-tool-bar-local-item-from-menu
6534                    'ispell-message "spell" tool-bar-map message-mode-map)
6535                   (message-tool-bar-local-item-from-menu
6536                    'mml-preview "preview"
6537                    tool-bar-map mml-mode-map)
6538                   (message-tool-bar-local-item-from-menu
6539                    'message-insert-importance-high "important"
6540                    tool-bar-map message-mode-map)
6541                   (message-tool-bar-local-item-from-menu
6542                    'message-insert-importance-low "unimportant"
6543                    tool-bar-map message-mode-map)
6544                   (message-tool-bar-local-item-from-menu
6545                    'message-insert-disposition-notification-to "receipt"
6546                    tool-bar-map message-mode-map)
6547                   tool-bar-map)))))
6548    
6549  ;;; Group name completion.  ;;; Group name completion.
6550    
6551  (defvar message-newgroups-header-regexp  (defcustom message-newgroups-header-regexp
6552    "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"    "^\\(Newsgroups\\|Followup-To\\|Posted-To\\|Gcc\\):"
6553    "Regexp that match headers that lists groups.")    "Regexp that match headers that lists groups."
6554      :group 'message
6555      :type 'regexp)
6556    
6557    (defcustom message-completion-alist
6558      (list (cons message-newgroups-header-regexp 'message-expand-group)
6559            '("^\\(Resent-\\)?\\(To\\|B?Cc\\):" . message-expand-name)
6560            '("^\\(Reply-To\\|From\\|Mail-Followup-To\\|Mail-Copies-To\\):"
6561              . message-expand-name)
6562            '("^\\(Disposition-Notification-To\\|Return-Receipt-To\\):"
6563              . message-expand-name))
6564      "Alist of (RE . FUN).  Use FUN for completion on header lines matching RE."
6565      :group 'message
6566      :type '(alist :key-type regexp :value-type function))
6567    
6568    (defcustom message-tab-body-function nil
6569      "*Function to execute when `message-tab' (TAB) is executed in the body.
6570    If nil, the function bound in `text-mode-map' or `global-map' is executed."
6571      :group 'message
6572      :link '(custom-manual "(message)Various Commands")
6573      :type 'function)
6574    
6575  (defun message-tab ()  (defun message-tab ()
6576    "Expand group names in Newsgroups and Followup-To headers.    "Complete names according to `message-completion-alist'.
6577  Do a `tab-to-tab-stop' if not in those headers."  Execute function specified by `message-tab-body-function' when not in
6578    those headers."
6579    (interactive)    (interactive)
6580    (if (let ((mail-abbrev-mode-regexp message-newgroups-header-regexp))    (let ((alist message-completion-alist))
6581          (mail-abbrev-in-expansion-header-p))      (while (and alist
6582        (message-expand-group)                  (let ((mail-abbrev-mode-regexp (caar alist)))
6583      (tab-to-tab-stop)))                    (not (mail-abbrev-in-expansion-header-p))))
6584          (setq alist (cdr alist)))
6585        (funcall (or (cdar alist) message-tab-body-function
6586                     (lookup-key text-mode-map "\t")
6587                     (lookup-key global-map "\t")
6588                     'indent-relative))))
6589    
6590  (defun message-expand-group ()  (defun message-expand-group ()
6591    "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 6629  Do a `tab-to-tab-stop' if not in those h
6629              (goto-char (point-min))              (goto-char (point-min))
6630              (delete-region (point) (progn (forward-line 3) (point))))))))))              (delete-region (point) (progn (forward-line 3) (point))))))))))
6631    
6632    (defun message-expand-name ()
6633      (if (fboundp 'bbdb-complete-name)
6634          (bbdb-complete-name)
6635        (expand-abbrev)))
6636    
6637  ;;; Help stuff.  ;;; Help stuff.
6638    
6639  (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 6663  The following arguments may contain list
6663           (list list))))           (list list))))
6664    
6665  (defun message-generate-new-buffer-clone-locals (name &optional varstr)  (defun message-generate-new-buffer-clone-locals (name &optional varstr)
6666    "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'.
6667  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
6668  new one, cloning only the locals having a substring matching the  new one, cloning only the locals having a substring matching the
6669  regexp varstr."  regexp VARSTR."
6670    (let ((oldbuf (current-buffer)))    (let ((oldbuf (current-buffer)))
6671      (save-excursion      (save-excursion
6672        (set-buffer (generate-new-buffer name))        (set-buffer (generate-new-buffer name))
# Line 4671  regexp varstr." Line 6724  regexp varstr."
6724          (when lines          (when lines
6725            (insert lines))            (insert lines))
6726          (setq content-type-p          (setq content-type-p
6727                (re-search-backward "^Content-Type:" nil t)))                (or mml-boundary
6728                      (re-search-backward "^Content-Type:" nil t))))
6729        (save-restriction        (save-restriction
6730          (message-narrow-to-headers-or-head)          (message-narrow-to-headers-or-head)
6731          (message-remove-first-header "Content-Type")          (message-remove-first-header "Content-Type")
6732          (message-remove-first-header "Content-Transfer-Encoding"))          (message-remove-first-header "Content-Transfer-Encoding"))
6733        ;; We always make sure that the message has a Content-Type header.        ;; We always make sure that the message has a Content-Type
6734        ;; This is because some broken MTAs and MUAs get awfully confused        ;; header.  This is because some broken MTAs and MUAs get
6735        ;; when confronted with a message with a MIME-Version header and        ;; awfully confused when confronted with a message with a
6736        ;; without a Content-Type header.  For instance, Solaris'        ;; MIME-Version header and without a Content-Type header.  For
6737        ;; /usr/bin/mail.        ;; instance, Solaris' /usr/bin/mail.
6738        (unless content-type-p        (unless content-type-p
6739          (goto-char (point-min))          (goto-char (point-min))
6740          ;; For unknown reason, MIME-Version doesn't exist.          ;; For unknown reason, MIME-Version doesn't exist.
# Line 4688  regexp varstr." Line 6742  regexp varstr."
6742            (forward-line 1)            (forward-line 1)
6743            (insert "Content-Type: text/plain; charset=us-ascii\n"))))))            (insert "Content-Type: text/plain; charset=us-ascii\n"))))))
6744    
6745  (defun message-read-from-minibuffer (prompt)  (defun message-read-from-minibuffer (prompt &optional initial-contents)
6746    "Read from the minibuffer while providing abbrev expansion."    "Read from the minibuffer while providing abbrev expansion."
6747    (if (fboundp 'mail-abbrevs-setup)    (if (fboundp 'mail-abbrevs-setup)
6748        (let ((mail-abbrev-mode-regexp "")        (let ((mail-abbrev-mode-regexp "")
6749              (minibuffer-setup-hook 'mail-abbrevs-setup))              (minibuffer-setup-hook 'mail-abbrevs-setup)
6750          (read-from-minibuffer prompt))              (minibuffer-local-map message-minibuffer-local-map))
6751      (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook))          (read-from-minibuffer prompt initial-contents))
6752        (read-string prompt))))      (let ((minibuffer-setup-hook 'mail-abbrev-minibuffer-setup-hook)
6753              (minibuffer-local-map message-minibuffer-local-map))
6754          (read-string prompt initial-contents))))
6755    
6756  (defun message-use-alternative-email-as-from ()  (defun message-use-alternative-email-as-from ()
6757    (require 'mail-utils)    (require 'mail-utils)
# Line 4715  regexp varstr." Line 6771  regexp varstr."
6771        (goto-char (point-max))        (goto-char (point-max))
6772        (insert "From: " email "\n"))))        (insert "From: " email "\n"))))
6773    
6774    (defun message-options-get (symbol)
6775      (cdr (assq symbol message-options)))
6776    
6777    (defun message-options-set (symbol value)
6778      (let ((the-cons (assq symbol message-options)))
6779        (if the-cons
6780            (if value
6781                (setcdr the-cons value)
6782              (setq message-options (delq the-cons message-options)))
6783          (and value
6784               (push (cons symbol value) message-options))))
6785      value)
6786    
6787    (defun message-options-set-recipient ()
6788      (save-restriction
6789        (message-narrow-to-headers-or-head)
6790        (message-options-set 'message-sender
6791                             (mail-strip-quoted-names
6792                              (message-fetch-field "from")))
6793        (message-options-set 'message-recipients
6794                             (mail-strip-quoted-names
6795                              (let ((to (message-fetch-field "to"))
6796                                    (cc (message-fetch-field "cc"))
6797                                    (bcc (message-fetch-field "bcc")))
6798                                (concat
6799                                 (or to "")
6800                                 (if (and to cc) ", ")
6801                                 (or cc "")
6802                                 (if (and (or to cc) bcc) ", ")
6803                                 (or bcc "")))))))
6804    
6805    (defun message-hide-headers ()
6806      "Hide headers based on the `message-hidden-headers' variable."
6807      (let ((regexps (if (stringp message-hidden-headers)
6808                         (list message-hidden-headers)
6809                       message-hidden-headers))
6810            (inhibit-point-motion-hooks t)
6811            (after-change-functions nil))
6812        (when regexps
6813          (save-excursion
6814            (save-restriction
6815              (message-narrow-to-headers)
6816              (goto-char (point-min))
6817              (while (not (eobp))
6818                (if (not (message-hide-header-p regexps))
6819                    (message-next-header)
6820                  (let ((begin (point)))
6821                    (message-next-header)
6822                    (add-text-properties
6823                     begin (point)
6824                     '(invisible t message-hidden t))))))))))
6825    
6826    (defun message-hide-header-p (regexps)
6827      (let ((result nil)
6828            (reverse nil))
6829        (when (eq (car regexps) 'not)
6830          (setq reverse t)
6831          (pop regexps))
6832        (dolist (regexp regexps)
6833          (setq result (or result (looking-at regexp))))
6834        (if reverse
6835            (not result)
6836          result)))
6837    
6838    (when (featurep 'xemacs)
6839      (require 'messagexmas)
6840      (message-xmas-redefine))
6841    
6842  (provide 'message)  (provide 'message)
6843    
6844  (run-hooks 'message-load-hook)  (run-hooks 'message-load-hook)

Legend:
Removed from v.1.58  
changed lines
  Added in v.1.58.2.1

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