;;; 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
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
(eval-when-compile
(require 'cl)
(defvar gnus-message-group-art)
- (defvar gnus-list-identifiers) ; gnus-sum is required where necessary
- (require 'hashcash))
+ (defvar gnus-list-identifiers)) ; gnus-sum is required where necessary
+(require 'hashcash)
(require 'canlock)
(require 'mailheader)
-(require 'nnheader)
(require 'gmm-utils)
+(require 'nnheader)
;; This is apparently necessary even though things are autoloaded.
;; Because we dynamically bind mail-abbrev-mode-regexp, we'd better
;; require mailabbrev here.
(require 'rfc822)
(require 'ecomplete)
+
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
"Mail and news message composing."
:group 'message-interface
:type 'regexp)
-;;;###autoload
(defcustom message-from-style 'default
"*Specifies how \"From\" headers look.
Don't touch this variable unless you really know what you're doing.
-Checks include `subject-cmsg', `multiple-headers', `sendsys',
-`message-id', `from', `long-lines', `control-chars', `size',
-`new-text', `quoting-style', `redirected-followup', `signature',
-`approved', `sender', `empty', `empty-headers', `message-id', `from',
-`subject', `shorten-followup-to', `existing-newsgroups',
-`buffer-file-name', `unchanged', `newsgroups', `reply-to',
-`continuation-headers', `long-header-lines', `invisible-text' and
-`illegible-text'."
+Checks include `approved', `continuation-headers', `control-chars',
+`empty', `existing-newsgroups', `from', `illegible-text',
+`invisible-text', `long-header-lines', `long-lines', `message-id',
+`multiple-headers', `new-text', `newsgroups', `quoting-style',
+`repeated-newsgroups', `reply-to', `sender', `sendsys', `shoot',
+`shorten-followup-to', `signature', `size', `subject', `subject-cmsg'
+and `valid-newsgroups'."
:group 'message-news
:type '(repeat sexp)) ; Fixme: improve this
: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
:version "22.1"
:type '(choice (const :tag "never" nil)
(const :tag "always strip" t)
- (const ask))
+ (const ask))
:link '(custom-manual "(message)Message Headers")
:group 'message-various)
;;; End of variables adopted from `message-utils.el'.
-;;;###autoload
(defcustom message-signature-separator "^-- *$"
"Regexp matching the signature separator."
:type 'regexp
: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."
:type '(choice string
(const :tag "consult file" t)))
-;;;###autoload
-(defcustom message-user-organization-file "/usr/lib/news/organization"
+(defcustom message-user-organization-file
+ (let (orgfile)
+ (dolist (f (list "/etc/organization"
+ "/etc/news/organization"
+ "/usr/lib/news/organization"))
+ (when (file-readable-p f)
+ (setq orgfile f)))
+ orgfile)
"*Local news organization file."
:type 'file
:link '(custom-manual "(message)News Headers")
: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."
:type 'string)
;; Useful to set in site-init.el
-;;;###autoload
(defcustom message-send-mail-function
(let ((program (if (boundp 'sendmail-program)
;; see paths.el
: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."
:group 'message-headers
:link '(custom-manual "(message)Message Headers")
:type '(choice (const :tag "None" nil)
- (const :tag "References" '(references))
- (const :tag "All" t)
- (repeat (sexp :tag "Header"))))
+ (const :tag "References" '(references))
+ (const :tag "All" t)
+ (repeat (sexp :tag "Header"))))
+
+(defcustom message-fill-column 72
+ "Column beyond which automatic line-wrapping should happen.
+Local value for message buffers. If non-nil, also turn on
+auto-fill in message buffers."
+ :group 'message-various
+ ;; :link '(custom-manual "(message)Message Headers")
+ :type '(choice (const :tag "Don't turn on auto fill" nil)
+ (integer)))
(defcustom message-setup-hook nil
"Normal hook, run each time a new outgoing message is initialized.
:version "22.1"
:group 'message-various)
-;;;###autoload
(defcustom message-citation-line-function 'message-insert-citation-line
"*Function called to insert the \"Whomever writes:\" line.
+Predefined functions include `message-insert-citation-line' and
+`message-insert-formated-citation-line' (see the variable
+`message-citation-line-format').
+
Note that Gnus provides a feature where the reader can click on
`writes:' to hide the cited text. If you change this line too much,
people who read your message will have to change their Gnus
configuration. See the variable `gnus-cite-attribution-suffix'."
- :type 'function
+ :type '(choice
+ (function-item :tag "plain" message-insert-citation-line)
+ (function-item :tag "formatted" message-insert-formated-citation-line)
+ (function :tag "Other"))
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
-;;;###autoload
+(defcustom message-citation-line-format "On %a, %b %d %Y, %N wrote:\n"
+ "Format of the \"Whomever writes:\" line.
+
+The string is formatted using `format-spec'. The following
+constructs are replaced:
+
+ %f The full From, e.g. \"John Doe <john.doe@example.invalid>\".
+ %n The mail address, e.g. \"john.doe@example.invalid\".
+ %N The real name if present, e.g.: \"John Doe\", else fall
+ back to the mail address.
+ %F The first name if present, e.g.: \"John\".
+ %L The last name if present, e.g.: \"Doe\".
+
+All other format specifiers are passed to `format-time-string'
+which is called using the date from the article your replying to.
+Extracting the first (%F) and last name (%L) is done
+heuristically, so you should always check it yourself.
+
+Please also read the note in the documentation of
+`message-citation-line-function'."
+ :type '(choice (const :tag "Plain" "%f writes:")
+ (const :tag "Include date" "On %a, %b %d %Y, %n wrote:")
+ string)
+ :link '(custom-manual "(message)Insertion Variables")
+ :version "23.0" ;; No Gnus
+ :group 'message-insertion)
+
(defcustom message-yank-prefix "> "
"*Prefix inserted on the lines of yanked messages.
Fix `message-cite-prefix-regexp' if it is set to an abnormal value.
:link '(custom-manual "(message)Insertion Variables")
:type 'integer)
-;;;###autoload
(defcustom message-cite-function 'message-cite-original
"*Function for citing an original message.
Predefined functions include `message-cite-original' and
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
-;;;###autoload
(defcustom message-indent-citation-function 'message-indent-citation
"*Function for modifying a citation just inserted in the mail buffer.
This can also be a list of functions. Each function can find the
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
-;;;###autoload
(defcustom message-signature t
"*String to be inserted at the end of the message buffer.
If t, the `message-signature-file' file will be inserted instead.
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
-;;;###autoload
(defcustom message-signature-file "~/.signature"
"*Name of file containing the text inserted at end of message buffer.
Ignored if the named file doesn't exist.
-If nil, don't insert a signature."
+If nil, don't insert a signature.
+If a path is specified, the value of `message-signature-directory' is ignored,
+even if set."
:type '(choice file (const :tags "None" nil))
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
-;;;###autoload
+(defcustom message-signature-directory nil
+ "*Name of directory containing signature files.
+Comes in handy if you have many such files, handled via posting styles for
+instance.
+If nil, `message-signature-file' is expected to specify the directory if
+needed."
+ :type '(choice string (const :tags "None" nil))
+ :link '(custom-manual "(message)Insertion Variables")
+ :group 'message-insertion)
+
(defcustom message-signature-insert-empty-line t
"*If non-nil, insert an empty line before the signature separator."
:version "22.1"
(defcustom message-mail-alias-type 'abbrev
"*What alias expansion type to use in Message buffers.
-The default is `abbrev', which uses mailabbrev. nil switches
-mail aliases off."
+The default is `abbrev', which uses mailabbrev. `ecomplete' uses
+an electric completion mode. nil switches mail aliases off.
+This can also be a list of values."
:group 'message
:link '(custom-manual "(message)Mail Aliases")
:type '(choice (const :tag "Use Mailabbrev" abbrev)
(const :tag "Use ecomplete" ecomplete)
(const :tag "No expansion" nil)))
+(defcustom message-self-insert-commands '(self-insert-command)
+ "List of `self-insert-command's used to trigger ecomplete.
+When one of those commands is invoked to enter a character in To or Cc
+header, ecomplete will suggest the candidates of recipients (see also
+`message-mail-alias-type'). If you use some tool to enter non-ASCII
+text and it replaces `self-insert-command' with the other command, e.g.
+`egg-self-insert-command', you may want to add it to this list."
+ :group 'message-various
+ :type '(repeat function))
+
(defcustom message-auto-save-directory
(file-name-as-directory (nnheader-concat message-directory "drafts"))
"*Directory where Message auto-saves buffers if Gnus isn't running.
(defcustom message-dont-reply-to-names
(and (boundp 'rmail-dont-reply-to-names) rmail-dont-reply-to-names)
- "*A regexp specifying addresses to prune when doing wide replies.
-A value of nil means exclude your own user name only."
+ "*Addresses to prune when doing wide replies.
+This can be a regexp or a list of regexps. Also, a value of nil means
+exclude your own user name only."
:version "21.1"
:group 'message
:link '(custom-manual "(message)Wide Reply")
:type '(choice (const :tag "Yourself" nil)
- regexp))
+ regexp
+ (repeat :tag "Regexp List" regexp)))
+
+(defsubst message-dont-reply-to-names ()
+ (gmm-regexp-concat message-dont-reply-to-names))
(defvar message-shoot-gnksa-feet nil
"*A list of GNKSA feet you are allowed to shoot.
`quoted-text-only' Allow you to post quoted text only;
`multiple-copies' Allow you to post multiple copies;
`cancel-messages' Allow you to cancel or supersede messages from
- your other email addresses.")
+ your other email addresses.")
(defsubst message-gnksa-enable-p (feature)
(or (not (listp message-shoot-gnksa-feet))
(defface message-header-to
'((((class color)
(background dark))
- (:foreground "green2" :bold t))
+ (:foreground "DarkOliveGreen1" :bold t))
(((class color)
(background light))
(:foreground "MidnightBlue" :bold t))
(defface message-header-cc
'((((class color)
(background dark))
- (:foreground "green4" :bold t))
+ (:foreground "chartreuse1" :bold t))
(((class color)
(background light))
(:foreground "MidnightBlue"))
(defface message-header-subject
'((((class color)
(background dark))
- (:foreground "green3"))
+ (:foreground "OliveDrab1"))
(((class color)
(background light))
(:foreground "navy blue" :bold t))
(defface message-header-other
'((((class color)
(background dark))
- (:foreground "#b00000"))
+ (:foreground "VioletRed1"))
(((class color)
(background light))
(:foreground "steel blue"))
(defface message-header-name
'((((class color)
(background dark))
- (:foreground "DarkGreen"))
+ (:foreground "green"))
(((class color)
(background light))
(:foreground "cornflower blue"))
(defface message-header-xheader
'((((class color)
(background dark))
- (:foreground "blue"))
+ (:foreground "DeepSkyBlue1"))
(((class color)
(background light))
(:foreground "blue"))
(defface message-separator
'((((class color)
(background dark))
- (:foreground "blue3"))
+ (:foreground "LightSkyBlue1"))
(((class color)
(background light))
(:foreground "brown"))
(defface message-cited-text
'((((class color)
(background dark))
- (:foreground "red"))
+ (:foreground "LightPink1"))
(((class color)
(background light))
(:foreground "red"))
(defface message-mml
'((((class color)
(background dark))
- (:foreground "ForestGreen"))
+ (:foreground "MediumSpringGreen"))
(((class color)
(background light))
(:foreground "ForestGreen"))
(1 'message-header-name)
(2 'message-header-newsgroups nil t))
(,(message-font-lock-make-header-matcher
- (concat "^\\([A-Z][^: \n\t]+:\\)" content))
+ (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
(1 'message-header-name)
- (2 'message-header-other nil t))
+ (2 'message-header-xheader))
(,(message-font-lock-make-header-matcher
- (concat "^\\(X-[A-Za-z0-9-]+:\\|In-Reply-To:\\)" content))
+ (concat "^\\([A-Z][^: \n\t]+:\\)" content))
(1 'message-header-name)
- (2 'message-header-name))
+ (2 'message-header-other nil t))
,@(if (and mail-header-separator
(not (equal mail-header-separator "")))
`((,(concat "^\\(" (regexp-quote mail-header-separator) "\\)$")
(const :tag "Never" nil)
(const :tag "Always" t)))
-(defcustom message-generate-hashcash nil
+(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
(concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain.
;; valid TLDs:
- "\\([a-z][a-z]" ;; two letter country TDLs
- "\\|biz\\|com\\|edu\\|gov\\|int\\|mil\\|net\\|org"
- "\\|aero\\|coop\\|info\\|name\\|museum"
- "\\|arpa\\|pro\\|uucp\\|bitnet\\|bofh" ;; old style?
- "\\)")
+ "\\([a-z][a-z]\\|" ;; two letter country TDLs
+ "aero\\|arpa\\|bitnet\\|biz\\|bofh\\|"
+ "cat\\|com\\|coop\\|edu\\|gov\\|"
+ "info\\|int\\|jobs\\|"
+ "mil\\|mobi\\|museum\\|name\\|net\\|"
+ "org\\|pro\\|travel\\|uucp\\)")
+ ;; http://en.wikipedia.org/wiki/List_of_Internet_top-level_domains
+ ;; http://en.wikipedia.org/wiki/GTLD
+ ;; `in the process of being approved': .asia .post .tel .sex
+ ;; "dead" nato bitnet uucp
"Regular expression that matches a valid FQDN."
;; see also: gnus-button-valid-fqdn-regexp
:version "22.1"
(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)
(widen)
(narrow-to-region
(goto-char (point-min))
- (cond
- ((re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "\n") nil t)
- (match-beginning 0))
- ((search-forward "\n\n" nil t)
- (1- (point)))
- (t
- (point-max))))
+ (if (re-search-forward (concat "\\(\n\\)\n\\|^\\("
+ (regexp-quote mail-header-separator)
+ "\n\\)")
+ nil t)
+ (or (match-end 1) (match-beginning 2))
+ (point-max)))
(goto-char (point-min)))
(defun message-news-p ()
(get-text-property pos 'egg-lang)
(get-text-property pos 'egg-start)))))
+(defsubst message-mail-alias-type-p (type)
+ (if (atom message-mail-alias-type)
+ (eq message-mail-alias-type type)
+ (memq type message-mail-alias-type)))
+
(defun message-strip-forbidden-properties (begin end &optional old-length)
"Strip forbidden properties between BEGIN and END, ignoring the third arg.
This function is intended to be called from `after-change-functions'.
See also `message-forbidden-properties'."
- (when (and (eq message-mail-alias-type 'ecomplete)
- (eq this-command 'self-insert-command))
+ (when (and (message-mail-alias-type-p 'ecomplete)
+ (memq this-command message-self-insert-commands))
(message-display-abbrev))
(when (and message-strip-special-text-properties
(message-tamago-not-in-use-p begin))
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-o move to From (\"Originator\")
+ C-c C-f C-o move to From (\"Originator\")
C-c C-f C-f move to Followup-To
C-c C-f C-m move to Mail-Followup-To
C-c C-f C-e move to Expires
(set (make-local-variable 'message-checksum) nil)
(set (make-local-variable 'message-mime-part) 0)
(message-setup-fill-variables)
+ (when message-fill-column
+ (setq fill-column message-fill-column)
+ (turn-on-auto-fill))
;; Allow using comment commands to add/remove quoting.
;; (set (make-local-variable 'comment-start) message-yank-prefix)
(when message-yank-prefix
nil 'local)
;; Allow mail alias things.
(cond
- ((eq message-mail-alias-type 'abbrev)
+ ((message-mail-alias-type-p 'abbrev)
(if (fboundp 'mail-abbrevs-setup)
(mail-abbrevs-setup)
(if (fboundp 'mail-aliases-setup) ; warning avoidance
(mail-aliases-setup))))
- ((eq message-mail-alias-type 'ecomplete)
+ ((message-mail-alias-type-p 'ecomplete)
(ecomplete-setup)))
(unless buffer-file-name
(message-set-auto-save-file-name))
(or (search-forward (concat "\n" mail-header-separator "\n") nil t)
(search-forward-regexp "[^:]+:\\([^\n]\\|\n[ \t]\\)+\n\n" nil t)))
+(defun message-in-body-p ()
+ "Return t if point is in the message body."
+ (let ((body (save-excursion (message-goto-body) (point))))
+ (>= (point) body)))
+
(defun message-goto-eoh ()
"Move point to the end of the headers."
(interactive)
(message-goto-body)
(forward-line -1))
-(defun message-in-body-p ()
- "Return t if point is in the message body."
- (let ((body (save-excursion (message-goto-body) (point))))
- (>= (point) body)))
-
(defun message-goto-signature ()
"Move point to the beginning of the message signature.
If there is no signature in the article, go to the end and
prefix FORCE is given."
(interactive "P")
(let* ((mct (message-fetch-reply-field "mail-copies-to"))
- (dont (and mct (or (equal (downcase mct) "never")
+ (dont (and mct (or (equal (downcase mct) "never")
(equal (downcase mct) "nobody"))))
- (to (or (message-fetch-reply-field "mail-reply-to")
- (message-fetch-reply-field "reply-to")
- (message-fetch-reply-field "from"))))
+ (to (or (message-fetch-reply-field "mail-reply-to")
+ (message-fetch-reply-field "reply-to")
+ (message-fetch-reply-field "from"))))
(when (and dont to)
(message
(if force
;; (mail-strip-quoted-names "Foo Bar <foo@bar>, bla@fasel (Bla Fasel)")
(dolist (header headers)
(let* ((header-name (symbol-name (car header)))
- (new-header (cdr header))
- (synonyms (loop for synonym in message-header-synonyms
+ (new-header (cdr header))
+ (synonyms (loop for synonym in message-header-synonyms
when (memq (car header) synonym) return synonym))
- (old-header
- (loop for synonym in synonyms
+ (old-header
+ (loop for synonym in synonyms
for old-header = (mail-fetch-field (symbol-name synonym))
when (and old-header (string-match new-header old-header))
return synonym)))
(if old-header
- (message "already have `%s' in `%s'" new-header old-header)
+ (message "already have `%s' in `%s'" new-header old-header)
(when (and (message-position-on-field header-name)
- (setq old-header (mail-fetch-field header-name))
- (not (string-match "\\` *\\'" old-header)))
+ (setq old-header (mail-fetch-field header-name))
+ (not (string-match "\\` *\\'" old-header)))
(insert ", "))
- (insert new-header)))))
+ (insert new-header)))))
(defun message-widen-reply ()
"Widen the reply to include maximum recipients."
((listp message-signature)
(eval message-signature))
(t message-signature)))
- (signature
+ signature-file)
+ (setq signature
(cond ((stringp signature)
signature)
- ((and (eq t signature)
- message-signature-file
- (file-exists-p message-signature-file))
- signature))))
+ ((and (eq t signature) message-signature-file)
+ (setq signature-file
+ (if (and message-signature-directory
+ ;; don't actually use the signature directory
+ ;; if message-signature-file contains a path.
+ (not (file-name-directory
+ message-signature-file)))
+ (nnheader-concat message-signature-directory
+ message-signature-file)
+ message-signature-file))
+ (file-exists-p signature-file))))
(when signature
(goto-char (point-max))
;; Insert the signature.
(insert "\n"))
(insert "-- \n")
(if (eq signature t)
- (insert-file-contents message-signature-file)
+ (insert-file-contents signature-file)
(insert signature))
(goto-char (point-max))
(or (bolp) (insert "\n")))))
(substring table ?a (+ ?a n))
(substring table (+ ?a 26) 255))))
-(defun message-caesar-buffer-body (&optional rotnum)
+(defun message-caesar-buffer-body (&optional rotnum wide)
"Caesar rotate all letters in the current buffer by 13 places.
Used to encode/decode possibly offensive messages (commonly in rec.humor).
With prefix arg, specifies the number of places to rotate each letter forward.
-Mail and USENET news headers are not rotated."
+Mail and USENET news headers are not rotated unless WIDE is non-nil."
(interactive (if current-prefix-arg
(list (prefix-numeric-value current-prefix-arg))
(list nil)))
(save-excursion
(save-restriction
- (when (message-goto-body)
+ (when (and (not wide) (message-goto-body))
(narrow-to-region (point) (point-max)))
(message-caesar-region (point-min) (point-max) rotnum))))
(let ((fill-prefix message-yank-prefix))
(fill-individual-paragraphs (point) (point-max) justifyp))))
-(defun message-indent-citation ()
+(defun message-indent-citation (&optional start end yank-only)
"Modify text just inserted from a message to be cited.
The inserted text should be the region.
When this function returns, the region is again around the modified text.
Normally, indent each nonblank line `message-indentation-spaces' spaces.
However, if `message-yank-prefix' is non-nil, insert that prefix on each line."
- (let ((start (point)))
+ (unless start (setq start (point)))
+ (unless yank-only
;; Remove unwanted headers.
(when message-ignored-cited-headers
(let (all-removed)
(insert "\n"))
(while (and (zerop (forward-line -1))
(looking-at "$"))
- (message-delete-line))
- ;; Do the indentation.
- (if (null message-yank-prefix)
- (indent-rigidly start (mark t) message-indentation-spaces)
- (save-excursion
- (goto-char start)
- (while (< (point) (mark t))
- (cond ((looking-at ">")
- (insert message-yank-cited-prefix))
- ((looking-at "^$")
- (insert message-yank-empty-prefix))
- (t
- (insert message-yank-prefix)))
- (forward-line 1))))
- (goto-char start)))
+ (message-delete-line)))
+ ;; Do the indentation.
+ (if (null message-yank-prefix)
+ (indent-rigidly start (or end (mark t)) message-indentation-spaces)
+ (save-excursion
+ (goto-char start)
+ (while (< (point) (or end (mark t)))
+ (cond ((looking-at ">")
+ (insert message-yank-cited-prefix))
+ ((looking-at "^$")
+ (insert message-yank-empty-prefix))
+ (t
+ (insert message-yank-prefix)))
+ (forward-line 1))))
+ (goto-char start))
+
+(defvar message-cite-reply-above nil
+ "If non-nil, start own text above the quote.
+
+Note: Top posting is bad netiquette. Don't use it unless you
+really must. You probably want to set variable only for specific
+groups, e.g. using `gnus-posting-styles':
+
+ (eval (set (make-local-variable 'message-cite-reply-above) t))
+
+This variable has no effect in news postings.")
(defun message-yank-original (&optional arg)
"Insert the message being replied to, if any.
Just \\[universal-argument] as argument means don't indent, insert no
prefix, and don't delete any headers."
(interactive "P")
- (let ((modified (buffer-modified-p)))
+ (let ((modified (buffer-modified-p))
+ body-text)
(when (and message-reply-buffer
message-cite-function)
+ (when message-cite-reply-above
+ (if (and (not (message-news-p))
+ (or (eq message-cite-reply-above 'is-evil)
+ (y-or-n-p "\
+Top posting is bad netiquette. Please don't top post unless you really must.
+Really top post? ")))
+ (save-excursion
+ (setq body-text
+ (buffer-substring (message-goto-body)
+ (point-max)))
+ (delete-region (message-goto-body) (point-max)))
+ (set (make-local-variable 'message-cite-reply-above) nil)))
(delete-windows-on message-reply-buffer t)
(push-mark (save-excursion
(insert-buffer-substring message-reply-buffer)
+ (unless (bolp)
+ (insert ?\n))
(point)))
(unless arg
- (funcall message-cite-function))
- (message-exchange-point-and-mark)
- (unless (bolp)
- (insert ?\n))
+ (funcall message-cite-function)
+ (unless (eq (char-before (mark t)) ?\n)
+ (let ((pt (point)))
+ (goto-char (mark t))
+ (insert-before-markers ?\n)
+ (goto-char pt))))
+ (when message-cite-reply-above
+ (message-goto-body)
+ (insert body-text)
+ (insert (if (bolp) "\n" "\n\n"))
+ (message-goto-body))
+ ;; Add a `message-setup-very-last-hook' here?
+ ;; Add `gnus-article-highlight-citation' here?
(unless modified
(setq message-checksum (message-checksum))))))
(setq x-no-archive (message-fetch-field "x-no-archive"))
(vector 0
(or (message-fetch-field "subject") "none")
- (message-fetch-field "from")
+ (or (message-fetch-field "from") "nobody")
(message-fetch-field "date")
(message-fetch-field "message-id" t)
(message-fetch-field "references")
(undo-boundary)
(delete-region (point) (mark t))
(insert "> [Quoted text removed due to X-No-Archive]\n")
+ (push-mark)
(forward-line -1)))))
(defun message-cite-original ()
"Cite function in the standard Message manner."
(message-cite-original-1 nil))
+(defun message-insert-formated-citation-line (&optional from date)
+ "Function that inserts a formated citation line.
+
+See `message-citation-line-format'."
+ ;; The optional args are for testing/debugging. They will disappear later.
+ ;; Example:
+ ;; (with-temp-buffer
+ ;; (message-insert-formated-citation-line
+ ;; "John Doe <john.doe@example.invalid>"
+ ;; (current-time))
+ ;; (buffer-string))
+ (when (or message-reply-headers (and from date))
+ (unless from
+ (setq from (mail-header-from message-reply-headers)))
+ (let* ((data (condition-case ()
+ (funcall (if (boundp gnus-extract-address-components)
+ gnus-extract-address-components
+ 'mail-extract-address-components)
+ from)
+ (error nil)))
+ (name (car data))
+ (fname name)
+ (lname name)
+ (net (car (cdr data)))
+ (name-or-net (or (car data)
+ (car (cdr data)) from))
+ (replydate
+ (or
+ date
+ ;; We need Gnus functionality if the user wants date or time from
+ ;; the original article:
+ (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
+ (let ((i ?A) lst)
+ (when (stringp name)
+ ;; Guess first name and last name:
+ (cond ((string-match
+ "\\`\\(\\w\\|[-.]\\)+ \\(\\w\\|[-.]\\)+\\'" name)
+ (setq fname (nth 0 (split-string name "[ \t]+"))
+ lname (nth 1 (split-string name "[ \t]+"))))
+ ((string-match
+ "\\`\\(\\w\\|[-.]\\)+, \\(\\w\\|[-.]\\)+\\'" name)
+ (setq fname (nth 1 (split-string name "[ \t,]+"))
+ lname (nth 0 (split-string name "[ \t,]+"))))
+ ((string-match
+ "\\`\\(\\w\\|[-.]\\)+\\'" name)
+ (setq fname name
+ lname ""))))
+ ;; The following letters are not used in `format-time-string':
+ (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 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 net lst)
+ (push ?o lst) (push "<o>" lst)
+ (push ?q lst) (push "<q>" lst)
+ (push ?t lst) (push "<t>" lst)
+ (push ?v lst) (push "<v>" lst)
+ ;; Delegate the rest to `format-time-string':
+ (while (<= i ?z)
+ (when (and (not (memq i lst))
+ ;; Skip (Z,a)
+ (or (<= i ?Z)
+ (>= i ?a)))
+ (push i lst)
+ (push (condition-case nil
+ (progn (format-time-string (format "%%%c" i)
+ replydate))
+ (format ">%c<" i))
+ lst))
+ (setq i (1+ i)))
+ (reverse lst)))
+ (spec (apply 'format-spec-make flist)))
+ (insert (format-spec message-citation-line-format spec)))
+ (newline)))
+
(defun message-cite-original-without-signature ()
"Cite function in the standard Message manner.
This function strips off the signature from the original message."
(run-hooks 'message-sent-hook))
(message "Sending...done")
;; Do ecomplete address snarfing.
- (when (eq message-mail-alias-type 'ecomplete)
+ (when (message-mail-alias-type-p 'ecomplete)
(message-put-addresses-in-ecomplete))
;; Mark the buffer as unmodified and delete auto-save.
(set-buffer-modified-p nil)
"Invisible text found and made visible; continue sending? ")
(error "Invisible text found and made visible")))))
(message-check 'illegible-text
- (let (found choice)
+ (let (char found choice)
(message-goto-body)
- (skip-chars-forward mm-7bit-chars)
- (while (not (eobp))
- (when (let ((char (char-after)))
- (or (< (mm-char-int char) 128)
- (and (mm-multibyte-p)
- (memq (char-charset char)
- '(eight-bit-control eight-bit-graphic
- control-1))
- (not (get-text-property
- (point) 'untranslated-utf-8)))))
+ (while (progn
+ (skip-chars-forward mm-7bit-chars)
+ (when (get-text-property (point) 'no-illegible-text)
+ ;; There is a signed or encrypted raw message part
+ ;; that is considered to be safe.
+ (goto-char (or (next-single-property-change
+ (point) 'no-illegible-text)
+ (point-max))))
+ (setq char (char-after)))
+ (when (or (< (mm-char-int char) 128)
+ (and (mm-multibyte-p)
+ (memq (char-charset char)
+ '(eight-bit-control eight-bit-graphic
+ control-1))
+ (not (get-text-property
+ (point) 'untranslated-utf-8))))
(message-overlay-put (message-make-overlay (point) (1+ (point)))
'face 'highlight)
(setq found t))
- (forward-char)
- (skip-chars-forward mm-7bit-chars))
+ (forward-char))
(when found
(setq choice
(gnus-multiple-choice
"Non-printable characters found. Continue sending?"
- '((?d "Remove non-printable characters and send")
- (?r "Replace non-printable characters with dots and send")
+ `((?d "Remove non-printable characters and send")
+ (?r ,(format
+ "Replace non-printable characters with \"%s\" and send"
+ message-replacement-char))
(?i "Ignore non-printable characters and send")
(?e "Continue editing"))))
(if (eq choice ?e)
(message-kill-all-overlays)
(delete-char 1)
(when (eq choice ?r)
- (insert "."))))
+ (insert message-replacement-char))))
(forward-char)
(skip-chars-forward mm-7bit-chars))))))
(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)
(let ((message-deletable-headers
(if news nil message-deletable-headers)))
(message-generate-headers headers))
+ ;; Check continuation headers.
+ (message-check 'continuation-headers
+ (goto-char (point-min))
+ (while (re-search-forward "^[^ \t\n][^ \t\n:]*[ \t\n]" nil t)
+ (goto-char (match-beginning 0))
+ (if (y-or-n-p "Fix continuation lines? ")
+ (insert " ")
+ (forward-line 1)
+ (unless (y-or-n-p "Send anyway? ")
+ (error "Failed to send the message")))))
;; Let the user do all of the above.
(run-hooks 'message-header-hook))
(unwind-protect
'call-process-region
(append
(list (point-min) (point-max)
- (if (boundp 'sendmail-program)
- sendmail-program
- "/usr/lib/sendmail")
+ (cond ((boundp 'sendmail-program)
+ sendmail-program)
+ ((file-exists-p "/usr/sbin/sendmail")
+ "/usr/sbin/sendmail")
+ ((file-exists-p "/usr/lib/sendmail")
+ "/usr/lib/sendmail")
+ ((file-exists-p "/usr/ucblib/sendmail")
+ "/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
;; free for -inject-arguments -- a big win for the user and for us
;; since we don't have to play that double-guessing game and the user
;; gets full control (no gestapo'ish -f's, for instance). --sj
- (if (functionp message-qmail-inject-args)
- (funcall message-qmail-inject-args)
- message-qmail-inject-args)))
+ (if (functionp message-qmail-inject-args)
+ (funcall message-qmail-inject-args)
+ message-qmail-inject-args)))
;; qmail-inject doesn't say anything on it's stdout/stderr,
;; we have to look at the retval instead
(0 nil)
(message-check 'continuation-headers
(goto-char (point-min))
(let ((do-posting t))
- (while (re-search-forward "^[^ \t\n][^:\n]*$" nil t)
+ (while (re-search-forward "^[^ \t\n][^ \t\n:]*[ \t\n]" nil t)
+ (goto-char (match-beginning 0))
(if (y-or-n-p "Fix continuation lines? ")
- (progn
- (goto-char (match-beginning 0))
- (insert " "))
+ (insert " ")
+ (forward-line 1)
(unless (y-or-n-p "Send anyway? ")
(setq do-posting nil))))
do-posting))
(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
(string-match "[\\()]" tmp)))))
(insert fullname)
(goto-char (point-min))
- ;; Look for a character that cannot appear unquoted
- ;; according to RFC 822.
- (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
- ;; Quote fullname, escaping specials.
- (goto-char (point-min))
- (insert "\"")
- (while (re-search-forward "[\"\\]" nil 1)
- (replace-match "\\\\\\&" t))
- (insert "\""))
+ ;; Look for a character that cannot appear unquoted
+ ;; according to RFC 822.
+ (when (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]" nil 1)
+ ;; Quote fullname, escaping specials.
+ (goto-char (point-min))
+ (insert "\"")
+ (while (re-search-forward "[\"\\]" nil 1)
+ (replace-match "\\\\\\&" t))
+ (insert "\""))
(insert " <" login ">"))
(t ; 'parens or default
(insert login " (")
(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))))
-
-(defun message-pop-to-buffer (name)
+ (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 &optional switch-function)
"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))
+ (funcall (or switch-function 'pop-to-buffer) buffer)
+ (set-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)))
+ (funcall (or switch-function 'pop-to-buffer) name)
+ (set-buffer name))
(erase-buffer)
(message-mode)))
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)))
+ (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))
+ switch-function))
;; 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
(while (string-match "[ \t][ \t]+" recipients)
(setq recipients (replace-match " " t t recipients)))
;; Remove addresses that match `rmail-dont-reply-to-names'.
- (let ((rmail-dont-reply-to-names message-dont-reply-to-names))
+ (let ((rmail-dont-reply-to-names (message-dont-reply-to-names)))
(setq recipients (rmail-dont-reply-to recipients)))
;; Perhaps "Mail-Copies-To: never" removed the only address?
(if (string-equal recipients "")
(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."
(setq message-id (message-fetch-field "message-id" t)
references (message-fetch-field "references")
date (message-fetch-field "date")
- from (message-fetch-field "from")
+ 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))
(setq e (point))
(insert
"\n-------------------- End of forwarded message --------------------\n")
- (when 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)))))
+ (message-remove-ignored-headers b e)))
+
+(defun message-remove-ignored-headers (b e)
+ (when 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)))
+ (let ((ignored (if (stringp message-forward-ignored-headers)
+ (list message-forward-ignored-headers)
+ message-forward-ignored-headers)))
+ (dolist (elem ignored)
+ (message-remove-header elem t))))))
(defun message-forward-make-body-mime (forward-buffer)
- (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")
- (let ((b (point)) e)
+ (let ((b (point)))
+ (insert "\n\n<#part type=message/rfc822 disposition=inline raw=t>\n")
(save-restriction
(narrow-to-region (point) (point))
(mml-insert-buffer forward-buffer)
(when (looking-at "From ")
(replace-match "X-From-Line: "))
(goto-char (point-max)))
- (setq e (point))
- (insert "<#/part>\n")))
+ (insert "<#/part>\n")
+ ;; Consider there is no illegible text.
+ (add-text-properties
+ b (point)
+ `(no-illegible-text t rear-nonsticky t start-open t))))
(defun message-forward-make-body-mml (forward-buffer)
(insert "\n\n<#mml type=message/rfc822 disposition=inline>\n")
(insert "<#/mml>\n")
(when (and (not message-forward-decoded-p)
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)))))
+ (message-remove-ignored-headers b e))))
(defun message-forward-make-body-digest-plain (forward-buffer)
(insert
(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)))
(goto-char boundary)
(when (re-search-backward "^.?From .*\n" nil t)
(delete-region (match-beginning 0) (match-end 0)))))
- (mm-enable-multibyte)
+ (mime-to-mml)
(save-restriction
(message-narrow-to-head-1)
(message-remove-header message-ignored-bounced-headers t)
(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)
(defun message-put-addresses-in-ecomplete ()
(dolist (header '("to" "cc" "from" "reply-to"))
- (let ((value (message-fetch-field header)))
+ (let ((value (message-field-value header)))
(dolist (string (mail-header-parse-addresses value 'raw))
(setq string
(gnus-replace-in-string
- "\n" ""
- (gnus-replace-in-string "^ +\\| *$" "" string)))
+ (gnus-replace-in-string string "^ +\\| +$" "") "\n" ""))
(ecomplete-add-item 'mail (car (mail-header-parse-address string))
string))))
(ecomplete-save))
(defun message-display-abbrev (&optional choose)
"Display the next possible abbrev for the text before point."
(interactive (list t))
- (when (and (member (char-after (line-beginning-position)) '(?C ?T ? ))
+ (when (and (memq (char-after (point-at-bol)) '(?C ?T ?\t ? ))
(message-point-in-header-p)
(save-excursion
- (save-restriction
- (message-narrow-to-field)
- (goto-char (point-min))
- (looking-at "To\\|Cc"))))
+ (beginning-of-line)
+ (while (and (memq (char-after) '(?\t ? ))
+ (zerop (forward-line -1))))
+ (looking-at "To:\\|Cc:")))
(let* ((end (point))
(start (save-excursion
(and (re-search-backward "[\n\t ]" nil t)
projects / gnus / blobdiff