:type 'regexp)
(defcustom message-make-forward-subject-function
- 'message-forward-subject-author-subject
+ 'message-forward-subject-name-subject
"*List of functions called to generate subject headers for forwarded messages.
The subject generated by the previous function is passed into each
successive function.
* `message-forward-subject-author-subject' (Source of article (author or
newsgroup)), in brackets followed by the subject
+* `message-forward-subject-name-subject' (Source of article (name of author
+ or newsgroup)), in brackets followed by the subject
* `message-forward-subject-fwd' (Subject of article with 'Fwd:' prepended
to it."
:group 'message-forwarding
(or (not (listp message-shoot-gnksa-feet))
(memq feature message-shoot-gnksa-feet)))
+(defcustom message-hidden-headers nil
+ "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.."
+ :group 'message
+ :type '(repeat regexp))
+
;;; Internal variables.
;;; Well, not really internal.
:link '(custom-manual "(message)News Headers")
:type 'string)
+(defcustom message-use-idna (and (condition-case nil (require 'idna)
+ (file-error))
+ (fboundp 'coding-system-p)
+ (coding-system-p 'utf-8)
+ 'ask)
+ "Whether to encode non-ASCII in domain names into ASCII according to IDNA."
+ :group 'message-headers
+ :type '(choice (const :tag "Ask" ask)
+ (const :tag "Never" nil)
+ (const :tag "Always" t)))
+
;;; Internal variables.
(defvar message-sending-message "Sending...")
(define-key message-mode-map "\C-c\C-z" 'message-kill-to-signature)
(define-key message-mode-map "\M-\r" 'message-newline-and-reformat)
;;(define-key message-mode-map "\M-q" 'message-fill-paragraph)
+ (define-key message-mode-map [remap split-line] 'message-split-line)
(define-key message-mode-map "\C-a" 'message-beginning-of-line)
(define-key message-mode-map "\t" 'message-tab)
["Reduce To: to Cc:" message-reduce-to-to-cc t]
"----"
["Sort Headers" message-sort-headers t]
+ ["Encode non-ASCII domain names" message-idna-to-ascii-rhs t]
["Goto Body" message-goto-body t]
["Goto Signature" message-goto-signature t]))
;; No reason this should be clutter up customize. We make it a
;; property list (rather than a list of property symbols), to be
;; directly useful for `remove-text-properties'.
- '(field nil read-only nil intangible nil invisible nil
+ '(field nil read-only nil invisible nil intangible nil
mouse-face nil modification-hooks nil insert-in-front-hooks nil
insert-behind-hooks nil point-entered nil point-left nil)
;; Other special properties:
(message-tamago-not-in-use-p begin)
;; Check whether the invisible MIME part is not inserted.
(not (text-property-any begin end 'mime-edit-invisible t)))
- (remove-text-properties begin end message-forbidden-properties)))
+ (while (not (= begin end))
+ (when (not (get-text-property begin 'message-hidden))
+ (remove-text-properties begin (1+ begin)
+ message-forbidden-properties))
+ (incf begin))))
;;;###autoload
(define-derived-mode message-mode text-mode "Message"
(delete-region (point) (re-search-forward "[ \t]*"))
(when (and quoted (not bolp))
(insert quoted leading-space)))
+ (undo-boundary)
(if quoted
(let* ((adaptive-fill-regexp
(regexp-quote (concat quoted leading-space)))
(push (pop saved-id) refs-list))
refs-list))
-(defvar gnus-article-copy)
(defun message-yank-original (&optional arg)
"Insert the message being replied to, if any.
Puts point before the text and mark after.
In addition, if `message-yank-add-new-references' is non-nil and this
command is called interactively, new IDs from the yanked article will
-be added to \"References\" field.
-\(See also `message-yank-add-new-references'.)"
+be added to the \"References\" field."
(interactive "P")
- (let ((modified (buffer-modified-p))
- (buffer (message-eval-parameter message-reply-buffer))
- start end refs)
- (when (and buffer
- message-cite-function)
- (delete-windows-on buffer t)
- (insert-buffer buffer) ; mark will be set at the end of article.
- (setq start (point)
- end (mark t))
-
- ;; Add new IDs to References field.
- (when (and message-yank-add-new-references (interactive-p))
- (save-excursion
- (save-restriction
- (message-narrow-to-headers)
- (setq refs (message-list-references
- nil
- (message-fetch-field "References")))
- (widen)
- (narrow-to-region start end)
- (std11-narrow-to-header)
- (when (setq refs (message-list-references
- refs
- (unless (eq message-yank-add-new-references
- 'message-id-only)
- (or (message-fetch-field "References")
- (message-fetch-field "In-Reply-To")))
- (message-fetch-field "Message-ID")))
+ (let ((modified (buffer-modified-p)))
+ (when (let ((buffer (message-eval-parameter message-reply-buffer)))
+ (and buffer
+ message-cite-function
+ (prog1
+ t
+ (delete-windows-on buffer t)
+ ; The mark will be set at the end of the article.
+ (insert-buffer buffer))))
+ ;; Add new IDs to the References field.
+ (when (and message-yank-add-new-references
+ (interactive-p))
+ (let ((start (point))
+ (end (mark t))
+ refs newrefs)
+ (save-excursion
+ (save-restriction
(widen)
- (message-narrow-to-headers)
- (goto-char (point-min))
- (let ((case-fold-search t))
- (if (re-search-forward "^References:\\([\t ]+.+\n\\)+" nil t)
+ (setq refs (message-list-references
+ nil
+ (or (message-make-references)
+ (prog2
+ (message-narrow-to-headers)
+ (message-fetch-field "References")
+ (widen)))))
+ (narrow-to-region start end)
+ (std11-narrow-to-header)
+ (unless (equal (setq newrefs
+ (message-list-references
+ (copy-sequence refs)
+ (unless (eq message-yank-add-new-references
+ 'message-id-only)
+ (or (message-fetch-field "References")
+ (message-fetch-field "In-Reply-To")))
+ (message-fetch-field "Message-ID")))
+ refs)
+ ;; If the References field has been changed, we make it
+ ;; visible in the header.
+ (mail-header-set-message-id message-reply-headers nil)
+ (mail-header-set-references message-reply-headers nil)
+ (widen)
+ (message-narrow-to-headers)
+ (if (let ((case-fold-search t))
+ (re-search-forward "^References:\\([\t ]+.+\n\\)+"
+ nil t))
(replace-match "")
- (goto-char (point-max))))
- (mail-header-format
- (list (or (assq 'References message-header-format-alist)
- '(References . message-fill-references)))
- (list (cons 'References
- (mapconcat 'identity (nreverse refs) " "))))
- (backward-delete-char 1)))))
-
+ (goto-char (point-max)))
+ (mail-header-format
+ (list (or (assq 'References message-header-format-alist)
+ '(References . message-fill-references)))
+ (list (cons 'References (mapconcat 'identity
+ (nreverse newrefs) " "))))
+ (backward-delete-char 1))))))
(unless arg
(if (and message-suspend-font-lock-when-citing
(boundp 'font-lock-mode)
(goto-char (point-max))
(unless (bolp)
(insert "\n"))
+ ;; Make the hidden headers visible.
+ (let ((points (message-text-with-property 'message-hidden)))
+ (when points
+ (goto-char (car points))
+ (dolist (point points)
+ (add-text-properties point (1+ point)
+ '(invisible nil intangible nil)))))
;; Delete all invisible text except for the mime parts which might
;; be inserted by the MIME-Edit.
(message-check 'invisible-text
;; Check "Shoot me".
(message-check 'shoot
(if (re-search-forward
- "Message-ID.*.i-did-not-set--mail-host-address--so-shoot-me" nil t)
+ "Message-ID.*.i-did-not-set--mail-host-address--so-tickle-me" nil t)
(y-or-n-p "You appear to have a misconfigured system. Really post? ")
t))
;; Check for Approved.
(let ((from (mail-header-from message-reply-headers))
(date (mail-header-date message-reply-headers))
(msg-id (mail-header-message-id message-reply-headers)))
- (when msg-id
- (concat msg-id
- (when from
- (let ((pair (std11-extract-address-components from)))
- (concat "\n ("
- (or (car pair) (cadr pair))
- "'s message of \""
- (if (or (not date) (string= date ""))
- "(unknown date)" date)
- "\")"))))))))
+ (when from
+ (let ((name (std11-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 ")")))))))
(defun message-make-distribution ()
"Make a Distribution header."
(concat message-user-agent " " user-agent))
message-user-agent)))))
+(defun message-idna-inside-rhs-p ()
+ "Return t iff point is inside a RHS (heuristically).
+Only works properly if header contains mailbox-list or address-list.
+I.e., calling it on a Subject: header is useless."
+ (save-restriction
+ (narrow-to-region (save-excursion (or (re-search-backward "^[^ \t]" nil t)
+ (point-min)))
+ (save-excursion (or (re-search-forward "^[^ \t]" nil t)
+ (point-max))))
+ (if (re-search-backward "[\\\n\r\t ]"
+ (save-excursion (search-backward "@" nil t)) t)
+ ;; whitespace between @ and point
+ nil
+ (let ((dquote 1) (paren 1))
+ (while (save-excursion (re-search-backward "[^\\]\"" nil t dquote))
+ (incf dquote))
+ (while (save-excursion (re-search-backward "[^\\]\(" nil t paren))
+ (incf paren))
+ (and (= (% dquote 2) 1) (= (% paren 2) 1))))))
+
+(autoload 'idna-to-ascii "idna")
+
+(defun message-idna-to-ascii-rhs-1 (header)
+ "Interactively potentially IDNA encode domain names in HEADER."
+ (let (rhs ace start startpos endpos ovl)
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^" header) nil t)
+ (while (re-search-forward "@\\([^ \t\r\n>]+\\)"
+ (or (save-excursion
+ (re-search-forward "^[^ \t]" nil t))
+ (point-max))
+ t)
+ (setq rhs (match-string-no-properties 1)
+ startpos (match-beginning 1)
+ endpos (match-end 1))
+ (when (save-match-data
+ (and (message-idna-inside-rhs-p)
+ (setq ace (idna-to-ascii rhs))
+ (not (string= rhs ace))
+ (if (eq message-use-idna 'ask)
+ (unwind-protect
+ (progn
+ (setq ovl (message-make-overlay startpos
+ endpos))
+ (message-overlay-put ovl 'face 'highlight)
+ (y-or-n-p
+ (format "Replace with `%s'? " ace)))
+ (message "")
+ (message-delete-overlay ovl))
+ message-use-idna)))
+ (replace-match (concat "@" ace)))))))
+
+(defun message-idna-to-ascii-rhs ()
+ "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers.
+See `message-idna-encode'."
+ (interactive)
+ (when message-use-idna
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-head)
+ (message-idna-to-ascii-rhs-1 "From")
+ (message-idna-to-ascii-rhs-1 "To")
+ (message-idna-to-ascii-rhs-1 "Cc")))))
+
(defun message-generate-headers (headers)
"Prepare article HEADERS.
Headers already prepared in the buffer are not modified."
(beginning-of-line))
(when (or (message-news-p)
(string-match "@.+\\.." secure-sender))
- (insert "Sender: " secure-sender "\n")))))))
+ (insert "Sender: " secure-sender "\n"))))
+ ;; Check for IDNA
+ (message-idna-to-ascii-rhs))))
(defun message-insert-courtesy-copy ()
"Insert a courtesy message in mail copies of combined messages."
(if (consp value) (car value) value))
"\n"))
+(defun message-split-line ()
+ "Split current line, moving portion beyond point vertically down.
+If the current line has `message-yank-prefix', insert it on the new line."
+ (interactive "*")
+ (condition-case nil
+ (split-line message-yank-prefix) ;; Emacs 21.3.50+ supports arg.
+ (error
+ (split-line))))
+
+
(defun message-fill-header (header value)
(let ((begin (point))
(fill-column 78)
"(nowhere)"))
"] " subject))
+(defun message-forward-subject-name-subject (subject)
+ "Generate a SUBJECT for a forwarded message.
+The form is: [Source] Subject, where if the original message was mail,
+Source is the name of the sender, and if the original message was
+news, Source is the list of newsgroups is was posted to."
+ (concat "["
+ (let ((prefix (message-fetch-field "newsgroups")))
+ (or prefix
+ (and (setq prefix (message-fetch-field "from"))
+ (car (std11-extract-address-components
+ (nnheader-decode-from prefix))))
+ "(nowhere)"))
+ "] " subject))
+
(defun message-forward-subject-fwd (subject)
"Generate a SUBJECT for a forwarded message.
The form is: Fwd: Subject, where Subject is the original subject of
(delete-char -2))))))
(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark)
+(defalias 'message-make-overlay 'make-overlay)
+(defalias 'message-delete-overlay 'delete-overlay)
+(defalias 'message-overlay-put 'overlay-put)
;; Support for toolbar
(eval-when-compile
(if (and (or to cc) bcc) ", ")
(or bcc "")))))))
+(defun message-hide-headers ()
+ "Hide headers based on the `message-hidden-headers' variable."
+ (let ((regexps (if (stringp message-hidden-headers)
+ (list message-hidden-headers)
+ message-hidden-headers))
+ (inhibit-point-motion-hooks t)
+ (after-change-functions nil))
+ (when regexps
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-headers)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (not (message-hide-header-p regexps))
+ (message-next-header)
+ (let ((begin (point)))
+ (message-next-header)
+ (add-text-properties begin (point)
+ '(intangible t invisible t
+ message-hidden t))))))))))
+
+(defun message-hide-header-p (regexps)
+ (let ((result nil)
+ (reverse nil))
+ (when (eq (car regexps) 'not)
+ (setq reverse t)
+ (pop regexps))
+ (dolist (regexp regexps)
+ (setq result (or result (looking-at regexp))))
+ (if reverse
+ (not result)
+ result)))
+
(when (featurep 'xemacs)
(require 'messagexmas)
(message-xmas-redefine))
projects / elisp / gnus.git- / blobdiff