;;; message.el --- composing mail and news messages
-;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+;; Copyright (C) 1996,97,98 Free Software Foundation, Inc.
-;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
;; Keywords: mail, news, MIME
;; This file is part of GNU Emacs.
(const default))
:group 'message-headers)
-(defcustom message-references-generator
- (if (fboundp 'std11-fill-msg-id-list-string)
- (function message-generate-filled-references)
- (function message-generate-folded-references))
- "*Function to generate \"References\" field."
- :type '(radio (function-item message-generate-filled-references)
- (function-item message-generate-folded-references)
- (function-item message-generate-unfolded-references)
- (function :tag "Other"))
- :group 'message-headers)
-
(defcustom message-syntax-checks nil
- ;; Guess this one shouldn't be easy to customize...
- "Controls what syntax checks should not be performed on outgoing posts.
+ ; Guess this one shouldn't be easy to customize...
+ "*Controls what syntax checks should not be performed on outgoing posts.
To disable checking of long signatures, for instance, add
`(signature . disabled)' to this list.
(defcustom message-required-news-headers
'(From Newsgroups Subject Date Message-ID
(optional . Organization) Lines
- (optional . X-Newsreader))
- "Headers to be generated or prompted for when posting an article.
+ (optional . User-Agent))
+ "*Headers to be generated or prompted for when posting an article.
RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
Message-ID. Organization, Lines, In-Reply-To, Expires, and
-X-Newsreader are optional. If don't you want message to insert some
+User-Agent are optional. If don't you want message to insert some
header, remove it from this list."
:group 'message-news
:group 'message-headers
(defcustom message-required-mail-headers
'(From Subject Date (optional . In-Reply-To) Message-ID Lines
- (optional . X-Mailer))
- "Headers to be generated or prompted for when mailing a message.
+ (optional . User-Agent))
+ "*Headers to be generated or prompted for when mailing a message.
RFC822 required that From, Date, To, Subject and Message-ID be
-included. Organization, Lines and X-Mailer are optional."
+included. Organization, Lines and User-Agent are optional."
:group 'message-mail
:group 'message-headers
:type '(repeat sexp))
:group 'message-headers
:type 'regexp)
-(defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:"
+(defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:"
"*Regexp of headers to be removed unconditionally before mailing."
:group 'message-mail
:group 'message-headers
:type 'regexp)
-(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|X-Trace:\\|X-Complaints-To:\\|Return-Path:\\|^Supersedes:"
+(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:"
"*Header lines matching this regexp will be deleted before posting.
It's best to delete old Path and Date headers before posting to avoid
any confusion."
:group 'message-interface
:type 'regexp)
+(defcustom message-subject-re-regexp "^[ \t]*\\([Rr][Ee]:[ \t]*\\)*[ \t]*"
+ "*Regexp matching \"Re: \" in the subject line."
+ :group 'message-various
+ :type 'regexp)
+
+;;; Some sender agents encode the whole subject including leading "Re: ".
+;;; And if followup agent does not decode it for some reason (e.g. unknown
+;;; charset) and just add a new "Re: " in front of the encoded-word, the
+;;; result will contain multiple "Re: "'s.
+(defcustom message-subject-encoded-re-regexp
+ (concat
+ "^[ \t]*"
+ (regexp-quote "=?")
+ "[-!#$%&'*+0-9A-Z^_`a-z{|}~]+" ; charset
+ (regexp-quote "?")
+ "\\("
+ "[Bb]" (regexp-quote "?") ; B encoding
+ "\\(\\(CQk\\|CSA\\|IAk\\|ICA\\)[Jg]\\)*" ; \([ \t][ \t][ \t]\)*
+ "\\("
+ "[Uc][km]U6" ; [Rr][Ee]:
+ "\\|"
+ "\\(C[VX]\\|I[FH]\\)J[Fl]O[g-v]" ; [ \t][Rr][Ee]:
+ "\\|"
+ "\\(CQl\\|CSB\\|IAl\\|ICB\\)[Sy][RZ]T[o-r]" ; [ \t][ \t][Rr][Ee]:
+ "\\)"
+ "\\|"
+ "[Qb]" (regexp-quote "?") ; Q encoding
+ "\\(_\\|=09\\|=20\\)*"
+ "\\([Rr]\\|=[57]2\\)\\([Ee]\\|=[46]5\\)\\(:\\|=3[Aa]\\)"
+ "\\)"
+ )
+ "*Regexp matching \"Re: \" in the subject line.
+Unlike `message-subject-re-regexp', this regexp matches \"Re: \" within
+an encoded-word."
+ :group 'message-various
+ :type 'regexp)
+
+(defcustom message-use-subject-re t
+ "*If t, remove any (buggy) \"Re: \"'s from the subject of the precursor
+and add a new \"Re: \". If it is nil, use the subject \"as-is\". If it
+is the symbol `guess', try to detect \"Re: \" within an encoded-word."
+ :group 'message-various
+ :type '(choice (const :tag "off" nil)
+ (const :tag "on" t)
+ (const guess)))
+
;;;###autoload
(defcustom message-signature-separator "^-- *$"
"Regexp matching the signature separator."
:group 'message-various)
(defcustom message-elide-elipsis "\n[...]\n\n"
- "*The string which is inserted for elided text.")
+ "*The string which is inserted for elided text."
+ :type 'string
+ :group 'message-various)
(defcustom message-interactive nil
"Non-nil means when sending a message wait for and display errors.
:type 'file
:group 'message-headers)
-(defcustom message-autosave-directory
- (nnheader-concat message-directory "drafts/")
- "*Directory where Message autosaves buffers.
-If nil, Message won't autosave."
- :group 'message-buffers
- :type 'directory)
-
(defcustom message-forward-start-separator
(concat (mime-make-tag "message" "rfc822") "\n")
"*Delimiter inserted before forwarded messages."
:type 'boolean)
(defcustom message-included-forward-headers
- "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-Transfer-Encoding:\\|^Content-Type:\\|^Mime-Version:"
+ "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^\\(Mail-\\)?Followup-To:\\|^\\(Mail-\\)?Reply-To:\\|^Mail-Copies-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:\\|^Posted-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-\\|^Message-ID:\\|^References:\\|^Content-\\|^MIME-Version:"
"*Regexp matching headers to be included in forwarded messages."
:group 'message-forwarding
:type 'regexp)
-(defcustom message-ignored-resent-headers "^Return-receipt"
+(defcustom message-ignored-resent-headers "^Return-Receipt"
"*All headers that match this regexp will be deleted when resending a message."
:group 'message-interface
:type 'regexp)
variable `mail-header-separator'.
Legal values include `message-send-mail-with-sendmail' (the default),
-`message-send-mail-with-mh' and `message-send-mail-with-qmail'."
+`message-send-mail-with-mh', `message-send-mail-with-qmail' and
+`message-send-mail-with-smtp'."
:type '(radio (function-item message-send-mail-with-sendmail)
(function-item message-send-mail-with-mh)
(function-item message-send-mail-with-qmail)
(const use)
(const ask)))
+(defcustom message-use-mail-copies-to 'ask
+ "*Specifies what to do with Mail-Copies-To header.
+If nil, always ignore the header. If it is t, use its value, but
+query before using the value other than \"always\" or \"never\".
+If it is the symbol `ask', always query the user whether to use
+the value. If it is the symbol `use', always use the value."
+ :group 'message-interface
+ :type '(choice (const :tag "ignore" nil)
+ (const use)
+ (const ask)))
+
+(defcustom message-use-mail-followup-to 'ask
+ "*Specifies what to do with Mail-Followup-To header.
+If nil, always ignore the header. If it is the symbol `ask', always
+query the user whether to use the value. If it is t or the symbol
+`use', always use the value."
+ :group 'message-interface
+ :type '(choice (const :tag "ignore" nil)
+ (const use)
+ (const ask)))
+
+(defcustom message-use-mail-reply-to t
+ "*Specifies what to do with Mail-Reply-To/Reply-To header.
+If nil, always ignore the header. If it is t, use its value unless
+\"Reply-To\" is marked as \"broken\". If it is the symbol `ask',
+always query the user whether to use the value. If it is the symbol
+`use', always use the value."
+ :group 'message-interface
+ :type '(choice (const :tag "ignore" nil)
+ (const use)
+ (const ask)))
+
;; stuff relating to broken sendmail in MMDF
(defcustom message-sendmail-f-is-evil nil
"*Non-nil means that \"-f username\" should not be added to the sendmail
((boundp 'gnus-select-method)
gnus-select-method)
(t '(nnspool "")))
- "Method used to post news."
+ "*Method used to post news.
+Note that when posting from inside Gnus, for instance, this
+variable isn't used."
:group 'message-news
:group 'message-sending
;; This should be the `gnus-select-method' widget, but that might
:type 'hook)
(defcustom message-header-setup-hook nil
- "Hook called narrowed to the headers when setting up a message
-buffer."
+ "Hook called narrowed to the headers when setting up a message buffer."
:group 'message-various
:type 'hook)
mail-citation-hook)
mail-citation-hook
'message-cite-original)
- "*Function for citing an original message."
+ "*Function for citing an original message.
+Pre-defined functions include `message-cite-original' and
+`message-cite-original-without-signature'."
:type '(radio (function-item message-cite-original)
+ (function-item message-cite-original-without-signature)
(function-item sc-cite-original)
(function :tag "Other"))
:group 'message-insertion)
(defvar message-reply-buffer nil)
(defvar message-reply-headers nil)
-(defvar message-newsreader nil)
-(defvar message-mailer nil)
(defvar message-sent-message-via nil)
(defvar message-checksum nil)
(defvar message-send-actions nil
(define-widget 'message-header-lines 'text
"All header lines must be LFD terminated."
+ :format "%t:%n%v"
:valid-regexp "^\\'"
:error "All header lines must be newline terminated")
;; 33 and 126, except colon)", i. e., any chars except ctl chars,
;; space, or colon.
'(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:"))
- "Set this non-nil if the system's mailer runs the header and body together.
+ "*Set this non-nil if the system's mailer runs the header and body together.
\(This problem exists on Sunos 4 when sendmail is run in remote mode.)
The value should be an expression to test whether the problem will
actually occur."
:group 'message-sending
:type 'sexp)
+;;; XXX: This symbol is overloaded! See below.
+(defvar message-user-agent nil
+ "String of the form of PRODUCT/VERSION. Used for User-Agent header field.")
+
;; Ignore errors in case this is used in Emacs 19.
;; Don't use ignore-errors because this is copied into loaddefs.el.
;;;###autoload
The default is `abbrev', which uses mailabbrev. nil switches
mail aliases off.")
+(defcustom message-autosave-directory
+ (nnheader-concat message-directory "drafts/")
+ "*Directory where Message autosaves buffers if Gnus isn't running.
+If nil, Message won't autosave."
+ :group 'message-buffers
+ :type 'directory)
+
;;; Internal variables.
;;; Well, not really internal.
`((,(concat "^\\([Tt]o:\\)" content)
(1 'message-header-name-face)
(2 'message-header-to-face nil t))
- (,(concat "^\\(^[GBF]?[Cc][Cc]:\\|^[Rr]eply-[Tt]o:\\)" content)
+ (,(concat "^\\([GBF]?[Cc][Cc]:\\|[Rr]eply-[Tt]o:\\|"
+ "[Mm]ail-[Cc]opies-[Tt]o:\\|"
+ "[Mm]ail-[Rr]eply-[Tt]o:\\|"
+ "[Mm]ail-[Ff]ollowup-[Tt]o:\\)" content)
(1 'message-header-name-face)
(2 'message-header-cc-face nil t))
(,(concat "^\\([Ss]ubject:\\)" content)
(,(concat "^\\(X-[A-Za-z0-9-]+\\|In-Reply-To\\):" content)
(1 'message-header-name-face)
(2 'message-header-name-face))
- (,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
- 1 'message-separator-face)
+ ,@(if (and mail-header-separator
+ (not (equal mail-header-separator "")))
+ `((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
+ 1 'message-separator-face))
+ nil)
(,(concat "^[ \t]*"
"\\([" cite-prefix "]+[" cite-suffix "]*\\)?"
- "[>|}].*")
+ "[:>|}].*")
(0 'message-cited-text-face))))
"Additional expressions to highlight in Message mode.")
(Lines)
(Expires)
(Message-ID)
- (References)
- (X-Mailer)
- (X-Newsreader))
+ (References . message-fill-header)
+ (User-Agent))
"Alist used for formatting headers.")
(eval-and-compile
(autoload 'gnus-output-to-rmail "gnus-util")
(autoload 'mail-abbrev-in-expansion-header-p "mailabbrev")
(autoload 'nndraft-request-associate-buffer "nndraft")
- (autoload 'nndraft-request-expire-articles "nndraft"))
+ (autoload 'nndraft-request-expire-articles "nndraft")
+ (autoload 'gnus-open-server "gnus-int")
+ (autoload 'gnus-request-post "gnus-int")
+ (autoload 'gnus-alive-p "gnus-util")
+ (autoload 'rmail-output "rmail"))
\f
(defun message-fetch-field (header &optional not-all)
"The same as `mail-fetch-field', only remove all newlines."
- (let ((value (mail-fetch-field header nil (not not-all))))
+ (let* ((inhibit-point-motion-hooks t)
+ (value (mail-fetch-field header nil (not not-all))))
(when value
(nnheader-replace-chars-in-string value ?\n ? ))))
(defun message-strip-subject-re (subject)
"Remove \"Re:\" from subject lines."
- (if (string-match "^[Rr][Ee]: *" subject)
+ (if (string-match message-subject-re-regexp subject)
(substring subject (match-end 0))
subject))
(defun message-news-p ()
"Say whether the current buffer contains a news message."
- (or message-this-is-news
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (and (message-fetch-field "newsgroups")
- (not (message-fetch-field "posted-to")))))))
+ (and (not message-this-is-mail)
+ (or message-this-is-news
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (and (message-fetch-field "newsgroups")
+ (not (message-fetch-field "posted-to"))))))))
(defun message-mail-p ()
"Say whether the current buffer contains a mail message."
- (or message-this-is-mail
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (or (message-fetch-field "to")
- (message-fetch-field "cc")
- (message-fetch-field "bcc"))))))
+ (and (not message-this-is-news)
+ (or message-this-is-mail
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (or (message-fetch-field "to")
+ (message-fetch-field "cc")
+ (message-fetch-field "bcc")))))))
(defun message-next-header ()
"Go to the beginning of the next header."
(define-key message-mode-map "\C-c\C-f\C-w" 'message-goto-fcc)
(define-key message-mode-map "\C-c\C-f\C-c" 'message-goto-cc)
(define-key message-mode-map "\C-c\C-f\C-s" 'message-goto-subject)
- (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to)
+ ;; (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-reply-to)
+ (define-key message-mode-map "\C-c\C-f\C-r" 'message-goto-mail-reply-to)
+ (define-key message-mode-map "\C-c\C-f\C-m" 'message-goto-mail-followup-to)
(define-key message-mode-map "\C-c\C-f\C-n" 'message-goto-newsgroups)
(define-key message-mode-map "\C-c\C-f\C-d" 'message-goto-distribution)
(define-key message-mode-map "\C-c\C-f\C-f" 'message-goto-followup-to)
["Subject" message-goto-subject t]
["Cc" message-goto-cc t]
["Reply-To" message-goto-reply-to t]
+ ["Mail-Reply-To" message-goto-mail-reply-to t]
+ ["Mail-Followup-To" message-goto-mail-followup-to t]
+ ["Mail-Copies-To" message-goto-mail-copies-to t]
["Summary" message-goto-summary t]
["Keywords" message-goto-keywords t]
["Newsgroups" message-goto-newsgroups t]
C-c C-f C-w move to Fcc C-c C-f C-r move to Reply-To
C-c C-f C-u move to Summary C-c C-f C-n move to Newsgroups
C-c C-f C-k move to Keywords C-c C-f C-d move to Distribution
+ C-c C-f C-m move to Mail-Followup-To
C-c C-f C-f move to Followup-To
C-c C-t message-insert-to (add a To header to a news followup)
C-c C-n message-insert-newsgroups (add a Newsgroup header to a news reply)
C-c C-y message-yank-original (insert current message, if any).
C-c C-q message-fill-yanked-message (fill what was yanked).
C-c C-e message-elide-region (elide the text between point and mark).
+C-c C-z message-kill-to-signature (kill the text up to the signature).
C-c C-r message-caesar-buffer-body (rot13 the message body)."
(interactive)
(kill-all-local-variables)
(concat (regexp-quote mail-header-separator)
"$\\|[ \t]*[-_][-_][-_]+$\\|"
"-- $\\|"
- ;;!!! Uhm... shurely this can't be right.
+ ;;!!! Uhm... shurely this can't be right?
"[> " (regexp-quote message-yank-prefix) "]+$\\|"
paragraph-start))
(setq paragraph-separate
paragraph-separate))
(make-local-variable 'message-reply-headers)
(setq message-reply-headers nil)
- (make-local-variable 'message-newsreader)
- (make-local-variable 'message-mailer)
+ (make-local-variable 'message-user-agent)
(make-local-variable 'message-post-method)
(make-local-variable 'message-sent-message-via)
(setq message-sent-message-via nil)
(mail-abbrevs-setup)
(funcall (intern "mail-aliases-setup"))))
(message-set-auto-save-file-name)
- (run-hooks 'text-mode-hook 'message-mode-hook)
(unless (string-match "XEmacs" emacs-version)
(set (make-local-variable 'font-lock-defaults)
- '(message-font-lock-keywords t))))
+ '(message-font-lock-keywords t)))
+ (make-local-variable 'adaptive-fill-regexp)
+ (setq adaptive-fill-regexp
+ (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|" adaptive-fill-regexp))
+ (unless (boundp 'adaptive-fill-first-line-regexp)
+ (setq adaptive-fill-first-line-regexp nil))
+ (make-local-variable 'adaptive-fill-first-line-regexp)
+ (setq adaptive-fill-first-line-regexp
+ (concat "[ \t]*[-a-z0-9A-Z]*>+[ \t]*\\|"
+ adaptive-fill-first-line-regexp))
+ (run-hooks 'text-mode-hook 'message-mode-hook))
\f
(interactive)
(message-position-on-field "Reply-To" "Subject"))
+(defun message-goto-mail-reply-to ()
+ "Move point to the Mail-Reply-To header."
+ (interactive)
+ (message-position-on-field "Mail-Reply-To" "Subject"))
+
+(defun message-goto-mail-followup-to ()
+ "Move point to the Mail-Followup-To header."
+ (interactive)
+ (message-position-on-field "Mail-Followup-To" "Subject"))
+
+(defun message-goto-mail-copies-to ()
+ "Move point to the Mail-Copies-To header."
+ (interactive)
+ (message-position-on-field "Mail-Copies-To" "Subject"))
+
(defun message-goto-newsgroups ()
"Move point to the Newsgroups header."
(interactive)
(interactive)
(let ((point (point)))
(message-goto-signature)
- (kill-region point (point))))
+ (unless (eobp)
+ (forward-line -2))
+ (kill-region point (point))
+ (unless (bolp)
+ (insert "\n"))))
(defun message-newline-and-reformat ()
"Insert four newlines, and then reformat if inside quoted text."
(or (bolp) (insert "\n")))))
(defun message-elide-region (b e)
- "Elide the text between point and mark. An ellipsis (from
-message-elide-elipsis) will be inserted where the text was killed."
+ "Elide the text between point and mark.
+An ellipsis (from `message-elide-elipsis') will be inserted where the
+text was killed."
(interactive "r")
(kill-region b e)
(unless (bolp)
(name-default (concat "*message* " mail-trimmed-to))
(name (if enter-string
(read-string "New buffer name: " name-default)
- name-default))
- (default-directory
- (if message-autosave-directory
- (file-name-as-directory message-autosave-directory)
- default-directory)))
+ name-default)))
(rename-buffer name t)))))
(defun message-fill-yanked-message (&optional justifyp)
(unless modified
(setq message-checksum (cons (message-checksum) (buffer-size)))))))
+(defun message-cite-original-without-signature ()
+ "Cite function in the standard Message manner."
+ (let ((start (point))
+ (end (mark t))
+ (functions
+ (when message-indent-citation-function
+ (if (listp message-indent-citation-function)
+ message-indent-citation-function
+ (list message-indent-citation-function)))))
+ (goto-char end)
+ (when (re-search-backward "^-- $" start t)
+ (delete-region (point) end))
+ (goto-char start)
+ (while functions
+ (funcall (pop functions)))
+ (when message-citation-line-function
+ (unless (bolp)
+ (insert "\n"))
+ (funcall message-citation-line-function))))
+
(defun message-cite-original ()
"Cite function in the standard Message manner."
(let ((start (point))
(defun message-dont-send ()
"Don't send the message you have been editing."
(interactive)
+ (set-buffer-modified-p t)
+ (save-buffer)
(let ((actions message-postpone-actions))
(message-bury (current-buffer))
(message-do-actions actions)))
the user from the mailer."
(interactive "P")
;; Disabled test.
- (when (if (and buffer-file-name
- nil)
- (y-or-n-p (format "Send buffer contents as %s message? "
- (if (message-mail-p)
- (if (message-news-p) "mail and news" "mail")
- "news")))
- (or (buffer-modified-p)
- (message-check-element 'unchanged)
- (y-or-n-p "No changes in the buffer; really send? ")))
+ (when (or (buffer-modified-p)
+ (message-check-element 'unchanged)
+ (y-or-n-p "No changes in the buffer; really send? "))
;; Make it possible to undo the coming changes.
(undo-boundary)
(let ((inhibit-read-only t))
t))))
(defun message-send-via-mail (arg)
- "Send the current message via mail."
+ "Send the current message via mail."
(message-send-mail arg))
(defun message-send-via-news (arg)
(let* ((case-fold-search t)
(message-id (message-fetch-field "message-id" t)))
(or (not message-id)
+ ;; Is there an @ in the ID?
(and (string-match "@" message-id)
- (string-match "@[^\\.]*\\." message-id))
+ ;; Is there a dot in the ID?
+ (string-match "@[^.]*\\." message-id)
+ ;; Does the ID end with a dot?
+ (not (string-match "\\.>" message-id)))
(y-or-n-p
(format "The Message-ID looks strange: \"%s\". Really post? "
message-id)))))
(while (setq file (message-fetch-field "fcc"))
(push file list)
(message-remove-header "fcc" nil t)))
- (run-hooks 'message-header-hook)
- (run-hooks 'message-before-do-fcc-hook)
+ (run-hooks 'message-header-hook 'message-before-do-fcc-hook)
(goto-char (point-min))
(re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
(replace-match "" t t)
(timezone-make-date-arpa-standard
(current-time-string now) (current-time-zone now))))
+(defun message-make-followup-subject (subject)
+ "Make a followup Subject."
+ (cond
+ ((and (eq message-use-subject-re 'guess)
+ (string-match message-subject-encoded-re-regexp subject))
+ subject)
+ (message-use-subject-re
+ (concat "Re: " (message-strip-subject-re subject)))
+ (t subject)))
+
(defun message-make-message-id ()
"Make a unique Message-ID."
(concat "<" (message-unique-id)
(defun message-make-in-reply-to ()
"Return the In-Reply-To header for this message."
(when message-reply-headers
- (let ((from (mail-header-from message-reply-headers))
+ (let ((mid (mail-header-message-id message-reply-headers))
+ (from (mail-header-from message-reply-headers))
(date (mail-header-date message-reply-headers)))
- (when from
- (let ((stop-pos
- (string-match " *at \\| *@ \\| *(\\| *<" from)))
- (concat (if stop-pos (substring from 0 stop-pos) from)
- "'s message of \""
- (if (or (not date) (string= date ""))
- "(unknown date)" date)
- "\""))))))
+ (when mid
+ (concat mid
+ (when from
+ (let ((stop-pos
+ (string-match " *at \\| *@ \\| *(\\| *<" from)))
+ (concat "\n ("
+ (if stop-pos (substring from 0 stop-pos) from)
+ "'s message of "
+ (if (or (not date) (string= date ""))
+ "(unknown date)" date)
+ ")"))))))))
(defun message-make-distribution ()
"Make a Distribution header."
(or mail-host-address
(message-make-fqdn)))
-(defun message-generate-filled-references (references message-id)
- "Return filled References field from REFERENCES and MESSAGE-ID."
- (std11-fill-msg-id-list-string (concat references message-id)))
-
-(defun message-generate-folded-references (references message-id)
- "Return folded References field from REFERENCES and MESSAGE-ID."
- (if references
- (let (quote)
- (setq references
- (mapconcat (function
- (lambda (char)
- (cond ((eq char ?\\)
- (setq quote t)
- "\\")
- ((memq char '(?\ ?\t))
- (prog1
- (if quote
- (char-to-string char)
- (concat "\n" (char-to-string char)))
- (setq quote nil)))
- (t
- (setq quote nil)
- (char-to-string char)
- ))))
- references ""))
- (if message-id
- (concat references "\n " message-id)
- references))
- message-id))
-
-(defun message-generate-unfolded-references (references message-id)
- "Return folded References field from REFERENCES and MESSAGE-ID."
- (if references
- (if message-id
- (concat references " " message-id)
- references)
- message-id))
-
(defun message-generate-headers (headers)
"Prepare article HEADERS.
Headers already prepared in the buffer are not modified."
(To nil)
(Distribution (message-make-distribution))
(Lines (message-make-lines))
- (X-Newsreader message-newsreader)
- (X-Mailer (and (not (message-fetch-field "X-Newsreader"))
- message-mailer))
+ (User-Agent message-user-agent)
(Expires (message-make-expires))
(case-fold-search t)
header value elem)
(insert "Original-")
(beginning-of-line))
(when (or (message-news-p)
- (string-match "^[^@]@.+\\..+" secure-sender))
+ (string-match "@.+\\.." secure-sender))
(insert "Sender: " secure-sender "\n")))))))
(defun message-insert-courtesy-copy ()
(if (or (= (following-char) ?,)
(eobp))
(when (not quoted)
- (if (and (> (current-column) 78)
- last)
- (progn
- (save-excursion
- (goto-char last)
- (insert "\n\t"))
- (setq last (1+ (point))))
- (setq last (1+ (point)))))
+ (if last
+ (save-excursion
+ (goto-char last)
+ (looking-at "[ \t]*")
+ (replace-match "\n " t t)))
+ (setq last (1+ (point))))
(setq quoted (not quoted)))
(unless (eobp)
(forward-char 1))))
(defun message-fill-header (header value)
(let ((begin (point))
(fill-column 78)
- (fill-prefix "\t"))
+ (fill-prefix " "))
(insert (capitalize (symbol-name header))
": "
(if (consp value) (car value) value)
(defun message-set-auto-save-file-name ()
"Associate the message buffer with a file in the drafts directory."
(when message-autosave-directory
- (setq message-draft-article (nndraft-request-associate-buffer "drafts"))
+ (if (gnus-alive-p)
+ (setq message-draft-article
+ (nndraft-request-associate-buffer "drafts"))
+ (setq buffer-file-name (expand-file-name "*message*"
+ message-autosave-directory))
+ (setq buffer-auto-save-file-name (make-auto-save-file-name)))
(clear-visited-file-modtime)))
(defun message-disassociate-draft ()
"Start editing a reply to the article in the current buffer."
(interactive)
(let ((cur (current-buffer))
- from subject date reply-to to cc
- references message-id follow-to
(inhibit-point-motion-hooks t)
- mct never-mct gnus-warning)
+ from date subject mct mft mrt
+ never-mct to cc
+ references message-id follow-to gnus-warning)
(save-restriction
(message-narrow-to-head)
;; Allow customizations to have their say.
(funcall message-wide-reply-to-function)))))
;; Find all relevant headers we need.
(setq from (message-fetch-field "from")
- date (message-fetch-field "date")
+ date (message-fetch-field "date" t)
subject (or (message-fetch-field "subject") "none")
+ references (message-fetch-field "references")
+ message-id (message-fetch-field "message-id" t)
to (message-fetch-field "to")
cc (message-fetch-field "cc")
- mct (message-fetch-field "mail-copies-to")
- reply-to (unless ignore-reply-to (message-fetch-field "reply-to"))
- references (message-fetch-field "references")
- message-id (message-fetch-field "message-id" t))
+ mct (when (and wide message-use-mail-copies-to)
+ (message-fetch-field "mail-copies-to"))
+ mft (when (and wide message-use-mail-followup-to)
+ (message-fetch-field "mail-followup-to"))
+ mrt (when message-use-mail-reply-to
+ (or (message-fetch-field "mail-reply-to")
+ (and (or (eq message-use-mail-reply-to 'use)
+ (not ignore-reply-to))
+ (message-fetch-field "reply-to"))))
+ gnus-warning (message-fetch-field "gnus-warning"))
+ (when (and gnus-warning (string-match "<[^>]+>" gnus-warning))
+ (setq message-id (match-string 0 gnus-warning)))
;; Remove any (buggy) Re:'s that are present and make a
;; proper one.
- (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject)
- (setq subject (substring subject (match-end 0))))
- (setq subject (concat "Re: " subject))
-
- (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
- (string-match "<[^>]+>" gnus-warning))
- (setq message-id (match-string 0 gnus-warning)))
-
- ;; Handle special values of Mail-Copies-To.
- (when mct
- (cond ((equal (downcase mct) "never")
- (setq never-mct t)
- (setq mct nil))
- ((equal (downcase mct) "always")
- (setq mct (or reply-to from)))))
-
- (unless follow-to
- (if (or (not wide)
- to-address)
- (progn
- (setq follow-to (list (cons 'To (or to-address reply-to from))))
- (when (and wide mct)
- (push (cons 'Cc mct) follow-to)))
- (let (ccalist)
- (save-excursion
- (message-set-work-buffer)
- (unless never-mct
- (insert (or reply-to from "")))
- (insert (if to (concat (if (bolp) "" ", ") to "") ""))
- (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
- (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
- (goto-char (point-min))
- (while (re-search-forward "[ \t]+" nil t)
- (replace-match " " t t))
- ;; Remove addresses that match `rmail-dont-reply-to-names'.
- (insert (prog1 (rmail-dont-reply-to (buffer-string))
- (erase-buffer)))
- (goto-char (point-min))
- ;; Perhaps Mail-Copies-To: never removed the only address?
- (when (eobp)
- (insert (or reply-to from "")))
- (setq ccalist
- (mapcar
- (lambda (addr)
- (cons (mail-strip-quoted-names addr) addr))
- (message-tokenize-header (buffer-string))))
- (let ((s ccalist))
- (while s
- (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
- (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
- (when ccalist
- (let ((ccs (cons 'Cc (mapconcat
- (lambda (addr) (cdr addr)) ccalist ", "))))
- (when (string-match "^ +" (cdr ccs))
- (setcdr ccs (substring (cdr ccs) (match-end 0))))
- (push ccs follow-to))))))
+ (setq subject (message-make-followup-subject subject))
(widen))
+ ;; Handle special values of Mail-Copies-To.
+ (when mct
+ (cond
+ ((and (equal (downcase mct) "never")
+ (or (not (eq message-use-mail-copies-to 'ask))
+ (message-y-or-n-p
+ (concat "Obey Mail-Copies-To: never? ") t "\
+You should normally obey the Mail-Copies-To: header.
+
+ `Mail-Copies-To: never'
+directs you not to send your response to the author.")))
+ (setq never-mct t)
+ (setq mct nil))
+ ((and (equal (downcase mct) "always")
+ (or (not (eq message-use-mail-copies-to 'ask))
+ (message-y-or-n-p
+ (concat "Obey Mail-Copies-To: always? ") t "\
+You should normally obey the Mail-Copies-To: header.
+
+ `Mail-Copies-To: always'
+sends a copy of your response to the author.")))
+ (setq mct (or mrt from)))
+ ((and (eq message-use-mail-copies-to 'ask)
+ (not
+ (message-y-or-n-p
+ (concat "Obey Mail-Copies-To: " mct " ? ") t "\
+You should normally obey the Mail-Copies-To: header.
+
+ `Mail-Copies-To: " mct "'
+sends a copy of your response to " (if (string-match "," mct)
+ "the specified addresses"
+ "that address") ".")))
+ (setq mct nil))
+ ))
+
+ (unless follow-to
+ (cond
+ (to-address (setq follow-to (list (cons 'To to-address))))
+ ((not wide) (setq follow-to (list (cons 'To (or mrt from)))))
+ ;; Handle Mail-Followup-To.
+ ((and mft
+ (or (not (eq message-use-mail-followup-to 'ask))
+ (message-y-or-n-p
+ (concat "Obey Mail-Followup-To: " mft "? ") t "\
+You should normally obey the Mail-Followup-To: header.
+
+ `Mail-Followup-To: " mft "'
+directs your response to " (if (string-match "," mft)
+ "the specified addresses"
+ "that address only") ".
+
+A typical situation where Mail-Followup-To is used is when the author thinks
+that further discussion should take place only in "
+ (if (string-match "," mft)
+ "the specified mailing lists"
+ "that mailing list") ".")))
+ (setq follow-to (list (cons 'To mft)))
+ (when mct
+ (push (cons 'Cc mct) follow-to)))
+ (t
+ (let (ccalist)
+ (save-excursion
+ (message-set-work-buffer)
+ (unless never-mct
+ (insert (or mrt from "")))
+ (insert (if to (concat (if (bolp) "" ", ") to "") ""))
+ (insert (if mct (concat (if (bolp) "" ", ") mct) ""))
+ (insert (if cc (concat (if (bolp) "" ", ") cc) ""))
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t]+" nil t)
+ (replace-match " " t t))
+ ;; Remove addresses that match `rmail-dont-reply-to-names'.
+ (insert (prog1 (rmail-dont-reply-to (buffer-string))
+ (erase-buffer)))
+ (goto-char (point-min))
+ ;; Perhaps Mail-Copies-To: never removed the only address?
+ (when (eobp)
+ (insert (or mrt from "")))
+ (setq ccalist
+ (mapcar
+ (lambda (addr)
+ (cons (mail-strip-quoted-names addr) addr))
+ (message-tokenize-header (buffer-string))))
+ (let ((s ccalist))
+ (while s
+ (setq ccalist (delq (assoc (car (pop s)) s) ccalist)))))
+ (setq follow-to (list (cons 'To (cdr (pop ccalist)))))
+ (when ccalist
+ (let ((ccs (cons 'Cc (mapconcat
+ (lambda (addr) (cdr addr)) ccalist ", "))))
+ (when (string-match "^ +" (cdr ccs))
+ (setcdr ccs (substring (cdr ccs) (match-end 0))))
+ (push ccs follow-to)))))))
+
(message-pop-to-buffer (message-buffer-name
(if wide "wide reply" "reply") from
(if wide to-address nil)))
`((Subject . ,subject)
,@follow-to
,@(if (or references message-id)
- `((References . ,(funcall message-references-generator
- references message-id))))
- )
+ `((References . ,(concat (or references "") (and references " ")
+ (or message-id ""))))))
cur)))
;;;###autoload
;;;###autoload
(defun message-followup (&optional to-newsgroups)
- "Follow up to the message in the current buffer.
-If TO-NEWSGROUPS, use that as the new Newsgroups line."
+ "Follow up to the message in the current buffer."
(interactive)
(let ((cur (current-buffer))
- from subject date reply-to mct
- references message-id follow-to
(inhibit-point-motion-hooks t)
+ from date subject mct mft mrt
(message-this-is-news t)
- followup-to distribution newsgroups gnus-warning posted-to)
+ followup-to distribution newsgroups posted-to
+ references message-id follow-to gnus-warning)
(save-restriction
- (narrow-to-region
- (goto-char (point-min))
- (if (search-forward "\n\n" nil t)
- (1- (point))
- (point-max)))
+ (message-narrow-to-head)
+ ;; Allow customizations to have their say.
+ ;; This is a followup.
(when (message-functionp message-followup-to-function)
(setq follow-to
(funcall message-followup-to-function)))
+ ;; Find all relevant headers we need.
(setq from (message-fetch-field "from")
- date (message-fetch-field "date")
+ date (message-fetch-field "date" t)
subject (or (message-fetch-field "subject") "none")
references (message-fetch-field "references")
message-id (message-fetch-field "message-id" t)
- followup-to (message-fetch-field "followup-to")
+ followup-to (when message-use-followup-to
+ (message-fetch-field "followup-to"))
+ distribution (message-fetch-field "distribution")
newsgroups (message-fetch-field "newsgroups")
posted-to (message-fetch-field "posted-to")
- reply-to (message-fetch-field "reply-to")
- distribution (message-fetch-field "distribution")
- mct (message-fetch-field "mail-copies-to"))
- (when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
- (string-match "<[^>]+>" gnus-warning))
+ mct (when message-use-mail-copies-to
+ (message-fetch-field "mail-copies-to"))
+ mft (when message-use-mail-followup-to
+ (message-fetch-field "mail-followup-to"))
+ mrt (when message-use-mail-reply-to
+ (or (message-fetch-field "mail-reply-to")
+ (message-fetch-field "reply-to")))
+ gnus-warning (message-fetch-field "gnus-warning"))
+ (when (and gnus-warning (string-match "<[^>]+>" gnus-warning))
(setq message-id (match-string 0 gnus-warning)))
;; Remove bogus distribution.
(when (and (stringp distribution)
(setq distribution nil))
;; Remove any (buggy) Re:'s that are present and make a
;; proper one.
- (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject)
- (setq subject (substring subject (match-end 0))))
- (setq subject (concat "Re: " subject))
+ (setq subject (message-make-followup-subject subject))
(widen))
- (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
-
- (message-setup
- `((Subject . ,subject)
- ,@(cond
- (to-newsgroups
- (list (cons 'Newsgroups to-newsgroups)))
- (follow-to follow-to)
- ((and followup-to message-use-followup-to)
- (list
- (cond
- ((equal (downcase followup-to) "poster")
- (if (or (eq message-use-followup-to 'use)
- (message-y-or-n-p "Obey Followup-To: poster? " t "\
+ ;; Handle special values of Mail-Copies-To.
+ (when mct
+ (cond
+ ((and (equal (downcase mct) "never")
+ (or (not (eq message-use-mail-copies-to 'ask))
+ (message-y-or-n-p
+ (concat "Obey Mail-Copies-To: never? ") t "\
+You should normally obey the Mail-Copies-To: header.
+
+ `Mail-Copies-To: never'
+directs you not to send your response to the author.")))
+ (setq mct nil))
+ ((and (equal (downcase mct) "always")
+ (or (not (eq message-use-mail-copies-to 'ask))
+ (message-y-or-n-p
+ (concat "Obey Mail-Copies-To: always? ") t "\
+You should normally obey the Mail-Copies-To: header.
+
+ `Mail-Copies-To: always'
+sends a copy of your response to the author.")))
+ (setq mct (or mrt from)))
+ ((and (eq message-use-mail-copies-to 'ask)
+ (not
+ (message-y-or-n-p
+ (concat "Obey Mail-Copies-To: " mct " ? ") t "\
+You should normally obey the Mail-Copies-To: header.
+
+ `Mail-Copies-To: " mct "'
+sends a copy of your response to " (if (string-match "," mct)
+ "the specified addresses"
+ "that address") ".")))
+ (setq mct nil))
+ ))
+
+ (unless follow-to
+ (cond
+ (to-newsgroups (setq follow-to (list (cons 'Newsgroups to-newsgroups))))
+ ;; Handle Followup-To.
+ (followup-to
+ (cond
+ ((equal (downcase followup-to) "poster")
+ (if (or (eq message-use-followup-to 'use)
+ (message-y-or-n-p "Obey Followup-To: poster? " t "\
You should normally obey the Followup-To: header.
-`Followup-To: poster' sends your response via e-mail instead of news.
+ `Followup-To: poster'
+sends your response via e-mail instead of news.
-A typical situation where `Followup-To: poster' is used is when the poster
+A typical situation where `Followup-To: poster' is used is when the author
does not read the newsgroup, so he wouldn't see any replies sent to it."))
- (progn
- (setq message-this-is-news nil)
- (cons 'To (or reply-to from "")))
- (cons 'Newsgroups newsgroups)))
- (t
- (if (or (equal followup-to newsgroups)
- (not (eq message-use-followup-to 'ask))
- (message-y-or-n-p
- (concat "Obey Followup-To: " followup-to "? ") t "\
+ (setq message-this-is-news nil
+ distribution nil
+ follow-to (list (cons 'To (or mrt from ""))))
+ (setq follow-to (list (cons 'Newsgroups newsgroups)))))
+ (t
+ (if (or (equal followup-to newsgroups)
+ (not (eq message-use-followup-to 'ask))
+ (message-y-or-n-p
+ (concat "Obey Followup-To: " followup-to "? ") t "\
You should normally obey the Followup-To: header.
`Followup-To: " followup-to "'
Also, some source/announcement newsgroups are not indented for discussion;
responses here are directed to other newsgroups."))
- (cons 'Newsgroups followup-to)
- (cons 'Newsgroups newsgroups))))))
- (posted-to
- `((Newsgroups . ,posted-to)))
- (t
- `((Newsgroups . ,newsgroups))))
- ,@(and distribution (list (cons 'Distribution distribution)))
- ,@(if (or references message-id)
- `((References . ,(funcall message-references-generator
- references message-id))))
- ,@(when (and mct
- (not (equal (downcase mct) "never")))
- (list (cons 'Cc (if (equal (downcase mct) "always")
- (or reply-to from "")
- mct)))))
+ (setq follow-to (list (cons 'Newsgroups followup-to)))
+ (setq follow-to (list (cons 'Newsgroups newsgroups)))))))
+ ;; Handle Mail-Followup-To, followup via e-mail.
+ ((and mft
+ (or (not (eq message-use-mail-followup-to 'ask))
+ (message-y-or-n-p
+ (concat "Obey Mail-Followup-To: " mft "? ") t "\
+You should normally obey the Mail-Followup-To: header.
+
+ `Mail-Followup-To: " mft "'
+directs your response to " (if (string-match "," mft)
+ "the specified addresses"
+ "that address only") " instead of news.
+
+A typical situation where Mail-Followup-To is used is when the author thinks
+that further discussion should take place only in "
+ (if (string-match "," mft)
+ "the specified mailing lists"
+ "that mailing list") ".")))
+ (setq message-this-is-news nil
+ distribution nil
+ follow-to (list (cons 'To mft))))
+ (posted-to (setq follow-to (list (cons 'Newsgroups posted-to))))
+ (t
+ (setq follow-to (list (cons 'Newsgroups newsgroups))))))
- cur)
+ (message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
(setq message-reply-headers
- (vector 0 subject from date message-id references 0 0 ""))))
+ (vector 0 subject from date message-id references 0 0 ""))
+ (message-setup
+ `((Subject . ,subject)
+ ,@follow-to
+ ,@(and mct (list (cons 'Cc mct)))
+ ,@(and distribution (list (cons 'Distribution distribution)))
+ ,@(if (or references message-id)
+ `((References . ,(concat (or references "") (and references " ")
+ (or message-id ""))))))
+ cur)))
;;;###autoload
(defun message-cancel-news ()
(unless (message-news-p)
(error "This is not a news article; canceling is impossible"))
(when (yes-or-no-p "Do you really want to cancel this article? ")
- (let (from newsgroups message-id distribution buf)
+ (let (from newsgroups message-id distribution buf sender)
(save-excursion
;; Get header info. from original article.
(save-restriction
(message-narrow-to-head)
(setq from (message-fetch-field "from")
+ sender (message-fetch-field "sender")
newsgroups (message-fetch-field "newsgroups")
message-id (message-fetch-field "message-id" t)
distribution (message-fetch-field "distribution")))
;; Make sure that this article was written by the user.
- (unless (string-equal
- (downcase (cadr (std11-extract-address-components from)))
- (downcase (message-make-address)))
+ (unless (or (and sender
+ (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"))
;; Make control message.
(setq buf (set-buffer (get-buffer-create " *message cancel*")))
(let ((cur (current-buffer)))
;; Check whether the user owns the article that is to be superseded.
(unless (string-equal
- (downcase (cadr (mail-extract-address-components
- (message-fetch-field "from"))))
- (downcase (message-make-address)))
+ (downcase (or (message-fetch-field "sender")
+ (cadr (mail-extract-address-components
+ (message-fetch-field "from")))))
+ (downcase (message-make-sender)))
(error "This article is not yours"))
;; Get a normal message buffer.
(message-pop-to-buffer (message-buffer-name "supersede"))
(concat "[" (or (message-fetch-field
(if (message-news-p) "newsgroups" "from"))
"(nowhere)")
- "] " (or (message-fetch-field "Subject") "")))))
+ "] " (or (eword-decode-unstructured-field-body
+ (message-fetch-field "Subject") ""))))))
;;;###autoload
(defun message-forward (&optional news)
(goto-char (point-max)))
(insert mail-header-separator)
;; Rename all old ("Also-")Resent headers.
- (while (re-search-backward "^\\(Also-\\)?Resent-" beg t)
+ (while (re-search-backward "^\\(Also-\\)*Resent-" beg t)
(beginning-of-line)
(insert "Also-"))
;; Quote any "From " lines at the beginning.
(insert-buffer-substring cur)
(undo-boundary)
(message-narrow-to-head)
- (if (and (message-fetch-field "Mime-Version")
+ (if (and (message-fetch-field "MIME-Version")
(setq boundary (message-fetch-field "Content-Type")))
(if (string-match "boundary=\"\\([^\"]+\\)\"" boundary)
(setq boundary (concat (match-string 1 boundary) " *\n"
(defvar gnus-active-hashtb)
(defun message-expand-group ()
+ "Expand the group name under point."
(let* ((b (save-excursion
(save-restriction
(narrow-to-region
(point))
(skip-chars-backward "^, \t\n") (point))))
(completion-ignore-case t)
- (string (buffer-substring b (point)))
+ (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ")
+ (point))))
(hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))
(completions (all-completions string hashtb))
(cur (current-buffer))