:link '(custom-manual "(message)Mail Headers")
:type 'regexp)
-(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:"
+(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:\\|^NNTP-Posting-Date:\\|^X-Trace:\\|^X-Complaints-To:\\|^Cancel-Lock:\\|^Cancel-Key:\\|^X-Hashcash:\\|^X-Payment:\\|^Approved:"
"*Header lines matching this regexp will be deleted before posting.
It's best to delete old Path and Date headers before posting to avoid
any confusion."
:link '(custom-manual "(message)Message Headers")
:type '(repeat regexp))
+(defcustom message-cite-articles-with-x-no-archive t
+ "If non-nil, cite text from articles that has X-No-Archive set."
+ :group 'message
+ :type 'boolean)
+
;;; Internal variables.
;;; Well, not really internal.
"^|? *---+ +Message text follows: +---+ *|?$")
"A regexp that matches the separator before the text of a failed message.")
+(defvar message-field-fillers
+ '((To message-fill-field-address)
+ (Cc message-fill-field-address)
+ (From message-fill-field-address))
+ "Alist of header names/filler functions.")
+
(defvar message-header-format-alist
`((Newsgroups)
- (To . message-fill-address)
- (Cc . message-fill-address)
+ (To)
+ (Cc)
(Subject)
(In-Reply-To)
(Fcc)
(when value
(while (string-match "\n[\t ]+" value)
(setq value (replace-match " " t t value)))
- (set-text-properties 0 (length value) nil value)
value)))
(defun message-field-value (header &optional not-all)
(defun message-narrow-to-field ()
"Narrow the buffer to the header on the current line."
(beginning-of-line)
+ (while (looking-at "[ \t]")
+ (forward-line -1))
(narrow-to-region
(point)
(progn
(1+ max)))))
(message-sort-headers-1))))
-(defun message-delete-address ()
- "Delete the address under point."
+(defun message-kill-address ()
+ "Kill the address under point."
(interactive)
- (let ((start (point))
- (quote nil))
- (message-narrow-to-field)
- (while (and (not (eobp))
- (or (not (eq (setq char (following-char)) ?,))
- (not quote)))
- ())))
+ (let ((start (point)))
+ (message-skip-to-next-address)
+ (kill-region start (point))))
\f
(define-key message-mode-map "\C-c\C-d" 'message-dont-send)
(define-key message-mode-map "\C-c\n" 'gnus-delay-article)
+ (define-key message-mode-map "\C-c\M-k" 'message-kill-address)
(define-key message-mode-map "\C-c\C-e" 'message-elide-region)
(define-key message-mode-map "\C-c\C-v" 'message-delete-not-region)
(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)
(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)))
- (while (not (= begin end))
- (when (not (get-text-property begin 'message-hidden))
- (remove-text-properties begin (1+ begin)
- message-forbidden-properties))
- (incf begin))))
+ (dolist (from-to (message-text-with-property 'message-hidden
+ begin end t))
+ (remove-text-properties (car from-to) (cdr from-to)
+ message-forbidden-properties))))
;;;###autoload
(define-derived-mode message-mode text-mode "Message"
(interactive (list (if current-prefix-arg 'full)))
(if (if (boundp 'filladapt-mode) filladapt-mode)
nil
- (message-newline-and-reformat arg t)
+ (if (message-point-in-header-p)
+ (message-fill-field)
+ (message-newline-and-reformat arg t))
t))
;; Is it better to use `mail-header-end'?
(run-hooks 'mail-citation-hook)
(let ((start (point))
(end (mark t))
+ (x-no-archive nil)
(functions
(when message-indent-citation-function
(if (listp message-indent-citation-function)
(list message-indent-citation-function))))
(message-reply-headers (or message-reply-headers
(make-mail-header))))
- (mail-header-set-from message-reply-headers
- (save-restriction
- (narrow-to-region
- (point)
- (if (search-forward "\n\n" nil t)
- (1- (point))
- (point-max)))
+ (save-restriction
+ (narrow-to-region (point) (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point-max)))
+ (mail-header-set-from message-reply-headers
(or (message-fetch-field "from")
- "unknown sender")))
+ "unknown sender"))
+ (setq x-no-archive (message-fetch-field "x-no-archive")))
(goto-char start)
(while functions
(funcall (pop functions)))
(when message-citation-line-function
(unless (bolp)
(insert "\n"))
- (funcall message-citation-line-function)))))
+ (funcall message-citation-line-function))
+ (when (and x-no-archive
+ message-cite-articles-with-x-no-archive
+ (string-match "yes" x-no-archive))
+ (undo-boundary)
+ (delete-region (point) (mark t))
+ (insert "> [Quoted text removed due to X-No-Archive]\n")
+ (forward-line -1)))))
(defun message-insert-citation-line ()
"Insert a simple citation line."
'(invisible t mime-edit-invisible t))
(put-text-property start end 'invisible t))))))
-(defun message-text-with-property (prop)
- "Return a list of all points where the text has PROP."
- (let ((points nil)
- (point (point-min)))
- (save-excursion
- (while (< point (point-max))
- (when (get-text-property point prop)
- (push point points))
- (incf point)))
- (nreverse points)))
+(defun message-text-with-property (prop &optional start end reverse)
+ "Return a list of start and end positions where the text has PROP.
+START and END bound the search, they default to `point-min' and
+`point-max' respectively. If REVERSE is non-nil, find text which does
+not have PROP."
+ (unless start
+ (setq start (point-min)))
+ (unless end
+ (setq end (point-max)))
+ (let (next regions)
+ (if reverse
+ (while (and start
+ (setq start (text-property-any start end prop nil)))
+ (setq next (next-single-property-change start prop nil end))
+ (push (cons start (or next end)) regions)
+ (setq start next))
+ (while (and start
+ (or (get-text-property start prop)
+ (and (setq start (next-single-property-change
+ start prop nil end))
+ (get-text-property start prop))))
+ (setq next (text-property-any start end prop nil))
+ (push (cons start (or next end)) regions)
+ (setq start next)))
+ (nreverse regions)))
(defun message-fix-before-sending ()
"Do various things to make the message nice before sending it."
(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)))))
+ (dolist (from-to (message-text-with-property 'message-hidden))
+ (add-text-properties (car from-to) (cdr from-to)
+ '(invisible nil intangible nil)))
;; Make invisible text visible except for mime parts which may be
;; inserted by the MIME-Edit.
;; It doesn't seem as if this is useful, since the invisible property
(when (eval message-mailer-swallows-blank-line)
(newline))
(when message-interactive
- (save-excursion
- (set-buffer errbuf)
+ (with-current-buffer errbuf
(erase-buffer))))
(let* ((default-directory "/")
(cpr (as-binary-process
(defun message-make-date (&optional now)
"Make a valid data header.
If NOW, use that time instead."
- (let* ((now (or now (current-time)))
- (zone (nth 8 (decode-time now)))
- (sign "+"))
- (when (< zone 0)
- (setq sign "-")
- (setq zone (- zone)))
- (concat
- ;; The day name of the %a spec is locale-specific. Pfff.
- (format "%s, " (capitalize (car (rassoc (nth 6 (decode-time now))
- parse-time-weekdays))))
- (format-time-string "%d" now)
- ;; The month name of the %b spec is locale-specific. Pfff.
- (format " %s "
- (capitalize (car (rassoc (nth 4 (decode-time now))
- parse-time-months))))
- (format-time-string "%Y %H:%M:%S " now)
- ;; We do all of this because XEmacs doesn't have the %z spec.
- (format "%s%02d%02d" sign (/ zone 3600) (/ (% zone 3600) 60)))))
+ (let ((system-time-locale "C"))
+ (format-time-string "%a, %d %b %Y %T %z" now)))
(defun message-make-followup-subject (subject)
"Make a followup Subject."
(when field
(dolist (address (mail-header-parse-addresses field))
(setq address (car address)
- rhs (cadr (split-string address "@"))
- ace (idna-to-ascii rhs))
- (when (and (not (equalp rhs ace))
+ rhs (downcase (or (cadr (split-string address "@")) ""))
+ ace (downcase (idna-to-ascii rhs)))
+ (when (and (not (equal rhs ace))
(or (not (eq message-use-idna 'ask))
(y-or-n-p (format "Replace %s with %s? " rhs ace))))
(goto-char (point-min))
(if formatter
(funcall formatter header value)
(insert header-string ": " value))
+ (goto-char (message-fill-field))
;; We check whether the value was ended by a
- ;; newline. If now, we insert one.
+ ;; newline. If not, we insert one.
(unless (bolp)
(insert "\n"))
(forward-line -1)))
(unless optionalp
(push header-string message-inserted-headers)
(insert value)
- (when (bolp)
- (delete-char -1))))
+ (message-fill-field)))
;; Add the deletable property to the headers that require it.
(and (memq header message-deletable-headers)
(progn (beginning-of-line) (looking-at "[^:]+: "))
;;; Setting up a message buffer
;;;
+(defun message-skip-to-next-address ()
+ (let ((end (save-excursion
+ (message-next-header)
+ (point)))
+ quoted char)
+ (when (looking-at ",")
+ (forward-char 1))
+ (while (and (not (= (point) end))
+ (or (not (eq char ?,))
+ quoted))
+ (skip-chars-forward "^,\"" (point-max))
+ (when (eq (setq char (following-char)) ?\")
+ (setq quoted (not quoted)))
+ (unless (= (point) end)
+ (forward-char 1)))
+ (skip-chars-forward " \t\n")))
+
(defun message-fill-address (header value)
- (save-restriction
- (narrow-to-region (point) (point))
- (insert (capitalize (symbol-name header))
- ": "
- (if (consp value) (car value) value)
- "\n")
- (narrow-to-region (point-min) (1- (point-max)))
- (let (quoted last)
- (goto-char (point-min))
- (while (not (eobp))
- (skip-chars-forward "^,\"" (point-max))
- (if (or (eq (char-after) ?,)
- (eobp))
- (when (not quoted)
- (if (and (> (current-column) 78)
- last)
- (save-excursion
- (goto-char last)
- (looking-at "[ \t]*")
- (replace-match "\n " t t)))
- (setq last (1+ (point))))
- (setq quoted (not quoted)))
- (unless (eobp)
- (forward-char 1))))
- (goto-char (point-max))
- (widen)
- (forward-line 1)))
+ (insert (capitalize (symbol-name header))
+ ": "
+ (if (consp value) (car value) value)
+ "\n")
+ (message-fill-field-address))
(defun message-fill-references (header value)
(insert (capitalize (symbol-name header))
(split-line message-yank-prefix) ;; Emacs 21.3.50+ supports arg.
(error
(split-line))))
-
-(defun message-fill-header (header value)
+
+(defun message-insert-header (header value)
+ (insert (capitalize (symbol-name header))
+ ": "
+ (if (consp value) (car value) value)))
+
+(defun message-field-name ()
+ (save-excursion
+ (goto-char (point-min))
+ (when (looking-at "\\([^:]+\\):")
+ (intern (capitalize (match-string 1))))))
+
+(defun message-fill-field ()
+ (save-excursion
+ (save-restriction
+ (message-narrow-to-field)
+ (let ((field-name (message-field-name)))
+ (funcall (or (cadr (assq field-name message-field-fillers))
+ 'message-fill-field-general)))
+ (point-max))))
+
+(defun message-fill-field-address ()
+ (while (not (eobp))
+ (message-skip-to-next-address)
+ (let (last)
+ (if (and (> (current-column) 78)
+ last)
+ (progn
+ (save-excursion
+ (goto-char last)
+ (insert "\n\t"))
+ (setq last (1+ (point))))
+ (setq last (1+ (point)))))))
+
+(defun message-fill-field-general ()
(let ((begin (point))
(fill-column 78)
(fill-prefix " "))
- (insert (capitalize (symbol-name header))
- ": "
- (if (consp value) (car value) value)
- "\n")
- (save-restriction
- (narrow-to-region begin (point))
- (fill-region-as-paragraph begin (point))
- ;; Tapdance around looong Message-IDs.
- (forward-line -1)
- (when (looking-at "[ \t]*$")
- (message-delete-line))
- (goto-char begin)
- (re-search-forward ":" nil t)
- (when (looking-at "\n[ \t]+")
- (replace-match " " t t))
- (goto-char (point-max)))))
+ (while (and (search-forward "\n" nil t)
+ (not (eobp)))
+ (replace-match " " t t))
+ (fill-region-as-paragraph begin (point-max))
+ ;; Tapdance around looong Message-IDs.
+ (forward-line -1)
+ (when (looking-at "[ \t]*$")
+ (message-delete-line))
+ (goto-char begin)
+ (re-search-forward ":" nil t)
+ (when (looking-at "\n[ \t]+")
+ (replace-match " " t t))
+ (goto-char (point-max))))
(defun message-shorten-1 (list cut surplus)
"Cut SURPLUS elements out of LIST, beginning with CUTth one."
(when message-this-is-news
(while (< 998
(with-temp-buffer
- (message-fill-header header (mapconcat #'identity refs " "))
+ (message-insert-header
+ header (mapconcat #'identity refs " "))
(buffer-size)))
(message-shorten-1 refs cut 1)))
;; Finally, collect the references back into a string and insert
;; it into the buffer.
- (message-fill-header header (mapconcat #'identity refs " "))))
+ (message-insert-header header (mapconcat #'identity refs " "))))
(defun message-position-point ()
"Move point to where the user probably wants to find it."
:group 'message
:type '(alist :key-type regexp :value-type function))
+(defcustom message-expand-name-databases
+ (list 'bbdb 'eudc 'lsdb)
+ "List of databases to try for name completion (`message-expand-name').
+Each element is a symbol and can be `bbdb', `eudc' or `lsdb'."
+ :group 'message
+ :type '(set (const bbdb) (const eudc) (const lsdb)))
+
(defcustom message-expand-name-function
(cond ((and (boundp 'eudc-protocol)
eudc-protocol)
((fboundp 'lsdb-complete-name)
'lsdb-complete-name)
(t 'expand-abbrev))
- "*A function called to expand addresses in field body."
+ "*A function called to expand addresses in field body.
+This variable is semi-obsolete, set it as nil and use
+`message-expand-name-databases' instead."
:group 'message
- :type 'function)
+ :type '(radio (const :format "Invalidate it: %v\n" nil)
+ (function-item :format "eudc: %v\n" eudc-expand-inline)
+ (function-item :format "bbdb: %v\n" bbdb-complete-name)
+ (function-item :format "lsdb: %v\n" lsdb-complete-name)
+ (function :size 0 :value expand-abbrev)))
(defcustom message-tab-body-function nil
"*Function to execute when `message-tab' (TAB) is executed in the body.
(delete-region (point) (progn (forward-line 3) (point))))))))))
(defun message-expand-name ()
- (funcall message-expand-name-function))
+ (cond (message-expand-name-function
+ (funcall message-expand-name-function))
+ ((and (memq 'eudc message-expand-name-databases)
+ (boundp 'eudc-protocol)
+ eudc-protocol)
+ (eudc-expand-inline))
+ ((and (memq 'bbdb message-expand-name-databases)
+ (fboundp 'bbdb-complete-name))
+ (bbdb-complete-name))
+ ((and (memq 'lsdb message-expand-name-databases)
+ (fboundp 'lsdb-complete-name))
+ (lsdb-complete-name))
+ (t 'expand-abbrev)))
;;; Help stuff.