X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=314e5462423b0cde28082dc3d4aa240a9b31a6be;hb=89f56733a4665ec857c04c45ebf14ddacf82747e;hp=60aeda99b0d344a6b7495b7f66203aadea75fefc;hpb=6250e0fee04211ed52d1fc5d8fb8d37d88446d92;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index 60aeda9..314e546 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -414,7 +414,7 @@ included. Organization and User-Agent are optional." :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." @@ -1269,6 +1269,11 @@ starting with `not' and followed by regexps." :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. @@ -1862,7 +1867,6 @@ see `message-narrow-to-headers-or-head'." (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) @@ -2618,11 +2622,10 @@ See also `message-forbidden-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))) - (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" @@ -3578,6 +3581,7 @@ be added to the \"References\" field." (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) @@ -3585,22 +3589,28 @@ be added to the \"References\" field." (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." @@ -3896,16 +3906,31 @@ used to distinguish whether the invisible text is a MIME part or not." '(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." @@ -3915,12 +3940,9 @@ used to distinguish whether the invisible text is a MIME part or not." (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 @@ -4261,8 +4283,7 @@ This sub function is for exclusive use of `message-send-mail'." (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 @@ -5107,24 +5128,8 @@ Otherwise, generate and save a value for `canlock-password' first." (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." @@ -5494,7 +5499,7 @@ subscribed address (and not the additional To and Cc header contents)." (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)) @@ -7288,6 +7293,13 @@ which specify the range to operate on." :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) @@ -7297,9 +7309,15 @@ which specify the range to operate on." ((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. @@ -7366,7 +7384,19 @@ those headers." (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. @@ -7412,8 +7442,7 @@ regexp VARSTR." (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)