X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=314e5462423b0cde28082dc3d4aa240a9b31a6be;hb=89f56733a4665ec857c04c45ebf14ddacf82747e;hp=9df4753fae1c0189034e0e6081204e5cc5f1d4d8;hpb=eece261cac25dc313dfba7854b1050a590a1f9f3;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index 9df4753..314e546 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -59,12 +59,6 @@ (require 'mml)) (require 'rfc822) -(eval-and-compile - (autoload 'gnus-find-method-for-group "gnus") - (autoload 'nnvirtual-find-group-art "nnvirtual") - (autoload 'gnus-group-decoded-name "gnus-group")) -(eval-when-compile - (autoload 'sha1 "sha1-el")) (defgroup message '((user-mail-address custom-variable) (user-full-name custom-variable)) @@ -420,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." @@ -881,11 +875,6 @@ might set this variable to '(\"-f\" \"you@some.where\")." :type '(choice (function) (repeat string))) -(defvar message-cater-to-broken-inn t - "Non-nil means Gnus should not fold the `References' header. -Folding `References' makes ancient versions of INN create incorrect -NOV lines.") - (eval-when-compile (defvar gnus-post-method) (defvar gnus-select-method)) @@ -912,7 +901,7 @@ variable isn't used." ;; is nil. See: http://article.gmane.org/gmane.emacs.gnus.general/51138 (defcustom message-generate-headers-first '(references) "Which headers should be generated before starting to compose a message. -If `t', generate all required headers. This can also be a list of headers to +If t, generate all required headers. This can also be a list of headers to generate. The variables `message-required-news-headers' and `message-required-mail-headers' specify which headers to generate. @@ -1280,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. @@ -1698,10 +1692,16 @@ no, only reply back to the author." "^|? *---+ +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) @@ -1739,28 +1739,35 @@ no, only reply back to the author." :type 'regexp) (eval-and-compile - (autoload 'message-setup-toolbar "messagexmas") - (autoload 'mh-new-draft-name "mh-comp") - (autoload 'mh-send-letter "mh-comp") - (autoload 'gnus-output-to-rmail "gnus-util") - (autoload 'gnus-output-to-mail "gnus-util") - (autoload 'nndraft-request-associate-buffer "nndraft") - (autoload 'nndraft-request-expire-articles "nndraft") - (autoload 'gnus-open-server "gnus-int") - (autoload 'gnus-request-post "gnus-int") - (autoload 'gnus-copy-article-buffer "gnus-msg") (autoload 'gnus-alive-p "gnus-util") - (autoload 'gnus-server-string "gnus") + (autoload 'gnus-delay-article "gnus-delay") + (autoload 'gnus-extract-address-components "gnus-util") + (autoload 'gnus-find-method-for-group "gnus") + (autoload 'gnus-group-decoded-name "gnus-group") (autoload 'gnus-group-name-charset "gnus-group") (autoload 'gnus-group-name-decode "gnus-group") (autoload 'gnus-groups-from-server "gnus") - (autoload 'rmail-output "rmailout") - (autoload 'gnus-delay-article "gnus-delay") (autoload 'gnus-make-local-hook "gnus-util") - (autoload 'gnus-extract-address-components "gnus-util")) + (autoload 'gnus-open-server "gnus-int") + (autoload 'gnus-output-to-mail "gnus-util") + (autoload 'gnus-output-to-rmail "gnus-util") + (autoload 'gnus-request-post "gnus-int") + (autoload 'gnus-server-string "gnus") + (autoload 'idna-to-ascii "idna") + (autoload 'message-setup-toolbar "messagexmas") + (autoload 'mh-new-draft-name "mh-comp") + (autoload 'mh-send-letter "mh-comp") + (autoload 'mu-cite-original "mu-cite") + (autoload 'nndraft-request-associate-buffer "nndraft") + (autoload 'nndraft-request-expire-articles "nndraft") + (autoload 'nnvirtual-find-group-art "nnvirtual") + (autoload 'rmail-dont-reply-to "mail-utils") + (autoload 'rmail-msg-is-pruned "rmail") + (autoload 'rmail-msg-restore-non-pruned-header "rmail") + (autoload 'rmail-output "rmailout")) -(eval-and-compile - (autoload 'mu-cite-original "mu-cite")) +(eval-when-compile + (autoload 'sha1 "sha1-el")) @@ -1856,12 +1863,10 @@ is used by default." The buffer is expected to be narrowed to just the header of the message; see `message-narrow-to-headers-or-head'." (let* ((inhibit-point-motion-hooks t) - (case-fold-search t) (value (mail-fetch-field header nil (not not-all)))) (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) @@ -1874,14 +1879,14 @@ see `message-narrow-to-headers-or-head'." (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 (forward-line 1) (if (re-search-forward "^[^ \n\t]" nil t) - (progn - (beginning-of-line) - (point)) + (point-at-bol) (point-max)))) (goto-char (point-min))) @@ -2358,6 +2363,13 @@ Point is left at the beginning of the narrowed-to region." (1+ max))))) (message-sort-headers-1)))) +(defun message-kill-address () + "Kill the address under point." + (interactive) + (let ((start (point))) + (message-skip-to-next-address) + (kill-region start (point)))) + ;;; @@ -2432,11 +2444,11 @@ Point is left at the beginning of the narrowed-to region." (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) @@ -2610,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" @@ -2680,11 +2691,6 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (setq message-parameter-alist (copy-sequence message-startup-parameter-alist)) (message-setup-fill-variables) - (set - (make-local-variable 'paragraph-separate) - (format "\\(%s\\)\\|\\(%s\\)" - paragraph-separate - "<#!*/?\\(multipart\\|part\\|external\\|mml\\|secure\\)")) ;; Allow using comment commands to add/remove quoting. (set (make-local-variable 'comment-start) message-yank-prefix) (if (featurep 'xemacs) @@ -2731,7 +2737,8 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." "---+$\\|" ; delimiters for forwarded messages page-delimiter "$\\|" ; spoiler warnings ".*wrote:$\\|" ; attribution lines - quote-prefix-regexp "$")) ; empty lines in quoted text + quote-prefix-regexp "$\\|" ; empty lines in quoted text + mime-edit-tag-regexp)) ; MIME-Edit tags (setq paragraph-separate paragraph-start) (setq adaptive-fill-regexp (concat quote-prefix-regexp "\\|" adaptive-fill-regexp)) @@ -3020,16 +3027,23 @@ or in the synonym headers, defined by `message-header-synonyms'." (when (message-goto-signature) (forward-line -2))) -(defun message-kill-to-signature () - "Deletes all text up to the signature." - (interactive) - (let ((point (point))) - (message-goto-signature) - (unless (eobp) - (end-of-line -1)) - (kill-region point (point)) - (unless (bolp) - (insert "\n")))) +(defun message-kill-to-signature (&optional arg) + "Kill all text up to the signature. +If a numberic argument or prefix arg is given, leave that number +of lines before the signature intact." + (interactive "p") + (save-excursion + (save-restriction + (let ((point (point))) + (narrow-to-region point (point-max)) + (message-goto-signature) + (unless (eobp) + (if (and arg (numberp arg)) + (forward-line (- -1 arg)) + (end-of-line -1))) + (unless (= point (point)) + (kill-region point (point)) + (insert "\n")))))) (defun message-newline-and-reformat (&optional arg not-break) "Insert four newlines, and then reformat if inside quoted text. @@ -3124,7 +3138,9 @@ Prefix arg means justify as well." (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'? @@ -3565,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) @@ -3572,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." @@ -3883,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." @@ -3902,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 @@ -4248,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 @@ -4415,8 +4449,8 @@ This sub function is for exclusive use of `message-send-news'." "Send the prepared message buffer with `smtpmail-send-it'. This only differs from `smtpmail-send-it' that this command evaluates `message-send-mail-hook' just before sending a message. It is useful -if your ISP requires the POP-before-SMTP authentication. See the -documentation for the function `mail-source-touch-pop'." +if your ISP requires the POP-before-SMTP authentication. See the Gnus +manual for details." (run-hooks 'message-send-mail-hook) (smtpmail-send-it)) @@ -5094,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." @@ -5474,57 +5492,25 @@ subscribed address (and not the additional To and Cc header contents)." (delete-region (match-beginning 0) (1+ (std11-field-end))))))) 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))))))) + (let ((field (message-fetch-field header)) + rhs ace address) + (when field + (dolist (address (mail-header-parse-addresses field)) + (setq address (car 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)) + (y-or-n-p (format "Replace %s with %s? " rhs ace)))) + (goto-char (point-min)) + (while (re-search-forward (concat "^" header ":") nil t) + (message-narrow-to-field) + (while (search-forward (concat "@" rhs) nil t) + (replace-match (concat "@" ace) t t)) + (goto-char (point-max)) + (widen))))))) (defun message-idna-to-ascii-rhs () "Possibly IDNA encode non-ASCII domain names in From:, To: and Cc: headers. @@ -5645,8 +5631,9 @@ Headers already prepared in the buffer are not modified." (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))) @@ -5658,8 +5645,7 @@ Headers already prepared in the buffer are not modified." (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 "[^:]+: ")) @@ -5715,34 +5701,29 @@ Headers already prepared in the buffer are not modified." ;;; 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)) @@ -5759,27 +5740,57 @@ If the current line has `message-yank-prefix', insert it on the new line." (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." @@ -5788,8 +5799,9 @@ If the current line has `message-yank-prefix', insert it on the new line." (defun message-shorten-references (header references) "Trim REFERENCES to be 21 Message-ID long or less, and fold them. -If folding is disallowed, also check that the REFERENCES are less -than 988 characters long, and if they are not, trim them until they are." +When sending via news, also check that the REFERENCES are less +than 988 characters long, and if they are not, trim them until +they are." (let ((maxcount 21) (count 0) (cut 2) @@ -5811,33 +5823,26 @@ than 988 characters long, and if they are not, trim them until they are." (message-shorten-1 refs cut surplus) (decf count surplus))) - ;; If folding is disallowed, make sure the total length (including - ;; the spaces between) will be less than MAXSIZE characters. + ;; When sending via news, make sure the total folded length will + ;; be less than 998 characters. This is to cater to broken INN + ;; 2.3 which counts the total number of characters in a header + ;; rather than the physical line length of each line, as it shuld. ;; - ;; Only disallow folding for News messages. At this point the headers - ;; have not been generated, thus we use message-this-is-news directly. - (when (and message-this-is-news message-cater-to-broken-inn) - (let ((maxsize 988) - (totalsize (+ (apply #'+ (mapcar #'length refs)) - (1- count))) - (surplus 0) - (ptr (nthcdr (1- cut) refs))) - ;; Decide how many elements to cut off... - (while (> totalsize maxsize) - (decf totalsize (1+ (length (car ptr)))) - (incf surplus) - (setq ptr (cdr ptr))) - ;; ...and do it. - (when (> surplus 0) - (message-shorten-1 refs cut surplus)))) - + ;; This hack should be removed when it's believed than INN 2.3 is + ;; no longer widely used. + ;; + ;; At this point the headers have not been generated, thus we use + ;; message-this-is-news directly. + (when message-this-is-news + (while (< 998 + (with-temp-buffer + (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. - (let ((refstring (mapconcat #'identity refs " "))) - (if (and message-this-is-news message-cater-to-broken-inn) - (insert (capitalize (symbol-name header)) ": " - refstring "\n") - (message-fill-header header refstring))))) + (message-insert-header header (mapconcat #'identity refs " ")))) (defun message-position-point () "Move point to where the user probably wants to find it." @@ -6082,12 +6087,7 @@ are not included." (when message-default-headers (insert message-default-headers) (or (bolp) (insert ?\n))) - (put-text-property - (point) - (progn - (insert mail-header-separator "\n") - (1- (point))) - 'read-only nil) + (insert mail-header-separator "\n") (forward-line -1) (when (message-news-p) (when message-default-news-headers @@ -6986,8 +6986,6 @@ Optional NEWS will use news to forward instead of mail." (defun message-forward-rmail-make-body (forward-buffer) (save-window-excursion (set-buffer forward-buffer) - ;; Rmail doesn't have rmail-msg-restore-non-pruned-header in Emacs - ;; 20. FIXIT, or we drop support for rmail in Emacs 20. (if (rmail-msg-is-pruned) (rmail-msg-restore-non-pruned-header))) (message-forward-make-body forward-buffer)) @@ -7209,7 +7207,13 @@ which specify the range to operate on." (if (eq (char-after) (char-after (- (point) 2))) (delete-char -2)))))) -(defalias 'message-exchange-point-and-mark 'exchange-point-and-mark) +(defun message-exchange-point-and-mark () + "Exchange point and mark, but don't activate region if it was inactive." + (unless (prog1 + (message-mark-active-p) + (exchange-point-and-mark)) + (setq mark-active nil))) + (defalias 'message-make-overlay 'make-overlay) (defalias 'message-delete-overlay 'delete-overlay) (defalias 'message-overlay-put 'overlay-put) @@ -7289,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) @@ -7298,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. @@ -7367,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. @@ -7413,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)