;;; message.el --- composing mail and news messages
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006 Free Software Foundation, Inc.
+;; 2005, 2006, 2007 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: mail, news
:link '(custom-manual "(message)Message Headers")
:type '(repeat sexp))
-(defcustom message-draft-headers '(References From)
+(defcustom message-draft-headers '(References From Date)
"*Headers to be generated when saving a draft message."
:version "22.1"
:group 'message-news
"*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
-User-Agent are optional. If don't you want message to insert some
+User-Agent are optional. If you don't want message to insert some
header, remove it from this list."
:group 'message-news
:group 'message-headers
:type 'boolean)
(defcustom message-generate-new-buffers 'unique
- "*Non-nil means create a new message buffer whenever `message-setup' is called.
-If this is a function, call that function with three parameters: The type,
-the to address and the group name. (Any of these may be nil.) The function
-should return the new buffer name."
+ "*Say whether to create a new message buffer to compose a message.
+Valid values include:
+
+nil
+ Generate the buffer name in the Message way (e.g., *mail*, *news*,
+ *mail to whom*, *news on group*, etc.) and continue editing in the
+ existing buffer of that name. If there is no such buffer, it will
+ be newly created.
+
+`unique' or t
+ Create the new buffer with the name generated in the Message way.
+
+`unsent'
+ Similar to `unique' but the buffer name begins with \"*unsent \".
+
+`standard'
+ Similar to nil but the buffer name is simpler like *mail message*.
+
+function
+ If this is a function, call that function with three parameters:
+ The type, the To address and the group name (any of these may be nil).
+ The function should return the new buffer name."
:group 'message-buffers
:link '(custom-manual "(message)Message Buffers")
- :type '(choice (const :tag "off" nil)
- (const :tag "unique" unique)
- (const :tag "unsent" unsent)
- (function fun)))
+ :type '(choice (const nil)
+ (sexp :tag "unique" :format "unique\n" :value unique
+ :match (lambda (widget value) (memq value '(unique t))))
+ (const unsent)
+ (const standard)
+ (function :format "\n %{%t%}: %v")))
(defcustom message-kill-buffer-on-exit nil
"*Non-nil means that the message buffer will be killed after sending a message."
:version "22.1"
:group 'message-insertion
:link '(custom-manual "(message)Insertion Variables")
- :type 'regexp)
+ :type 'regexp
+ :set (lambda (symbol value)
+ (prog1
+ (custom-set-default symbol value)
+ (if (boundp 'gnus-message-cite-prefix-regexp)
+ (setq gnus-message-cite-prefix-regexp
+ (concat "^\\(?:" value "\\)"))))))
(defcustom message-cancel-message "I am canceling my own article.\n"
"Message to be inserted in the cancel message."
:link '(custom-manual "(message)Mail Variables")
:group 'message-sending)
+(defcustom message-sendmail-extra-arguments nil
+ "Additional arguments to `sendmail-program'."
+ ;; E.g. '("-a" "account") for msmtp
+ :version "23.0" ;; No Gnus
+ :type '(repeat string)
+ ;; :link '(custom-manual "(message)Mail Variables")
+ :group 'message-sending)
+
;; qmail-related stuff
(defcustom message-qmail-inject-program "/var/qmail/bin/qmail-inject"
"Location of the qmail-inject program."
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
-(defcustom message-citation-line-format "On %a, %b %d %Y, %n wrote:"
+(defcustom message-citation-line-format "On %a, %b %d %Y, %N wrote:"
"Format of the \"Whomever writes:\" line.
The string is formatted using `format-spec'. The following
(defcustom message-generate-hashcash (if (executable-find "hashcash") t)
"*Whether to generate X-Hashcash: headers.
+If `t', always generate hashcash headers. If `opportunistic',
+only generate hashcash headers if it can be done without the user
+waiting (i.e., only asynchronously).
+
You must have the \"hashcash\" binary installed, see `hashcash-path'."
:group 'message-headers
:link '(custom-manual "(message)Mail Headers")
- :type 'boolean)
+ :type '(choice (const :tag "Always" t)
+ (const :tag "Never" nil)
+ (const :tag "Opportunistic" opportunistic)))
;;; Internal variables.
(defvar message-send-mail-real-function nil
"Internal send mail function.")
-(defvar message-bogus-system-names "^localhost\\."
+(defvar message-bogus-system-names "^localhost\\.\\|\\.local$"
"The regexp of bogus system names.")
(defcustom message-valid-fqdn-regexp
(autoload 'gnus-output-to-mail "gnus-util")
(autoload 'gnus-output-to-rmail "gnus-util")
(autoload 'gnus-request-post "gnus-int")
+ (autoload 'gnus-select-frame-set-input-focus "gnus-util")
(autoload 'gnus-server-string "gnus")
(autoload 'idna-to-ascii "idna")
(autoload 'message-setup-toolbar "messagexmas")
(substring subject (match-end 0))
subject))
+(defcustom message-replacement-char "."
+ "Replacement character used instead of unprintable or not decodable chars."
+ :group 'message-various
+ :version "22.1" ;; Gnus 5.10.9
+ :type '(choice string
+ (const ".")
+ (const "?")))
+
+;; FIXME: We also should call `message-strip-subject-encoded-words'
+;; when forwarding. Probably in `message-make-forward-subject' and
+;; `message-forward-make-body'.
+
+(defun message-strip-subject-encoded-words (subject)
+ "Fix non-decodable words in SUBJECT."
+ ;; Cf. `gnus-simplify-subject-fully'.
+ (let* ((case-fold-search t)
+ (replacement-chars (format "[%s%s%s]"
+ message-replacement-char
+ message-replacement-char
+ message-replacement-char))
+ (enc-word-re "=\\?\\([^?]+\\)\\?\\([QB]\\)\\?\\([^?]+\\)\\(\\?=\\)")
+ cs-string
+ (have-marker
+ (with-temp-buffer
+ (insert subject)
+ (goto-char (point-min))
+ (when (re-search-forward enc-word-re nil t)
+ (setq cs-string (match-string 1)))))
+ cs-coding q-or-b word-beg word-end)
+ (if (or (not have-marker) ;; No encoded word found...
+ ;; ... or double encoding was correct:
+ (and (stringp cs-string)
+ (setq cs-string (downcase cs-string))
+ (mm-coding-system-p (intern cs-string))
+ (not (prog1
+ (y-or-n-p
+ (format "\
+Decoded Subject \"%s\"
+contains a valid encoded word. Decode again? "
+ subject))
+ (setq cs-coding (intern cs-string))))))
+ subject
+ (with-temp-buffer
+ (insert subject)
+ (goto-char (point-min))
+ (while (re-search-forward enc-word-re nil t)
+ (setq cs-string (downcase (match-string 1))
+ q-or-b (match-string 2)
+ word-beg (match-beginning 0)
+ word-end (match-end 0))
+ (setq cs-coding
+ (if (mm-coding-system-p (intern cs-string))
+ (setq cs-coding (intern cs-string))
+ nil))
+ ;; No double encoded subject? => bogus charset.
+ (unless cs-coding
+ (setq cs-coding
+ (mm-read-coding-system
+ (format "\
+Decoded Subject \"%s\"
+contains an encoded word. The charset `%s' is unknown or invalid.
+Hit RET to replace non-decodable characters with \"%s\" or enter replacement
+charset: "
+ subject cs-string message-replacement-char)))
+ (if cs-coding
+ (replace-match (concat "=?" (symbol-name cs-coding)
+ "?\\2?\\3\\4\\5"))
+ (save-excursion
+ (goto-char word-beg)
+ (re-search-forward "=\\?\\([^?]+\\)\\?\\([QB]\\)\\?" word-end t)
+ (replace-match "")
+ ;; QP or base64
+ (if (string-match "\\`Q\\'" q-or-b)
+ ;; QP
+ (progn
+ (message "Replacing non-decodable characters with \"%s\"."
+ message-replacement-char)
+ (while (re-search-forward "\\(=[A-F0-9][A-F0-9]\\)+"
+ word-end t)
+ (replace-match message-replacement-char)))
+ ;; base64
+ (message "Replacing non-decodable characters with \"%s\"."
+ replacement-chars)
+ (re-search-forward "[^?]+" word-end t)
+ (replace-match replacement-chars))
+ (re-search-forward "\\?=")
+ (replace-match "")))))
+ (rfc2047-decode-region (point-min) (point-max))
+ (buffer-string)))))
+
;;; Start of functions adopted from `message-utils.el'.
(defun message-strip-subject-trailing-was (subject)
date
;; We need Gnus functionality if the user wants date or time from
;; the original article:
- (when (string-match "%[^EFLn]" message-citation-line-format)
+ (when (string-match "%[^fnNFL]" message-citation-line-format)
(autoload 'gnus-date-get-time "gnus-util")
(gnus-date-get-time (mail-header-date message-reply-headers)))))
(flist
(setq fname name
lname ""))))
;; The following letters are not used in `format-time-string':
- (push ?E lst) (push net lst)
+ (push ?E lst) (push "<E>" lst)
(push ?F lst) (push fname lst)
;; We might want to use "" instead of "<X>" later.
(push ?J lst) (push "<J>" lst)
(push ?K lst) (push "<K>" lst)
(push ?L lst) (push lname lst)
- (push ?N lst) (push "<N>" lst)
+ (push ?N lst) (push name-or-net lst)
(push ?O lst) (push "<O>" lst)
(push ?P lst) (push "<P>" lst)
(push ?Q lst) (push "<Q>" lst)
(push ?f lst) (push from lst)
(push ?i lst) (push "<i>" lst)
- (push ?n lst) (push name-or-net lst)
+ (push ?n lst) (push net lst)
(push ?o lst) (push "<o>" lst)
(push ?q lst) (push "<q>" lst)
(push ?t lst) (push "<t>" lst)
(setq start next)))
(nreverse regions)))
-(defcustom message-replacement-char "."
- "Replacement character used instead of unprintable or not decodable chars."
- :group 'message-various
- :version "23.0" ;; No Gnus
- :type '(choice string
- (const ".")
- (const "?")))
-
(defun message-fix-before-sending ()
"Do various things to make the message nice before sending it."
;; Make sure there's a newline at the end of the message.
(gnus-setup-posting-charset nil)
message-posting-charset))
(headers message-required-mail-headers))
- (when message-generate-hashcash
+ (when (and message-generate-hashcash
+ (not (eq message-generate-hashcash 'opportunistic)))
(message "Generating hashcash...")
;; Wait for calculations already started to finish...
(hashcash-wait-async)
"/usr/ucblib/sendmail")
(t "fakemail"))
nil errbuf nil "-oi")
+ message-sendmail-extra-arguments
;; Always specify who from,
;; since some systems have broken sendmails.
;; But some systems are more broken with -f, so
(msg-id (mail-header-message-id message-reply-headers)))
(when from
(let ((name (mail-extract-address-components from)))
- (concat msg-id (if msg-id " (")
- (or (car name)
- (nth 1 name))
- "'s message of \""
- (if (or (not date) (string= date ""))
- "(unknown date)" date)
- "\"" (if msg-id ")")))))))
+ (concat
+ msg-id (if msg-id " (")
+ (if (car name)
+ (if (string-match "[^\000-\177]" (car name))
+ ;; Quote a string containing non-ASCII characters.
+ ;; It will make the RFC2047 encoder cause an error
+ ;; if there are special characters.
+ (let ((default-enable-multibyte-characters t))
+ (with-temp-buffer
+ (insert (car name))
+ (goto-char (point-min))
+ (while (search-forward "\"" nil t)
+ (when (prog2
+ (backward-char)
+ (zerop (% (skip-chars-backward "\\\\") 2))
+ (goto-char (match-beginning 0)))
+ (insert "\\"))
+ (forward-char))
+ ;; Those quotes will be removed by the RFC2047 encoder.
+ (concat "\"" (buffer-string) "\"")))
+ (car name))
+ (nth 1 name))
+ "'s message of \""
+ (if (or (not date) (string= date ""))
+ "(unknown date)" date)
+ "\"" (if msg-id ")")))))))
(defun message-make-distribution ()
"Make a Distribution header."
(concat message-user-path "!" login-name))
(t login-name))))
-(defun message-make-from ()
+(defun message-make-from (&optional name address )
"Make a From header."
(let* ((style message-from-style)
- (login (message-make-address))
- (fullname
- (or (and (boundp 'user-full-name)
- user-full-name)
- (user-full-name))))
+ (login (or address (message-make-address)))
+ (fullname (or name
+ (and (boundp 'user-full-name)
+ user-full-name)
+ (user-full-name))))
(when (string= fullname "&")
(setq fullname (user-login-name)))
(with-temp-buffer
(stringp message-user-fqdn)
(string-match message-valid-fqdn-regexp message-user-fqdn)
(not (string-match message-bogus-system-names message-user-fqdn)))
+ ;; `message-user-fqdn' seems to be valid
message-user-fqdn)
- ;; `message-user-fqdn' seems to be valid
((and (string-match message-valid-fqdn-regexp system-name)
(not (string-match message-bogus-system-names system-name)))
;; `system-name' returned the right result.
"Return a new (unique) buffer name based on TYPE and TO."
(cond
;; Generate a new buffer name The Message Way.
- ((eq message-generate-new-buffers 'unique)
+ ((memq message-generate-new-buffers '(unique t))
(generate-new-buffer-name
(concat "*" type
(if to
"")
(if (and group (not (string= group ""))) (concat " on " group) "")
"*")))
- ;; Use standard name.
+ ;; Search for the existing message buffer with the specified name.
(t
- (format "*%s message*" type))))
+ (let* ((new (if (eq message-generate-new-buffers 'standard)
+ (generate-new-buffer-name (concat "*" type " message*"))
+ (let ((message-generate-new-buffers 'unique))
+ (message-buffer-name type to group))))
+ (regexp (concat "\\`"
+ (regexp-quote
+ (if (string-match "<[0-9]+>\\'" new)
+ (substring new 0 (match-beginning 0))
+ new))
+ "\\(?:<\\([0-9]+\\)>\\)?\\'"))
+ (case-fold-search nil))
+ (or (cdar
+ (last
+ (sort
+ (delq nil
+ (mapcar
+ (lambda (b)
+ (when (and (string-match regexp (setq b (buffer-name b)))
+ (eq (with-current-buffer b major-mode)
+ 'message-mode))
+ (cons (string-to-number (or (match-string 1 b) "1"))
+ b)))
+ (buffer-list)))
+ 'car-less-than-car)))
+ new)))))
(defun message-pop-to-buffer (name)
"Pop to buffer NAME, and warn if it already exists and is modified."
(let ((buffer (get-buffer name)))
(if (and buffer
(buffer-name buffer))
- (progn
- (set-buffer (pop-to-buffer buffer))
+ (let ((window (get-buffer-window buffer 0)))
+ (if window
+ ;; Raise the frame already displaying the message buffer.
+ (progn
+ (gnus-select-frame-set-input-focus (window-frame window))
+ (select-window window))
+ (set-buffer (pop-to-buffer buffer)))
(when (and (buffer-modified-p)
- (not (y-or-n-p
- "Message already being composed; erase? ")))
+ (not (prog1
+ (y-or-n-p
+ "Message already being composed; erase? ")
+ (message nil))))
(error "Message being composed")))
(set-buffer (pop-to-buffer name)))
(erase-buffer)
nil
mua)))
-(defun message-setup (headers &optional replybuffer actions switch-function)
+(defun message-setup (headers &optional replybuffer actions
+ continue switch-function)
(let ((mua (message-mail-user-agent))
subject to field yank-action)
(if (not (and message-this-is-mail mua))
(format "%s" (car item))
(cdr item)))
headers)
- nil switch-function yank-action actions)))))
+ continue switch-function yank-action actions)))))
(defun message-headers-to-generate (headers included-headers excluded-headers)
"Return a list that includes all headers from HEADERS.
-If INCLUDED-HEADERS is a list, just include those headers. If if is
+If INCLUDED-HEADERS is a list, just include those headers. If it is
t, include all headers. In any case, headers from EXCLUDED-HEADERS
are not included."
(let ((result nil)
other-headers continue switch-function
yank-action send-actions)
"Start editing a mail message to be sent.
-OTHER-HEADERS is an alist of header/value pairs."
+OTHER-HEADERS is an alist of header/value pairs. CONTINUE says whether
+to continue editing a message already being composed. SWITCH-FUNCTION
+is a function used to switch to and display the mail buffer."
(interactive)
(let ((message-this-is-mail t) replybuffer)
(unless (message-mail-user-agent)
- (message-pop-to-buffer (message-buffer-name "mail" to)))
+ (funcall
+ (or switch-function 'message-pop-to-buffer)
+ ;; Search for the existing message buffer if `continue' is non-nil.
+ (let ((message-generate-new-buffers
+ (when (or (not continue)
+ (eq message-generate-new-buffers 'standard)
+ (functionp message-generate-new-buffers))
+ message-generate-new-buffers)))
+ (message-buffer-name "mail" to))))
;; FIXME: message-mail should do something if YANK-ACTION is not
;; insert-buffer.
(and (consp yank-action) (eq (car yank-action) 'insert-buffer)
(nconc
`((To . ,(or to "")) (Subject . ,(or subject "")))
(when other-headers other-headers))
- replybuffer send-actions)
+ replybuffer send-actions continue switch-function)
;; FIXME: Should return nil if failure.
t))
(defun message-get-reply-headers (wide &optional to-address address-headers)
(let (follow-to mct never-mct to cc author mft recipients extra)
- ;; Find all relevant headers we need.
+ ;; Find all relevant headers we need.
(save-restriction
(message-narrow-to-headers-or-head)
;; Gmane renames "To". Look at "Original-To", too, if it is present in
(push (cons 'Cc recipients) follow-to)))
follow-to))
+(defcustom message-simplify-subject-functions
+ '(message-strip-list-identifiers
+ message-strip-subject-re
+ message-strip-subject-trailing-was
+ message-strip-subject-encoded-words)
+ "List of functions taking a string argument that simplify subjects.
+The functions are applied when replying to a message.
+
+Useful functions to put in this list include:
+`message-strip-list-identifiers', `message-strip-subject-re',
+`message-strip-subject-trailing-was', and
+`message-strip-subject-encoded-words'."
+ :version "22.1" ;; Gnus 5.10.9
+ :group 'message-various
+ :type '(repeat function))
+
+(defun message-simplify-subject (subject &optional functions)
+ "Return simplified SUBJECT."
+ (unless functions
+ ;; Simplify fully:
+ (setq functions message-simplify-subject-functions))
+ (when (and (memq 'message-strip-list-identifiers functions)
+ gnus-list-identifiers)
+ (setq subject (message-strip-list-identifiers subject)))
+ (when (memq 'message-strip-subject-re functions)
+ (setq subject (concat "Re: " (message-strip-subject-re subject))))
+ (when (and (memq 'message-strip-subject-trailing-was functions)
+ message-subject-trailing-was-query)
+ (setq subject (message-strip-subject-trailing-was subject)))
+ (when (memq 'message-strip-subject-encoded-words functions)
+ (setq subject (message-strip-subject-encoded-words subject)))
+ subject)
+
;;;###autoload
(defun message-reply (&optional to-address wide)
"Start editing a reply to the article in the current buffer."
date (message-fetch-field "date")
from (or (message-fetch-field "from") "nobody")
subject (or (message-fetch-field "subject") "none"))
- (when gnus-list-identifiers
- (setq subject (message-strip-list-identifiers subject)))
- (setq subject (concat "Re: " (message-strip-subject-re subject)))
- (when message-subject-trailing-was-query
- (setq subject (message-strip-subject-trailing-was subject)))
+
+ ;; Strip list identifiers, "Re: ", and "was:"
+ (setq subject (message-simplify-subject subject))
(when (and (setq gnus-warning (message-fetch-field "gnus-warning"))
(string-match "<[^>]+>" gnus-warning))
(let ((case-fold-search t))
(string-match "world" distribution)))
(setq distribution nil))
- (if gnus-list-identifiers
- (setq subject (message-strip-list-identifiers subject)))
- (setq subject (concat "Re: " (message-strip-subject-re subject)))
- (when message-subject-trailing-was-query
- (setq subject (message-strip-subject-trailing-was subject)))
+ ;; Strip list identifiers, "Re: ", and "was:"
+ (setq subject (message-simplify-subject subject))
(widen))
(message-pop-to-buffer (message-buffer-name "followup" from newsgroups))
(message-forward-make-body-digest-mime forward-buffer)
(message-forward-make-body-digest-plain forward-buffer)))
+(eval-and-compile
+ (autoload 'mm-uu-dissect-text-parts "mm-uu")
+ (autoload 'mm-uu-dissect "mm-uu"))
+
+(defun message-signed-or-encrypted-p (&optional dont-emulate-mime handles)
+ "Say whether the current buffer contains signed or encrypted message.
+If DONT-EMULATE-MIME is nil, this function does the MIME emulation on
+messages that don't conform to PGP/MIME described in RFC2015. HANDLES
+is for the internal use."
+ (unless handles
+ (let ((mm-decrypt-option 'never)
+ (mm-verify-option 'never))
+ (if (setq handles (mm-dissect-buffer nil t))
+ (unless dont-emulate-mime
+ (mm-uu-dissect-text-parts handles))
+ (unless dont-emulate-mime
+ (setq handles (mm-uu-dissect))))))
+ ;; Check text/plain message in which there is a signed or encrypted
+ ;; body that has been encoded by B or Q.
+ (unless (or handles dont-emulate-mime)
+ (let ((cur (current-buffer))
+ (mm-decrypt-option 'never)
+ (mm-verify-option 'never))
+ (with-temp-buffer
+ (insert-buffer-substring cur)
+ (when (setq handles (mm-dissect-buffer t t))
+ (if (and (prog1
+ (bufferp (car handles))
+ (mm-destroy-parts handles))
+ (equal (mm-handle-media-type handles) "text/plain"))
+ (progn
+ (mm-decode-content-transfer-encoding
+ (mm-handle-encoding handles))
+ (setq handles (mm-uu-dissect)))
+ (setq handles nil))))))
+ (when handles
+ (prog1
+ (catch 'found
+ (dolist (handle (if (stringp (car handles))
+ (if (member (car handles)
+ '("multipart/signed"
+ "multipart/encrypted"))
+ (throw 'found t)
+ (cdr handles))
+ (list handles)))
+ (if (stringp (car handle))
+ (when (message-signed-or-encrypted-p dont-emulate-mime handle)
+ (throw 'found t))
+ (when (and (bufferp (car handle))
+ (equal (mm-handle-media-type handle)
+ "message/rfc822"))
+ (with-current-buffer (mm-handle-buffer handle)
+ (when (message-signed-or-encrypted-p dont-emulate-mime)
+ (throw 'found t)))))))
+ (mm-destroy-parts handles))))
+
;;;###autoload
(defun message-forward-make-body (forward-buffer &optional digest)
;; Put point where we want it before inserting the forwarded
(if message-forward-as-mime
(if (and message-forward-show-mml
(not (and (eq message-forward-show-mml 'best)
+ ;; Use the raw form in the body if it contains
+ ;; signed or encrypted message so as not to be
+ ;; destroyed by re-encoding.
(with-current-buffer forward-buffer
- (goto-char (point-min))
- (re-search-forward
- "Content-Type: *multipart/\\(signed\\|encrypted\\)"
- nil t)))))
+ (condition-case nil
+ (message-signed-or-encrypted-p)
+ (error t))))))
(message-forward-make-body-mml forward-buffer)
(message-forward-make-body-mime forward-buffer))
(message-forward-make-body-plain forward-buffer)))
(message-pop-to-buffer (message-buffer-name "mail" to))))
(let ((message-this-is-mail t))
(message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
- nil nil 'switch-to-buffer-other-window)))
+ nil nil nil 'switch-to-buffer-other-window)))
;;;###autoload
(defun message-mail-other-frame (&optional to subject)
(message-pop-to-buffer (message-buffer-name "mail" to))))
(let ((message-this-is-mail t))
(message-setup `((To . ,(or to "")) (Subject . ,(or subject "")))
- nil nil 'switch-to-buffer-other-frame)))
+ nil nil nil 'switch-to-buffer-other-frame)))
;;;###autoload
(defun message-news-other-window (&optional newsgroups subject)
projects / gnus / blobdiff