(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 '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 'mail-parse)
(require 'mml)
(require 'rfc822)
+(require 'ecomplete)
(defgroup message '((user-mail-address custom-variable)
(user-full-name custom-variable))
: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
;;; End of variables adopted from `message-utils.el'.
-;;;###autoload
(defcustom message-signature-separator "^-- *$"
"Regexp matching the signature separator."
:type 'regexp
: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")
: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."
: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:"
+ "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.
:link '(custom-manual "(message)Insertion Variables")
:group 'message-insertion)
-;;;###autoload
(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)))
+
+;; #### FIXME: this might become a generally usefull function at some point
+;; --dlv.
+(defsubst message-dont-reply-to-names ()
+ "Potentially convert a list of regexps into a single one."
+ (cond ((null message-dont-reply-to-names)
+ nil)
+ ((stringp message-dont-reply-to-names)
+ message-dont-reply-to-names)
+ ((listp message-dont-reply-to-names)
+ (mapconcat (lambda (elt) (concat "\\(" elt "\\)"))
+ message-dont-reply-to-names
+ "\\|"))))
(defvar message-shoot-gnksa-feet nil
"*A list of GNKSA feet you are allowed to shoot.
(or (not (listp message-shoot-gnksa-feet))
(memq feature message-shoot-gnksa-feet)))
-(defcustom message-hidden-headers "^References:"
+(defcustom message-hidden-headers '("^References:" "^Face:" "^X-Face:"
+ "^X-Draft-From:")
"Regexp of headers to be hidden when composing new messages.
This can also be a list of regexps to match headers. Or a list
starting with `not' and followed by regexps."
(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.
(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-request-post "gnus-int")
(autoload 'gnus-server-string "gnus")
(autoload 'idna-to-ascii "idna")
- (autoload 'gmm-tool-bar-from-list "gmm-utils")
(autoload 'message-setup-toolbar "messagexmas")
(autoload 'mh-new-draft-name "mh-comp")
(autoload 'mh-send-letter "mh-comp")
(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)
(define-key message-mode-map "\C-a" 'message-beginning-of-line)
(define-key message-mode-map "\t" 'message-tab)
- (define-key message-mode-map "\M-;" 'comment-region))
+ (define-key message-mode-map "\M-;" 'comment-region)
+
+ (define-key message-mode-map "\M-n" 'message-display-abbrev))
(easy-menu-define
message-mode-menu message-mode-map "Message Menu."
"----"
["Sort Headers" message-sort-headers t]
["Encode non-ASCII domain names" message-idna-to-ascii-rhs t]
+ ;; We hide `message-hidden-headers' by narrowing the buffer.
+ ["Show Hidden Headers" widen t]
["Goto Body" message-goto-body t]
["Goto Signature" message-goto-signature t]))
(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 (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))
(let ((buffer-read-only nil)
(add-hook 'after-change-functions 'message-strip-forbidden-properties
nil 'local)
;; Allow mail alias things.
- (when (eq message-mail-alias-type 'abbrev)
+ (cond
+ ((message-mail-alias-type-p 'abbrev)
(if (fboundp 'mail-abbrevs-setup)
(mail-abbrevs-setup)
(if (fboundp 'mail-aliases-setup) ; warning avoidance
(mail-aliases-setup))))
+ ((message-mail-alias-type-p 'ecomplete)
+ (ecomplete-setup)))
(unless buffer-file-name
(message-set-auto-save-file-name))
(unless (buffer-base-buffer)
(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
(message-carefully-insert-headers headers)))
(defcustom message-header-synonyms
- '((To Cc Bcc))
+ '((To Cc Bcc)
+ (Original-To))
"List of lists of header synonyms.
E.g., if this list contains a member list with elements `Cc' and `To',
then `message-carefully-insert-headers' will not insert a `To' header
(message-newline-and-reformat arg t))
t))
-;; Is it better to use `mail-header-end'?
(defun message-point-in-header-p ()
"Return t if point is in the header."
(save-excursion
- (let ((p (point)))
- (goto-char (point-min))
- (not (re-search-forward
- (concat "^" (regexp-quote mail-header-separator) "\n")
- p t)))))
+ (not (re-search-backward
+ (concat "^" (regexp-quote mail-header-separator) "\n") nil t))))
(defun message-do-auto-fill ()
"Like `do-auto-fill', but don't fill in message header."
(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)
(point)))
(unless arg
(funcall message-cite-function))
- (message-exchange-point-and-mark)
+ (if message-cite-reply-above
+ (progn
+ (message-goto-body)
+ (insert body-text)
+ (newline)
+ (message-goto-body)
+ (message-exchange-point-and-mark))
+ (message-exchange-point-and-mark))
(unless (bolp)
(insert ?\n))
(unless modified
(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)
+ (newline)))
+
(defun message-cite-original-without-signature ()
"Cite function in the standard Message manner.
This function strips off the signature from the original message."
(save-excursion
(run-hooks 'message-sent-hook))
(message "Sending...done")
+ ;; Do ecomplete address snarfing.
+ (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)
(delete-auto-save-file-if-necessary t)
(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)
(when (let ((char (char-after)))
(or (< (mm-char-int char) 128)
(and (mm-multibyte-p)
- ;; Fixme: Wrong for Emacs 23 and for things
- ;; like undecable utf-8. Should at least
+ ;; FIXME: Wrong for Emacs 23 (unicode) and for
+ ;; things like undecable utf-8. Should at least
;; use find-coding-systems-region.
(memq (char-charset char)
'(eight-bit-control eight-bit-graphic
(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
(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))
(* 25 25)))
(let ((tm (current-time)))
(concat
- (if (memq system-type '(ms-dos emx vax-vms))
+ (if (or (memq system-type '(ms-dos emx vax-vms))
+ ;; message-number-base36 doesn't handle bigints.
+ (floatp (user-uid)))
(let ((user (downcase (user-login-name))))
(while (string-match "[^a-z0-9_]" user)
(aset user (match-beginning 0) ?_))
(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)
(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))
;; Email address in From field equals to our address
(and (setq from (message-fetch-field "from"))
(string-equal
- (downcase (cadr (mail-extract-address-components from)))
- (downcase (cadr (mail-extract-address-components
- (message-make-from))))))
+ (downcase (car (mail-header-parse-address from)))
+ (downcase (car (mail-header-parse-address
+ (message-make-from))))))
;; Email address in From field matches
;; 'message-alternative-emails' regexp
(and from
message-alternative-emails
(string-match
message-alternative-emails
- (cadr (mail-extract-address-components from))))))))))
+ (car (mail-header-parse-address from))))))))))
;;;###autoload
(defun message-cancel-news (&optional arg)
(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")
(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
+ (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)))
+ (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)))
(set-buffer (get-buffer-create " *message resend*"))
(erase-buffer))
(let ((message-this-is-mail t)
+ message-generate-hashcash
message-setup-hook)
(message-setup `((To . ,address))))
;; Insert our usual headers.
;; Send it.
(let ((message-inhibit-body-encoding t)
message-required-mail-headers
+ message-generate-hashcash
rfc2047-encode-encoded-words)
(message-send-mail))
(kill-buffer (current-buffer)))
;; Support for toolbar
(eval-when-compile
- (defvar tool-bar-map)
(defvar tool-bar-mode))
-;; Note: The :set function in the `message-tool-bar*' will only affect _new_
-;; message buffers. We might add a function that walks thru all message-mode
-;; buffers and force the update.
+;; Note: The :set function in the `message-tool-bar*' variables will only
+;; affect _new_ message buffers. We might add a function that walks thru all
+;; message-mode buffers and force the update.
(defun message-tool-bar-update (&optional symbol value)
"Update message mode toolbar.
Setter function for custom variables."
- (if symbol
- ;; When used as ":set" function:
- (progn
- (set-default symbol value)
- (setq-default message-tool-bar-map nil))
- (message-make-tool-bar t)))
-
-;; The default will be changed to `message-tool-bar-gnome' when the new icons
-;; have been checked in:
-(defcustom message-tool-bar 'message-tool-bar-retro
+ (setq-default message-tool-bar-map nil)
+ (when symbol
+ ;; When used as ":set" function:
+ (set-default symbol value)))
+
+(defcustom message-tool-bar (if (eq gmm-tool-bar-style 'gnome)
+ 'message-tool-bar-gnome
+ 'message-tool-bar-retro)
"Specifies the message mode tool bar.
It can be either a list or a symbol refering to a list. See
:set 'message-tool-bar-update
:group 'message)
-;; The new icons are not yet committed, see
-;; http://thread.gmane.org/gmane.emacs.gnus.general/61719
(defcustom message-tool-bar-gnome
- '((ignore "separator" nil :help "") ;; How to get no tooltip?
- (message-send-and-exit "send")
- (message-dont-send "save-draft")
+ '((ispell-message "spell" nil
+ :visible (or (not (boundp 'flyspell-mode))
+ (not flyspell-mode)))
+ (flyspell-buffer "spell" t
+ :visible (and (boundp 'flyspell-mode)
+ flyspell-mode)
+ :help "Flyspell whole buffer")
+ (gmm-ignore "separator")
+ (message-send-and-exit "mail/send")
+ (message-dont-send "mail/save-draft")
(message-kill-buffer "close") ;; stock_cancel
(mml-attach-file "attach" mml-mode-map)
- (ispell-message "spell" nil :visible (not flyspell-mode))
- (flyspell-buffer "spell" t :visible flyspell-mode
- :help "Flyspell whole buffer")
- ;; We should have a mail-preview icon with an envelope like the one in
- ;; stock_mail-reply.
- (mml-preview "mail-preview" mml-mode-map)
+ (mml-preview "mail/preview" mml-mode-map)
(mml-secure-message-sign-encrypt "lock" mml-mode-map :visible nil)
(message-insert-importance-high "important" nil :visible nil)
(message-insert-importance-low "unimportant" nil :visible nil)
(message-insert-disposition-notification-to "receipt" nil :visible nil)
+ (gmm-customize-mode "preferences" t :help "Edit mode preferences")
(message-info "help" t :help "Message manual"))
"List of items for the message tool bar (GNOME style).
:group 'message)
(defcustom message-tool-bar-retro
- '((message-send-and-exit "mail/send")
+ '(;; Old Emacs 21 icon for consistency.
+ (message-send-and-exit "gnus/mail_send")
(message-kill-buffer "close")
(message-dont-send "cancel")
(mml-attach-file "attach" mml-mode-map)
(ispell-message "spell")
(mml-preview "preview" mml-mode-map)
- (message-insert-importance-high "important")
- (message-insert-importance-low "unimportant")
- (message-insert-disposition-notification-to "receipt"))
+ (message-insert-importance-high "gnus/important")
+ (message-insert-importance-low "gnus/unimportant")
+ (message-insert-disposition-notification-to "gnus/receipt"))
"List of items for the message tool bar (retro style).
See `gmm-tool-bar-from-list' for details on the format of the list."
:set 'message-tool-bar-update
:group 'message)
+(defvar image-load-path)
+
(defun message-make-tool-bar (&optional force)
"Make a message mode tool bar from `message-tool-bar-list'.
When FORCE, rebuild the tool bar."
- (when (or (not message-tool-bar-map) force)
+ (when (and (not (featurep 'xemacs))
+ (boundp 'tool-bar-mode)
+ tool-bar-mode
+ (or (not message-tool-bar-map) force))
(setq message-tool-bar-map
- (when (default-value 'tool-bar-mode)
- (let ((load-path (mm-image-load-path)))
- (gmm-tool-bar-from-list message-tool-bar
- message-tool-bar-zap-list
- 'message-mode-map)))))
+ (let* ((load-path
+ (gmm-image-load-path-for-library "message"
+ "mail/save-draft.xpm"
+ nil t))
+ (image-load-path (cons (car load-path)
+ (when (boundp 'image-load-path)
+ image-load-path))))
+ (gmm-tool-bar-from-list message-tool-bar
+ message-tool-bar-zap-list
+ 'message-mode-map))))
message-tool-bar-map)
;;; Group name completion.
(not result)
result)))
+(defun message-put-addresses-in-ecomplete ()
+ (dolist (header '("to" "cc" "from" "reply-to"))
+ (let ((value (message-fetch-field header)))
+ (dolist (string (mail-header-parse-addresses value 'raw))
+ (setq string
+ (gnus-replace-in-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 (point-at-bol)) '(?C ?T ? ))
+ (message-point-in-header-p)
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-field)
+ (goto-char (point-min))
+ (looking-at "To\\|Cc"))))
+ (let* ((end (point))
+ (start (save-excursion
+ (and (re-search-backward "[\n\t ]" nil t)
+ (1+ (point)))))
+ (word (when start (buffer-substring start end)))
+ (match (when (and word
+ (not (zerop (length word))))
+ (ecomplete-display-matches 'mail word choose))))
+ (when (and choose match)
+ (delete-region start end)
+ (insert match)))))
+
(when (featurep 'xemacs)
(require 'messagexmas)
(message-xmas-redefine))