: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.
(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)
(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"
(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 (downcase (cadr (split-string address "@")))
+ 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))
: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.
(let ((locals (save-excursion
(set-buffer buffer)
(buffer-local-variables)))
- (regexp
- "^\\(gnus\\|nn\\|message\\|user-\\(mail-address\\|full-name\\)\\)"))
+ (regexp "^gnus\\|^nn\\|^message\\|^sendmail\\|^smtp\\|^user-mail-address\\|^user-full-name"))
(mapcar
(lambda (local)
(when (and (consp local)
projects / elisp / gnus.git- / blobdiff