X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmessage.el;h=63cdc3e84cb2df7b4f50f7cae8b521af34202646;hb=c5a1ec5514a2c218c037d83b81da9043e9f6c321;hp=ec85c9b96eb997b045613fb24395f56abd562a82;hpb=d55aa13d564359a4dff01c15e79c5548aba5e631;p=elisp%2Fgnus.git- diff --git a/lisp/message.el b/lisp/message.el index ec85c9b..63cdc3e 100644 --- a/lisp/message.el +++ b/lisp/message.el @@ -1,5 +1,5 @@ ;;; message.el --- composing mail and news messages -;; Copyright (C) 1996,97 Free Software Foundation, Inc. +;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -30,7 +30,10 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(eval-when-compile + (require 'cl) + (require 'smtp) + ) (require 'mailheader) (require 'nnheader) @@ -163,8 +166,8 @@ Otherwise, most addresses look like `angles', but they look like :group 'message-headers) (defcustom message-syntax-checks nil - ;; Guess this one shouldn't be easy to customize... - "Controls what syntax checks should not be performed on outgoing posts. + ; Guess this one shouldn't be easy to customize... + "*Controls what syntax checks should not be performed on outgoing posts. To disable checking of long signatures, for instance, add `(signature . disabled)' to this list. @@ -180,7 +183,7 @@ shorten-followup-to existing-newsgroups buffer-file-name unchanged." '(From Newsgroups Subject Date Message-ID (optional . Organization) Lines (optional . X-Newsreader)) - "Headers to be generated or prompted for when posting an article. + "*Headers to be generated or prompted for when posting an article. RFC977 and RFC1036 require From, Date, Newsgroups, Subject, Message-ID. Organization, Lines, In-Reply-To, Expires, and X-Newsreader are optional. If don't you want message to insert some @@ -192,7 +195,7 @@ header, remove it from this list." (defcustom message-required-mail-headers '(From Subject Date (optional . In-Reply-To) Message-ID Lines (optional . X-Mailer)) - "Headers to be generated or prompted for when mailing a message. + "*Headers to be generated or prompted for when mailing a message. RFC822 required that From, Date, To, Subject and Message-ID be included. Organization, Lines and X-Mailer are optional." :group 'message-mail @@ -211,13 +214,13 @@ included. Organization, Lines and X-Mailer are optional." :group 'message-headers :type 'regexp) -(defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:" +(defcustom message-ignored-mail-headers "^[GF]cc:\\|^Resent-Fcc:\\|^Xref:" "*Regexp of headers to be removed unconditionally before mailing." :group 'message-mail :group 'message-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:" +(defcustom message-ignored-supersedes-headers "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Xref:\\|^Lines:\\|^Received:\\|^X-From-Line:\\|^X-Trace:\\|^X-Complaints-To:\\|Return-Path:\\|^Supersedes:" "*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." @@ -231,7 +234,9 @@ any confusion." :group 'message-various) (defcustom message-elide-elipsis "\n[...]\n\n" - "*The string which is inserted for elided text.") + "*The string which is inserted for elided text." + :type 'string + :group 'message-various) (defcustom message-interactive nil "Non-nil means when sending a message wait for and display errors. @@ -327,7 +332,8 @@ The headers should be delimited by a line whose contents match the variable `mail-header-separator'. Legal values include `message-send-mail-with-sendmail' (the default), -`message-send-mail-with-mh' and `message-send-mail-with-qmail'." +`message-send-mail-with-mh', `message-send-mail-with-qmail' and +`message-send-mail-with-smtp'." :type '(radio (function-item message-send-mail-with-sendmail) (function-item message-send-mail-with-mh) (function-item message-send-mail-with-qmail) @@ -409,7 +415,7 @@ might set this variable to '(\"-f\" \"you@some.where\")." ((boundp 'gnus-select-method) gnus-select-method) (t '(nnspool ""))) - "Method used to post news." + "*Method used to post news." :group 'message-news :group 'message-sending ;; This should be the `gnus-select-method' widget, but that might @@ -446,8 +452,7 @@ the signature is inserted." :type 'hook) (defcustom message-header-setup-hook nil - "Hook called narrowed to the headers when setting up a message -buffer." + "Hook called narrowed to the headers when setting up a message buffer." :group 'message-various :type 'hook) @@ -476,8 +481,11 @@ Used by `message-yank-original' via `message-yank-cite'." mail-citation-hook) mail-citation-hook 'message-cite-original) - "*Function for citing an original message." + "*Function for citing an original message. +Pre-defined functions include `message-cite-original' and +`message-cite-original-without-signature'." :type '(radio (function-item message-cite-original) + (function-item message-cite-original-without-signature) (function-item sc-cite-original) (function :tag "Other")) :group 'message-insertion) @@ -548,6 +556,7 @@ If stringp, use this; if non-nil, use no host name (user name only)." (define-widget 'message-header-lines 'text "All header lines must be LFD terminated." + :format "%t:%n%v" :valid-regexp "^\\'" :error "All header lines must be newline terminated") @@ -591,7 +600,7 @@ articles." ;; 33 and 126, except colon)", i. e., any chars except ctl chars, ;; space, or colon. '(looking-at "[ \t]\\|[][!\"#$%&'()*+,-./0-9;<=>?@A-Z\\\\^_`a-z{|}~]+:")) - "Set this non-nil if the system's mailer runs the header and body together. + "*Set this non-nil if the system's mailer runs the header and body together. \(This problem exists on Sunos 4 when sendmail is run in remote mode.) The value should be an expression to test whether the problem will actually occur." @@ -780,7 +789,7 @@ Defaults to `text-mode-abbrev-table'.") 1 'message-separator-face) (,(concat "^[ \t]*" "\\([" cite-prefix "]+[" cite-suffix "]*\\)?" - "[>|}].*") + "[:>|}].*") (0 'message-cited-text-face)))) "Additional expressions to highlight in Message mode.") @@ -908,7 +917,7 @@ The cdr of ech entry is a function for applying the face to a region.") (Lines) (Expires) (Message-ID) - (References) + (References . message-fill-references) (X-Mailer) (X-Newsreader)) "Alist used for formatting headers.") @@ -923,7 +932,10 @@ The cdr of ech entry is a function for applying the face to a region.") (autoload 'gnus-output-to-rmail "gnus-util") (autoload 'mail-abbrev-in-expansion-header-p "mailabbrev") (autoload 'nndraft-request-associate-buffer "nndraft") - (autoload 'nndraft-request-expire-articles "nndraft")) + (autoload 'nndraft-request-expire-articles "nndraft") + (autoload 'gnus-open-server "gnus-int") + (autoload 'gnus-request-post "gnus-int") + (autoload 'rmail-output "rmail")) @@ -1258,6 +1270,7 @@ C-c C-w message-insert-signature (insert `message-signature-file' file). C-c C-y message-yank-original (insert current message, if any). C-c C-q message-fill-yanked-message (fill what was yanked). C-c C-e message-elide-region (elide the text between point and mark). +C-c C-z message-kill-to-signature (kill the text up to the signature). C-c C-r message-caesar-buffer-body (rot13 the message body)." (interactive) (kill-all-local-variables) @@ -1321,10 +1334,10 @@ C-c C-r message-caesar-buffer-body (rot13 the message body)." (mail-abbrevs-setup) (funcall (intern "mail-aliases-setup")))) (message-set-auto-save-file-name) - (run-hooks 'text-mode-hook 'message-mode-hook) (unless (string-match "XEmacs" emacs-version) (set (make-local-variable 'font-lock-defaults) - '(message-font-lock-keywords t)))) + '(message-font-lock-keywords t))) + (run-hooks 'text-mode-hook 'message-mode-hook)) @@ -1458,7 +1471,11 @@ With the prefix argument FORCE, insert the header anyway." (interactive) (let ((point (point))) (message-goto-signature) - (kill-region point (point)))) + (unless (eobp) + (forward-line -2)) + (kill-region point (point)) + (unless (bolp) + (insert "\n")))) (defun message-newline-and-reformat () "Insert four newlines, and then reformat if inside quoted text." @@ -1514,8 +1531,9 @@ With the prefix argument FORCE, insert the header anyway." (or (bolp) (insert "\n"))))) (defun message-elide-region (b e) - "Elide the text between point and mark. An ellipsis (from -message-elide-elipsis) will be inserted where the text was killed." + "Elide the text between point and mark. +An ellipsis (from `message-elide-elipsis') will be inserted where the +text was killed." (interactive "r") (kill-region b e) (unless (bolp) @@ -1697,6 +1715,26 @@ prefix, and don't delete any headers." (unless modified (setq message-checksum (cons (message-checksum) (buffer-size))))))) +(defun message-cite-original-without-signature () + "Cite function in the standard Message manner." + (let ((start (point)) + (end (mark t)) + (functions + (when message-indent-citation-function + (if (listp message-indent-citation-function) + message-indent-citation-function + (list message-indent-citation-function))))) + (goto-char end) + (when (re-search-backward "^-- $" start t) + (delete-region (point) end)) + (goto-char start) + (while functions + (funcall (pop functions))) + (when message-citation-line-function + (unless (bolp) + (insert "\n")) + (funcall message-citation-line-function)))) + (defun message-cite-original () "Cite function in the standard Message manner." (let ((start (point)) @@ -1791,6 +1829,8 @@ The text will also be indented the normal way." (defun message-dont-send () "Don't send the message you have been editing." (interactive) + (set-buffer-modified-p t) + (save-buffer) (let ((actions message-postpone-actions)) (message-bury (current-buffer)) (message-do-actions actions))) @@ -1823,15 +1863,9 @@ Otherwise any failure is reported in a message back to the user from the mailer." (interactive "P") ;; Disabled test. - (when (if (and buffer-file-name - nil) - (y-or-n-p (format "Send buffer contents as %s message? " - (if (message-mail-p) - (if (message-news-p) "mail and news" "mail") - "news"))) - (or (buffer-modified-p) - (message-check-element 'unchanged) - (y-or-n-p "No changes in the buffer; really send? "))) + (when (or (buffer-modified-p) + (message-check-element 'unchanged) + (y-or-n-p "No changes in the buffer; really send? ")) ;; Make it possible to undo the coming changes. (undo-boundary) (let ((inhibit-read-only t)) @@ -1983,7 +2017,8 @@ the user from the mailer." (save-excursion (set-buffer errbuf) (erase-buffer)))) - (let ((default-directory "/")) + (let ((default-directory "/") + (coding-system-for-write 'binary)) (apply 'call-process-region (append (list (point-min) (point-max) (if (boundp 'sendmail-program) @@ -2031,27 +2066,28 @@ to find out how to use this." (run-hooks 'message-send-mail-hook) ;; send the message (case - (apply - 'call-process-region 1 (point-max) message-qmail-inject-program - nil nil nil - ;; qmail-inject's default behaviour is to look for addresses on the - ;; command line; if there're none, it scans the headers. - ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. - ;; - ;; in general, ALL of qmail-inject's defaults are perfect for simply - ;; reading a formatted (i. e., at least a To: or Resent-To header) - ;; message from stdin. - ;; - ;; qmail also has the advantage of not having been raped by - ;; various vendors, so we don't have to allow for that, either -- - ;; compare this with message-send-mail-with-sendmail and weep - ;; for sendmail's lost innocence. - ;; - ;; all this is way cool coz it lets us keep the arguments entirely - ;; free for -inject-arguments -- a big win for the user and for us - ;; since we don't have to play that double-guessing game and the user - ;; gets full control (no gestapo'ish -f's, for instance). --sj - message-qmail-inject-args) + (let ((coding-system-for-write 'binary)) + (apply + 'call-process-region 1 (point-max) message-qmail-inject-program + nil nil nil + ;; qmail-inject's default behaviour is to look for addresses on the + ;; command line; if there're none, it scans the headers. + ;; yes, it does The Right Thing w.r.t. Resent-To and it's kin. + ;; + ;; in general, ALL of qmail-inject's defaults are perfect for simply + ;; reading a formatted (i. e., at least a To: or Resent-To header) + ;; message from stdin. + ;; + ;; qmail also has the advantage of not having been raped by + ;; various vendors, so we don't have to allow for that, either -- + ;; compare this with message-send-mail-with-sendmail and weep + ;; for sendmail's lost innocence. + ;; + ;; all this is way cool coz it lets us keep the arguments entirely + ;; free for -inject-arguments -- a big win for the user and for us + ;; since we don't have to play that double-guessing game and the user + ;; gets full control (no gestapo'ish -f's, for instance). --sj + message-qmail-inject-args)) ;; qmail-inject doesn't say anything on it's stdout/stderr, ;; we have to look at the retval instead (0 nil) @@ -2202,14 +2238,15 @@ to find out how to use this." ;; ;; ;; - (let ((smtp-recipient-address-list + (let ((recipient-address-list (or resend-to-addresses (smtp-deduce-address-list (current-buffer) (point-min) delimline)))) (smtp-do-bcc delimline) - (if smtp-recipient-address-list - (if (not (smtp-via-smtp smtp-recipient-address-list tembuf)) + (if recipient-address-list + (if (not (smtp-via-smtp recipient-address-list + (current-buffer))) (error "Sending failed; SMTP protocol error")) (error "Sending failed; no recipients")) )) @@ -2413,8 +2450,12 @@ to find out how to use this." (let* ((case-fold-search t) (message-id (message-fetch-field "message-id" t))) (or (not message-id) + ;; Is there an @ in the ID? (and (string-match "@" message-id) - (string-match "@[^\\.]*\\." message-id)) + ;; Is there a dot in the ID? + (string-match "@[^.]*\\." message-id) + ;; Does the ID end with a dot? + (not (string-match "\\.>" message-id))) (y-or-n-p (format "The Message-ID looks strange: \"%s\". Really post? " message-id))))) @@ -2600,8 +2641,7 @@ to find out how to use this." (while (setq file (message-fetch-field "fcc")) (push file list) (message-remove-header "fcc" nil t))) - (run-hooks 'message-header-hook) - (run-hooks 'message-before-do-fcc-hook) + (run-hooks 'message-header-hook 'message-before-do-fcc-hook) (goto-char (point-min)) (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$")) (replace-match "" t t) @@ -3040,7 +3080,7 @@ Headers already prepared in the buffer are not modified." (insert "Original-") (beginning-of-line)) (when (or (message-news-p) - (string-match "^[^@]@.+\\..+" secure-sender)) + (string-match "^[^@]+@.+\\..+" secure-sender)) (insert "Sender: " secure-sender "\n"))))))) (defun message-insert-courtesy-copy () @@ -3094,9 +3134,16 @@ Headers already prepared in the buffer are not modified." (widen) (forward-line 1))) +(defun message-fill-references (header value) + (insert (capitalize (symbol-name header)) + ": " + (std11-fill-msg-id-list-string + (if (consp value) (car value) value)) + "\n")) + (defun message-fill-header (header value) (let ((begin (point)) - (fill-column 78) + (fill-column 990) (fill-prefix "\t")) (insert (capitalize (symbol-name header)) ": " @@ -3527,18 +3574,20 @@ responses here are directed to other newsgroups.")) (unless (message-news-p) (error "This is not a news article; canceling is impossible")) (when (yes-or-no-p "Do you really want to cancel this article? ") - (let (from newsgroups message-id distribution buf) + (let (from newsgroups message-id distribution buf sender) (save-excursion ;; Get header info. from original article. (save-restriction (message-narrow-to-head) (setq from (message-fetch-field "from") + sender (message-fetch-field "sender") newsgroups (message-fetch-field "newsgroups") message-id (message-fetch-field "message-id" t) distribution (message-fetch-field "distribution"))) ;; Make sure that this article was written by the user. (unless (string-equal - (downcase (cadr (std11-extract-address-components from))) + (downcase + (or sender (cadr (std11-extract-address-components from)))) (downcase (message-make-address))) (error "This article is not yours")) ;; Make control message. @@ -3697,7 +3746,7 @@ Optional NEWS will use news to forward instead of mail." (goto-char (point-max))) (insert mail-header-separator) ;; Rename all old ("Also-")Resent headers. - (while (re-search-backward "^\\(Also-\\)?Resent-" beg t) + (while (re-search-backward "^\\(Also-\\)*Resent-" beg t) (beginning-of-line) (insert "Also-")) ;; Quote any "From " lines at the beginning. @@ -3863,6 +3912,7 @@ Do a `tab-to-tab-stop' if not in those headers." (defvar gnus-active-hashtb) (defun message-expand-group () + "Expand the group name under point." (let* ((b (save-excursion (save-restriction (narrow-to-region