X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=21fb83a2b60e73218b75fdb9ec5714fd3ed0edbb;hb=39c8ecc92d0d37c0fdcc99872120a791d9251b2d;hp=019fb626eeb93c025d75470cf912fff7214d13ac;hpb=40e2dac24752abb2415d82c6fac6fd2c52b1f59e;p=gnus diff --git a/lisp/message.el b/lisp/message.el index 019fb626e..21fb83a2b 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -1,7 +1,7 @@ ;;; message.el --- composing mail and news messages ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: mail, news @@ -1106,6 +1106,8 @@ If stringp, use this; if non-nil, use no host name (user name only)." (string :tag "name") (sexp :tag "none" :format "%t" t))) +;; This can be the name of a buffer, or a cons cell (FUNCTION . ARGS) +;; for yanking the original buffer. (defvar message-reply-buffer nil) (defvar message-reply-headers nil "The headers of the current replied article. @@ -1138,8 +1140,22 @@ these lines." :link '(custom-manual "(message)Message Headers") :type 'message-header-lines) -(defcustom message-default-mail-headers "" +(defcustom message-default-mail-headers + ;; Ease the transition from mail-mode to message-mode. See bugs#4431, 5555. + (concat (if (and (boundp 'mail-default-reply-to) + (stringp mail-default-reply-to)) + (format "Reply-to: %s\n" mail-default-reply-to) + "") + (if (and (boundp 'mail-self-blind) + mail-self-blind) + (format "BCC: %s\n" user-mail-address) + "") + (if (and (boundp 'mail-archive-file-name) + (stringp mail-archive-file-name)) + (format "FCC: %s\n" mail-archive-file-name) + "")) "*A string of header lines to be inserted in outgoing mails." + :version "23.2" :group 'message-headers :group 'message-mail :link '(custom-manual "(message)Mail Headers") @@ -1317,6 +1333,7 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-to-face 'face-alias 'message-header-to) +(put 'message-header-to-face 'obsolete-face "22.1") (defface message-header-cc '((((class color) @@ -1331,6 +1348,7 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-cc-face 'face-alias 'message-header-cc) +(put 'message-header-cc-face 'obsolete-face "22.1") (defface message-header-subject '((((class color) @@ -1345,6 +1363,7 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-subject-face 'face-alias 'message-header-subject) +(put 'message-header-subject-face 'obsolete-face "22.1") (defface message-header-newsgroups '((((class color) @@ -1359,6 +1378,7 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-newsgroups-face 'face-alias 'message-header-newsgroups) +(put 'message-header-newsgroups-face 'obsolete-face "22.1") (defface message-header-other '((((class color) @@ -1373,6 +1393,7 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-other-face 'face-alias 'message-header-other) +(put 'message-header-other-face 'obsolete-face "22.1") (defface message-header-name '((((class color) @@ -1387,6 +1408,7 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-name-face 'face-alias 'message-header-name) +(put 'message-header-name-face 'obsolete-face "22.1") (defface message-header-xheader '((((class color) @@ -1401,6 +1423,7 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-header-xheader-face 'face-alias 'message-header-xheader) +(put 'message-header-xheader-face 'obsolete-face "22.1") (defface message-separator '((((class color) @@ -1415,6 +1438,7 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-separator-face 'face-alias 'message-separator) +(put 'message-separator-face 'obsolete-face "22.1") (defface message-cited-text '((((class color) @@ -1429,6 +1453,7 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-cited-text-face 'face-alias 'message-cited-text) +(put 'message-cited-text-face 'obsolete-face "22.1") (defface message-mml '((((class color) @@ -1443,6 +1468,7 @@ starting with `not' and followed by regexps." :group 'message-faces) ;; backward-compatibility alias (put 'message-mml-face 'face-alias 'message-mml) +(put 'message-mml-face 'obsolete-face "22.1") (defun message-font-lock-make-header-matcher (regexp) (let ((form @@ -1824,7 +1850,6 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (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") @@ -1950,7 +1975,7 @@ see `message-narrow-to-headers-or-head'." (defmacro message-with-reply-buffer (&rest forms) "Evaluate FORMS in the reply buffer, if it exists." - `(when (and message-reply-buffer + `(when (and (bufferp message-reply-buffer) (buffer-name message-reply-buffer)) (with-current-buffer message-reply-buffer ,@forms))) @@ -2395,6 +2420,8 @@ Return the number of headers removed." (point-max))) (goto-char (point-min))) +;; FIXME: clarify diffference: message-narrow-to-head, +;; message-narrow-to-headers-or-head, message-narrow-to-headers (defun message-narrow-to-head () "Narrow the buffer to the head of the message. Point is left at the beginning of the narrowed-to region." @@ -2503,7 +2530,8 @@ Prefixed with one \\[universal-argument], display the Emacs MIME manual. With two \\[universal-argument]'s, display the EasyPG or PGG manual, depending on the value of `mml2015-use'." (interactive "p") - ;; Why not `info', which is in loaddefs.el? + ;; Don't use `info' because support for `(filename)nodename' is not + ;; available in XEmacs < 21.5.12. (Info-goto-node (format "(%s)Top" (cond ((eq arg 16) (require 'mml2015) @@ -2716,7 +2744,7 @@ PGG manual, depending on the value of `mml2015-use'." ;;; Forbidden properties ;; ;; We use `after-change-functions' to keep special text properties -;; that interfer with the normal function of message mode out of the +;; that interfere with the normal function of message mode out of the ;; buffer. (defcustom message-strip-special-text-properties t @@ -3129,7 +3157,7 @@ or in the synonym headers, defined by `message-header-synonyms'." "Widen the reply to include maximum recipients." (interactive) (let ((follow-to - (and message-reply-buffer + (and (bufferp message-reply-buffer) (buffer-name message-reply-buffer) (with-current-buffer message-reply-buffer (message-get-reply-headers t))))) @@ -3624,9 +3652,16 @@ Really top post? "))) (point-max))) (delete-region (message-goto-body) (point-max))) (set (make-local-variable 'message-cite-reply-above) nil))) - (delete-windows-on message-reply-buffer t) + (if (bufferp message-reply-buffer) + (delete-windows-on message-reply-buffer t)) (push-mark (save-excursion - (insert-buffer-substring message-reply-buffer) + (cond + ((bufferp message-reply-buffer) + (insert-buffer-substring message-reply-buffer)) + ((and (consp message-reply-buffer) + (functionp (car message-reply-buffer))) + (apply (car message-reply-buffer) + (cdr message-reply-buffer)))) (unless (bolp) (insert ?\n)) (point))) @@ -3811,9 +3846,8 @@ See `message-citation-line-format'." (>= i ?a))) (push i lst) (push (condition-case nil - (progn (format-time-string (format "%%%c" i) - replydate)) - (format ">%c<" i)) + (format-time-string (format "%%%c" i) replydate) + (error (format ">%c<" i))) lst)) (setq i (1+ i))) (reverse lst))) @@ -4140,6 +4174,8 @@ conformance." (and (mm-multibyte-p) (memq (char-charset char) '(eight-bit-control eight-bit-graphic + ;; Emacs 23, Bug#1770: + eight-bit control-1)) (not (get-text-property (point) 'untranslated-utf-8)))) @@ -4166,10 +4202,13 @@ conformance." (or (< (mm-char-int char) 128) (and (mm-multibyte-p) ;; FIXME: Wrong for Emacs 23 (unicode) and for - ;; things like undecable utf-8. Should at least - ;; use find-coding-systems-region. + ;; things like undecodable utf-8 (in Emacs 21?). + ;; Should at least use find-coding-systems-region. + ;; -- fx (memq (char-charset char) '(eight-bit-control eight-bit-graphic + ;; Emacs 23, Bug#1770: + eight-bit control-1)) (not (get-text-property (point) 'untranslated-utf-8))))) @@ -4232,7 +4271,7 @@ This function could be useful in `message-setup-hook'." (not (y-or-n-p (format "Address `%s' might be bogus. Continue? " bog))) - (error "Bogus address.")))))))) + (error "Bogus address")))))))) (custom-add-option 'message-setup-hook 'message-check-recipients) @@ -4607,17 +4646,17 @@ to find out how to use this." (defun message-smtpmail-send-it () "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 Gnus -manual for details." +The only difference from `smtpmail-send-it' is 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 Gnus manual for details." (run-hooks 'message-send-mail-hook) (smtpmail-send-it)) (defun message-send-mail-with-mailclient () "Send the prepared message buffer with `mailclient-send-it'. -This only differs from `smtpmail-send-it' that this command evaluates -`message-send-mail-hook' just before sending a message." +The only difference from `mailclient-send-it' is that this +command evaluates `message-send-mail-hook' just before sending a message." (run-hooks 'message-send-mail-hook) (mailclient-send-it)) @@ -5023,7 +5062,8 @@ Otherwise, generate and save a value for `canlock-password' first." "Denied posting -- the From looks strange: \"%s\"." from) nil) ((let ((addresses (rfc822-addresses from))) - (while (and addresses + ;; `rfc822-addresses' returns a string if parsing fails. + (while (and (consp addresses) (not (eq (string-to-char (car addresses)) ?\())) (setq addresses (cdr addresses))) addresses) @@ -5119,17 +5159,24 @@ Otherwise, generate and save a value for `canlock-password' first." nil))) ;; Check the length of the signature. (message-check 'signature - (goto-char (point-max)) - (if (not (re-search-backward message-signature-separator nil t)) - t - (if (>= (count-lines (1+ (point-at-eol)) (point-max)) 5) - (if (message-gnksa-enable-p 'signature) - (y-or-n-p - (format "Signature is excessively long (%d lines). Really post? " - (count-lines (1+ (point-at-eol)) (point-max)))) - (message "Denied posting -- Excessive signature.") - nil) - t))) + (let (sig-start sig-end) + (goto-char (point-max)) + (if (not (re-search-backward message-signature-separator nil t)) + t + (setq sig-start (1+ (point-at-eol))) + (setq sig-end + (if (re-search-forward + "<#/?\\(multipart\\|part\\|external\\|mml\\)" nil t) + (- (point-at-bol) 1) + (point-max))) + (if (>= (count-lines sig-start sig-end) 5) + (if (message-gnksa-enable-p 'signature) + (y-or-n-p + (format "Signature is excessively long (%d lines). Really post? " + (count-lines sig-start sig-end))) + (message "Denied posting -- Excessive signature.") + nil) + t)))) ;; Ensure that text follows last quoted portion. (message-check 'quoting-style (goto-char (point-max)) @@ -5208,6 +5255,13 @@ Otherwise, generate and save a value for `canlock-password' first." (if (and message-fcc-handler-function (not (eq message-fcc-handler-function 'rmail-output))) (funcall message-fcc-handler-function file) + ;; FIXME this option, rmail-output (also used if + ;; message-fcc-handler-function is nil) is not + ;; documented anywhere AFAICS. It should work in Emacs + ;; 23; I suspect it does not work in Emacs 22. + ;; FIXME I don't see the need for the two different cases here. + ;; mail-use-rfc822 makes no difference (in Emacs 23),and + ;; the third argument just controls \"Wrote file\" message. (if (and (file-readable-p file) (mail-file-babyl-p file)) (rmail-output file 1 nil t) (let ((mail-use-rfc822 t)) @@ -6182,14 +6236,14 @@ between beginning of field and beginning of line." nil mua))) -(defun message-setup (headers &optional replybuffer actions +;; YANK-ACTION, if non-nil, can be a buffer or a yank action of the +;; form (FUNCTION . ARGS). +(defun message-setup (headers &optional yank-action actions continue switch-function) (let ((mua (message-mail-user-agent)) - subject to field yank-action) + subject to field) (if (not (and message-this-is-mail mua)) - (message-setup-1 headers replybuffer actions) - (if replybuffer - (setq yank-action (list 'insert-buffer replybuffer))) + (message-setup-1 headers yank-action actions) (setq headers (copy-sequence headers)) (setq field (assq 'Subject headers)) (when field @@ -6206,7 +6260,11 @@ between beginning of field and beginning of line." (format "%s" (car item)) (cdr item))) headers) - continue switch-function yank-action actions))))) + continue switch-function + (if (bufferp yank-action) + (list 'insert-buffer yank-action) + yank-action) + actions))))) (defun message-headers-to-generate (headers included-headers excluded-headers) "Return a list that includes all headers from HEADERS. @@ -6233,12 +6291,16 @@ are not included." (push header result))) (nreverse result))) -(defun message-setup-1 (headers &optional replybuffer actions) +(defun message-setup-1 (headers &optional yank-action actions) (dolist (action actions) (condition-case nil (add-to-list 'message-send-actions `(apply ',(car action) ',(cdr action))))) - (setq message-reply-buffer replybuffer) + (setq message-reply-buffer + (if (and (consp yank-action) + (eq (car yank-action) 'insert-buffer)) + (nth 1 yank-action) + yank-action)) (goto-char (point-min)) ;; Insert all the headers. (mail-header-format @@ -6369,7 +6431,7 @@ OTHER-HEADERS is an alist of header/value pairs. CONTINUE says whether to continue editing a message already being composed. SWITCH-FUNCTION is a function used to switch to and display the mail buffer." (interactive) - (let ((message-this-is-mail t) replybuffer) + (let ((message-this-is-mail t)) (unless (message-mail-user-agent) (message-pop-to-buffer ;; Search for the existing message buffer if `continue' is non-nil. @@ -6380,15 +6442,11 @@ is a function used to switch to and display the mail buffer." message-generate-new-buffers))) (message-buffer-name "mail" to)) switch-function)) - ;; FIXME: message-mail should do something if YANK-ACTION is not - ;; insert-buffer. - (and (consp yank-action) (eq (car yank-action) 'insert-buffer) - (setq replybuffer (nth 1 yank-action))) (message-setup (nconc `((To . ,(or to "")) (Subject . ,(or subject ""))) (when other-headers other-headers)) - replybuffer send-actions continue switch-function) + yank-action send-actions continue switch-function) ;; FIXME: Should return nil if failure. t)) @@ -7218,12 +7276,16 @@ is for the internal use." (message-forward-make-body-plain forward-buffer))) (message-position-point)) +(declare-function rmail-toggle-header "rmail" (&optional arg)) + ;;;###autoload (defun message-forward-rmail-make-body (forward-buffer) (save-window-excursion (set-buffer forward-buffer) (if (rmail-msg-is-pruned) - (rmail-msg-restore-non-pruned-header))) + (if (fboundp 'rmail-msg-restore-non-pruned-header) + (rmail-msg-restore-non-pruned-header) ; Emacs 22 + (rmail-toggle-header 0)))) ; Emacs 23 (message-forward-make-body forward-buffer)) ;; Fixme: Should have defcustom. @@ -7433,10 +7495,8 @@ which specify the range to operate on." (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))) + (goto-char (prog1 (mark t) + (set-marker (mark-marker) (point))))) (defalias 'message-make-overlay 'make-overlay) (defalias 'message-delete-overlay 'delete-overlay) @@ -7641,37 +7701,44 @@ those headers." (point)) (skip-chars-backward "^, \t\n") (point)))) (completion-ignore-case t) - (string (buffer-substring b (progn (skip-chars-forward "^,\t\n ") - (point)))) - (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb)) - (completions (all-completions string hashtb)) - comp) - (delete-region b (point)) - (cond - ((= (length completions) 1) - (if (string= (car completions) string) - (progn - (insert string) - (message "Only matching group")) - (insert (car completions)))) - ((and (setq comp (try-completion string hashtb)) - (not (string= comp string))) - (insert comp)) - (t - (insert string) - (if (not comp) - (message "No matching groups") - (save-selected-window - (pop-to-buffer "*Completions*") - (buffer-disable-undo) - (let ((buffer-read-only nil)) - (erase-buffer) - (let ((standard-output (current-buffer))) - (message-display-completion-list (sort completions 'string<) - string)) - (setq buffer-read-only nil) - (goto-char (point-min)) - (delete-region (point) (progn (forward-line 3) (point)))))))))) + (e (progn (skip-chars-forward "^,\t\n ") (point))) + (hashtb (and (boundp 'gnus-active-hashtb) gnus-active-hashtb))) + (message-completion-in-region e b hashtb))) + +(defalias 'message-completion-in-region + (if (fboundp 'completion-in-region) + 'completion-in-region + (lambda (e b hashtb) + (let* ((string (buffer-substring b e)) + (completions (all-completions string hashtb)) + comp) + (delete-region b (point)) + (cond + ((= (length completions) 1) + (if (string= (car completions) string) + (progn + (insert string) + (message "Only matching group")) + (insert (car completions)))) + ((and (setq comp (try-completion string hashtb)) + (not (string= comp string))) + (insert comp)) + (t + (insert string) + (if (not comp) + (message "No matching groups") + (save-selected-window + (pop-to-buffer "*Completions*") + (buffer-disable-undo) + (let ((buffer-read-only nil)) + (erase-buffer) + (let ((standard-output (current-buffer))) + (message-display-completion-list (sort completions 'string<) + string)) + (setq buffer-read-only nil) + (goto-char (point-min)) + (delete-region (point) + (progn (forward-line 3) (point)))))))))))) (defun message-expand-name () (cond ((and (memq 'eudc message-expand-name-databases)