X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=b5bfab2394fa0dd130ebeba2098a5d1ac5dd08fc;hb=776420e32b917422c0d23086974c18be85b5d641;hp=d475da4857091d4c1558a8a302dc74d73028d0a8;hpb=4f807c32efc86ca1042eaaf27ece8196b57ce8c9;p=gnus diff --git a/lisp/message.el b/lisp/message.el index d475da485..b5bfab239 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -193,7 +193,8 @@ Checks include `subject-cmsg', `multiple-headers', `sendsys', :group 'message-news :type '(repeat sexp)) ; Fixme: improve this -(defcustom message-required-headers '((optional . References) From) +(defcustom message-required-headers '((optional . References) + From) "*Headers to be generated or prompted for when sending a message. Also see `message-required-news-headers' and `message-required-mail-headers'." @@ -302,6 +303,8 @@ few false positives here." :group 'message-various :type 'regexp) +;; Fixme: Why are all these things autoloaded? + ;;; marking inserted text ;;;###autoload @@ -432,7 +435,7 @@ If t, use `message-user-organization-file'." :group 'message-headers) (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. @@ -441,6 +444,8 @@ The provided functions are: * `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 @@ -688,7 +693,11 @@ variable isn't used." ;; create a dependence to `gnus.el'. :type 'sexp) -(defcustom message-generate-headers-first nil +;; FIXME: This should be a temporary workaround until someone implements a +;; proper solution. If a crash happens while replying, the auto-save file +;; will *not* have a `References:' header if `message-generate-headers-first' +;; is nil. See: http://article.gmane.org/gmane.emacs.gnus.general/51138 +(defcustom message-generate-headers-first '(references) "*If non-nil, generate all required headers before composing. The variables `message-required-news-headers' and `message-required-mail-headers' specify which headers to generate. @@ -700,6 +709,7 @@ are to be deleted and then re-generated before sending, so this variable will not have a visible effect for those headers." :group 'message-headers :type '(choice (const :tag "None" nil) + (const :tag "References" '(references)) (const :tag "All" t) (repeat (sexp :tag "Header")))) @@ -982,6 +992,13 @@ candidates: (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. @@ -1290,8 +1307,7 @@ no, only reply back to the author." (defcustom message-use-idna (and (condition-case nil (require 'idna) (file-error)) - (fboundp 'coding-system-p) - (coding-system-p 'utf-8) + (mm-coding-system-p 'utf-8) 'ask) "Whether to encode non-ASCII in domain names into ASCII according to IDNA." :group 'message-headers @@ -1438,7 +1454,8 @@ no, only reply back to the author." (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-delay-article "gnus-delay") + (autoload 'gnus-make-local-hook "gnus-util")) @@ -1478,8 +1495,8 @@ is used by default." (beg 1) (first t) quoted elems paren) - (save-excursion - (message-set-work-buffer) + (with-temp-buffer + (mm-enable-multibyte) (insert header) (goto-char (point-min)) (while (not (eobp)) @@ -1572,15 +1589,6 @@ is used by default." (mail-narrow-to-head) (message-fetch-field header)))) -(defun message-set-work-buffer () - (if (get-buffer " *message work*") - (progn - (set-buffer " *message work*") - (erase-buffer)) - (set-buffer (get-buffer-create " *message work*")) - (kill-all-local-variables) - (mm-enable-multibyte))) - (defun message-functionp (form) "Return non-nil if FORM is funcallable." (or (and (symbolp form) (fboundp form)) @@ -2091,6 +2099,7 @@ Point is left at the beginning of the narrowed-to 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-c\C-a" 'mml-attach-file) @@ -2215,7 +2224,7 @@ message composition doesn't break too bad." ;; 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: @@ -2246,7 +2255,11 @@ This function is intended to be called from `after-change-functions'. See also `message-forbidden-properties'." (when (and message-strip-special-text-properties (message-tamago-not-in-use-p begin)) - (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" @@ -2325,9 +2338,7 @@ M-RET `message-newline-and-reformat' (break the line and reformat)." (set (make-local-variable 'tool-bar-map) (message-tool-bar-map)))) (easy-menu-add message-mode-menu message-mode-map) (easy-menu-add message-mode-field-menu message-mode-map) - ;; make-local-hook is harmless though obsolete in Emacs 21. - ;; Emacs 20 and XEmacs need make-local-hook. - (make-local-hook 'after-change-functions) + (gnus-make-local-hook 'after-change-functions) ;; Mmmm... Forbidden properties... (add-hook 'after-change-functions 'message-strip-forbidden-properties nil 'local) @@ -2607,7 +2618,7 @@ With the prefix argument FORCE, insert the header anyway." (let ((point (point))) (message-goto-signature) (unless (eobp) - (forward-line -2)) + (end-of-line -1)) (kill-region point (point)) (unless (bolp) (insert "\n")))) @@ -2690,6 +2701,7 @@ Prefix arg means justify as well." (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))) @@ -2702,7 +2714,7 @@ Prefix arg means justify as well." (defun message-fill-paragraph (&optional arg) "Like `fill-paragraph'." (interactive (list (if current-prefix-arg 'full))) - (if (and (boundp 'filladapt-mode) filladapt-mode) + (if (if (boundp 'filladapt-mode) filladapt-mode) nil (message-newline-and-reformat arg t) t)) @@ -3271,7 +3283,14 @@ It should typically alter the sending method in some way or other." (goto-char (point-max)) (unless (bolp) (insert "\n")) - ;; Delete all invisible text. + ;; 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))))) + ;; Make invisible text visible. (message-check 'invisible-text (let ((points (message-text-with-property 'invisible))) (when points @@ -3901,7 +3920,7 @@ Otherwise, generate and save a value for `canlock-password' first." (length (setq to (completing-read "Followups to (default: no Followup-To header) " - (mapcar (lambda (g) (list g)) + (mapcar #'list (cons "poster" (message-tokenize-header newsgroups))))))))) @@ -3911,7 +3930,7 @@ Otherwise, generate and save a value for `canlock-password' first." ;; 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. @@ -3981,7 +4000,7 @@ Otherwise, generate and save a value for `canlock-password' first." errors) (y-or-n-p (format - "Really post to %s possibly unknown group%s: %s? " + "Really use %s possibly unknown group%s: %s? " (if (= (length errors) 1) "this" "these") (if (= (length errors) 1) "" "s") (mapconcat 'identity errors ", ")))) @@ -4363,9 +4382,9 @@ If NOW, use that time instead." (lsh (% message-unique-id-char 25) 16)) 4) (message-number-base36 (+ (nth 1 tm) (lsh (/ message-unique-id-char 25) 16)) 4) - ;; Append the newsreader name, because while the generated - ;; ID is unique to this newsreader, other newsreaders might - ;; otherwise generate the same ID via another algorithm. + ;; Append a given name, because while the generated ID is unique + ;; to this newsreader, other newsreaders might otherwise generate + ;; the same ID via another algorithm. ".fsf"))) (defun message-number-base36 (num len) @@ -4384,8 +4403,8 @@ If NOW, use that time instead." (if (message-functionp message-user-organization) (funcall message-user-organization) message-user-organization)))) - (save-excursion - (message-set-work-buffer) + (with-temp-buffer + (mm-enable-multibyte) (cond ((stringp organization) (insert organization)) ((and (eq t organization) @@ -4424,12 +4443,10 @@ If NOW, use that time instead." (date (mail-header-date message-reply-headers)) (msg-id (mail-header-message-id message-reply-headers))) (when from - (let ((stop-pos - (string-match " *at \\| *@ \\| *(\\| *<" from))) + (let ((name (mail-extract-address-components from))) (concat msg-id (if msg-id " (") - (if (and stop-pos - (not (zerop stop-pos))) - (substring from 0 stop-pos) from) + (or (car name) + (nth 1 name)) "'s message of \"" (if (or (not date) (string= date "")) "(unknown date)" date) @@ -4471,8 +4488,8 @@ If NOW, use that time instead." (user-full-name)))) (when (string= fullname "&") (setq fullname (user-login-name))) - (save-excursion - (message-set-work-buffer) + (with-temp-buffer + (mm-enable-multibyte) (cond ((or (null style) (equal fullname "")) @@ -4645,28 +4662,34 @@ subscribed address (and not the additional To and Cc header contents)." "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." - (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))))) + (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 end startpos endpos) + (let (rhs ace start startpos endpos ovl) (goto-char (point-min)) - (setq start (re-search-forward (concat "^" header) nil t) - end (or (save-excursion (re-search-forward "^[ \t]" nil t)) - (point-max))) - (when (and start end) - (while (re-search-forward "@\\([^ \t\r\n>]+\\)" end t) + (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)) @@ -4677,11 +4700,13 @@ I.e., calling it on a Subject: header is useless." (if (eq message-use-idna 'ask) (unwind-protect (progn - (replace-highlight startpos endpos) + (setq ovl (message-make-overlay startpos + endpos)) + (message-overlay-put ovl 'face 'highlight) (y-or-n-p (format "Replace with `%s'? " ace))) (message "") - (replace-dehighlight)) + (message-delete-overlay ovl)) message-use-idna))) (replace-match (concat "@" ace))))))) @@ -4903,6 +4928,16 @@ Headers already prepared in the buffer are not modified." (widen) (forward-line 1))) +(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) @@ -5217,6 +5252,10 @@ are not included." (when message-default-mail-headers (insert message-default-mail-headers) (or (bolp) (insert ?\n))) + (save-restriction + (message-narrow-to-headers) + (if message-alternative-emails + (message-use-alternative-email-as-from))) (when message-generate-headers-first (message-generate-headers (message-headers-to-generate @@ -5228,8 +5267,6 @@ are not included." (message-insert-signature) (save-restriction (message-narrow-to-headers) - (if message-alternative-emails - (message-use-alternative-email-as-from)) (run-hooks 'message-header-setup-hook)) (set-buffer-modified-p nil) (setq buffer-undo-list nil) @@ -5806,6 +5843,23 @@ the list of newsgroups is was posted to." (mail-decode-encoded-word-string prefix))) "] " 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 + (or (message-fetch-field "newsgroups") + (let ((from (message-fetch-field "from"))) + (and from + (cdr (mail-header-parse-address from)))) + "(nowhere)"))) + (if message-forward-decoded-p + prefix + (mail-decode-encoded-word-string prefix))) + "] " 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 @@ -5883,11 +5937,11 @@ Optional DIGEST will use digest to forward." (not message-forward-decoded-p)) (insert (with-temp-buffer - (mm-disable-multibyte-mule4) + (mm-disable-multibyte) (insert (with-current-buffer forward-buffer - (mm-with-unibyte-current-buffer-mule4 (buffer-string)))) - (mm-enable-multibyte-mule4) + (mm-with-unibyte-current-buffer (buffer-string)))) + (mm-enable-multibyte) (mime-to-mml) (goto-char (point-min)) (when (looking-at "From ") @@ -6136,6 +6190,9 @@ which specify the range to operate on." (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 @@ -6332,11 +6389,6 @@ regexp varstr." (cdr local))))) locals))) -;;; Miscellaneous functions - -(defsubst message-replace-chars-in-string (string from to) - (mm-subst-char-in-string from to string)) - ;;; ;;; MIME functions ;;; @@ -6448,6 +6500,39 @@ regexp varstr." (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) + '(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))